FS/FS/Misc.pm

   1 package FS::Misc;
   2
   3 use strict;
   4 use vars qw ( @ISA @EXPORT_OK $DEBUG $DISABLE_ALL_NOTICES );
   5 use Exporter;
   6 use Carp;
   7 use Data::Dumper;
   8 use IPC::Run qw( run timeout );   # for _pslatex
   9 use IPC::Run3; # for do_print... should just use IPC::Run i guess
  10 use File::Temp;
  11 use Tie::IxHash;
  12 use Encode;
  13 #do NOT depend on any FS:: modules here, causes weird (sometimes unreproducable
  14 #until on client machine) dependancy loops.  put them in FS::Misc::Something
  15 #instead
  16
  17 @ISA = qw( Exporter );
  18 @EXPORT_OK = qw( send_email generate_email send_fax
  19                  states_hash counties cities state_label
  20                  card_types
  21                  pkg_freqs
  22                  generate_ps generate_pdf do_print
  23                  csv_from_fixed
  24                  ocr_image
  25                  money_pretty
  26                );
  27
  28 $DEBUG = 0;
  29
  30 =head1 NAME
  31
  32 FS::Misc - Miscellaneous subroutines
  33
  34 =head1 SYNOPSIS
  35
  36   use FS::Misc qw(send_email);
  37
  38   send_email();
  39
  40 =head1 DESCRIPTION
  41
  42 Miscellaneous subroutines.  This module contains miscellaneous subroutines
  43 called from multiple other modules.  These are not OO or necessarily related,
  44 but are collected here to eliminate code duplication.
  45
  46 =head1 DISABLE ALL NOTICES
  47
  48 Set $FS::Misc::DISABLE_ALL_NOTICES to suppress:
  49
  50 =over 4
  51
  52 =item FS::cust_bill::send_csv
  53
  54 =item FS::cust_bill::spool_csv
  55
  56 =item FS::msg_template::email::send_prepared
  57
  58 =item FS::Misc::send_email
  59
  60 =item FS::Misc::do_print
  61
  62 =item FS::Misc::send_fax
  63
  64 =item FS::Template_Mixin::postal_mail_fsinc
  65
  66 =back
  67
  68 =cut
  69
  70 $DISABLE_ALL_NOTICES = 0;
  71
  72 =head1 SUBROUTINES
  73
  74 =over 4
  75
  76 =item send_email OPTION => VALUE ...
  77
  78 Options:
  79
  80 =over 4
  81
  82 =item from
  83
  84 (required)
  85
  86 =item to
  87
  88 (required) comma-separated scalar or arrayref of recipients
  89
  90 =item subject
  91
  92 (required)
  93
  94 =item content-type
  95
  96 (optional) MIME type for the body
  97
  98 =item body
  99
 100 (required unless I<nobody> is true) arrayref of body text lines
 101
 102 =item mimeparts
 103
 104 (optional, but required if I<nobody> is true) arrayref of MIME::Entity->build PARAMHASH refs or MIME::Entity objects.  These will be passed as arguments to MIME::Entity->attach().
 105
 106 =item nobody
 107
 108 (optional) when set true, send_email will ignore the I<body> option and simply construct a message with the given I<mimeparts>.  In this case,
 109 I<content-type>, if specified, overrides the default "multipart/mixed" for the outermost MIME container.
 110
 111 =item content-encoding
 112
 113 (optional) when using nobody, optional top-level MIME
 114 encoding which, if specified, overrides the default "7bit".
 115
 116 =item type
 117
 118 (optional) type parameter for multipart/related messages
 119
 120 =item custnum
 121
 122 (optional) L<FS::cust_main> key; if passed, the message will be logged
 123 (if logging is enabled) with this custnum.
 124
 125 =item msgnum
 126
 127 (optional) L<FS::msg_template> key, for logging.
 128
 129 =back
 130
 131 =cut
 132
 133 use vars qw( $conf );
 134 use Date::Format;
 135 use MIME::Entity;
 136 use Email::Sender::Simple qw(sendmail);
 137 use Email::Sender::Transport::SMTP;
 138 use Email::Sender::Transport::SMTP::TLS 0.11;
 139 use FS::UID;
 140
 141 FS::UID->install_callback( sub {
 142   $conf = new FS::Conf;
 143 } );
 144
 145 sub send_email {
 146   my(%options) = @_;
 147
 148   if ( $DISABLE_ALL_NOTICES ) {
 149     warn 'send_email() disabled by $FS::Misc::DISABLE_ALL_NOTICES' if $DEBUG;
 150     return;
 151   }
 152
 153   if ( $DEBUG ) {
 154     my %doptions = %options;
 155     $doptions{'body'} = '(full body not shown in debug)';
 156     warn "FS::Misc::send_email called with options:\n  ". Dumper(\%doptions);
 157 #         join("\n", map { "  $_: ". $options{$_} } keys %options ). "\n"
 158   }
 159
 160   my @to = ref($options{to}) ? @{ $options{to} } : ( $options{to} );
 161
 162   my @mimeargs = ();
 163   my @mimeparts = ();
 164   if ( $options{'nobody'} ) {
 165
 166     croak "'mimeparts' option required when 'nobody' option given\n"
 167       unless $options{'mimeparts'};
 168
 169     @mimeparts = @{$options{'mimeparts'}};
 170
 171     @mimeargs = (
 172       'Type'         => ( $options{'content-type'} || 'multipart/mixed' ),
 173       'Encoding'     => ( $options{'content-encoding'} || '7bit' ),
 174     );
 175
 176   } else {
 177
 178     @mimeparts = @{$options{'mimeparts'}}
 179       if ref($options{'mimeparts'}) eq 'ARRAY';
 180
 181     if (scalar(@mimeparts)) {
 182
 183       @mimeargs = (
 184         'Type'     => 'multipart/mixed',
 185         'Encoding' => '7bit',
 186       );
 187
 188       unshift @mimeparts, {
 189         'Type'        => ( $options{'content-type'} || 'text/plain' ),
 190         'Charset'     => 'UTF-8',
 191         'Data'        => ( $options{'content-type'} =~ /^text\//
 192                              ? Encode::encode_utf8( $options{'body'} )
 193                              : $options{'body'}
 194                          ),
 195         'Encoding'    => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
 196         'Disposition' => 'inline',
 197       };
 198
 199     } else {
 200
 201       @mimeargs = (
 202         'Type'     => ( $options{'content-type'} || 'text/plain' ),
 203         'Data'     => ( $options{'content-type'} =~ /^text\//
 204                           ? Encode::encode_utf8( $options{'body'} )
 205                           : $options{'body'}
 206                       ),
 207         'Encoding' => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
 208         'Charset'  => 'UTF-8',
 209       );
 210
 211     }
 212
 213   }
 214
 215   my $from = $options{from};
 216   $from =~ s/^\s*//; $from =~ s/\s*$//;
 217   if ( $from =~ /^(.*)\s*<(.*@.*)>$/ ) {
 218     # a common idiom
 219     $from = $2;
 220   }
 221
 222   my $domain;
 223   if ( $from =~ /\@([\w\.\-]+)/ ) {
 224     $domain = $1;
 225   } else {
 226     warn 'no domain found in invoice from address '. $options{'from'}.
 227          '; constructing Message-ID (and saying HELO) @example.com';
 228     $domain = 'example.com';
 229   }
 230   my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
 231
 232   my $time = time;
 233   my $message = MIME::Entity->build(
 234     'From'       => $options{'from'},
 235     'To'         => join(', ', @to),
 236     'Sender'     => $options{'from'},
 237     'Reply-To'   => $options{'from'},
 238     'Date'       => time2str("%a, %d %b %Y %X %z", $time),
 239     'Subject'    => Encode::encode('MIME-Header', $options{'subject'}),
 240     'Message-ID' => "<$message_id>",
 241     @mimeargs,
 242   );
 243
 244   if ( $options{'type'} ) {
 245     #false laziness w/cust_bill::generate_email
 246     $message->head->replace('Content-type',
 247       $message->mime_type.
 248       '; boundary="'. $message->head->multipart_boundary. '"'.
 249       '; type='. $options{'type'}
 250     );
 251   }
 252
 253   foreach my $part (@mimeparts) {
 254
 255     if ( UNIVERSAL::isa($part, 'MIME::Entity') ) {
 256
 257       warn "attaching MIME part from MIME::Entity object\n"
 258         if $DEBUG;
 259       $message->add_part($part);
 260
 261     } elsif ( ref($part) eq 'HASH' ) {
 262
 263       warn "attaching MIME part from hashref:\n".
 264            join("\n", map "  $_: ".$part->{$_}, keys %$part ). "\n"
 265         if $DEBUG;
 266       $message->attach(%$part);
 267
 268     } else {
 269       croak "mimepart $part isn't a hashref or MIME::Entity object!";
 270     }
 271
 272   }
 273
 274   #send the email
 275
 276   my %smtp_opt = ( 'host' => $conf->config('smtpmachine'),
 277                    'helo' => $domain,
 278                  );
 279
 280   my($port, $enc) = split('-', ($conf->config('smtp-encryption') || '25') );
 281   $smtp_opt{'port'} = $port;
 282
 283   my $error = '';
 284   my $transport;
 285   if ( defined($enc) && $enc eq 'starttls' ) {
 286     foreach (qw(username password)) {
 287       $smtp_opt{$_} = $conf->config("smtp-$_");
 288       $error = "SMTP settings misconfiguration: ".
 289                "STARTTLS enabled in smtp-encryption but smtp-$_ missing"
 290         if ! length($smtp_opt{$_});
 291     }
 292     $transport = Email::Sender::Transport::SMTP::TLS->new( %smtp_opt );
 293   } else {
 294     if ( $conf->exists('smtp-username') && $conf->exists('smtp-password') ) {
 295       $smtp_opt{"sasl_$_"} = $conf->config("smtp-$_") for qw(username password);
 296     }
 297     $smtp_opt{'ssl'} = 1 if defined($enc) && $enc eq 'tls';
 298     $transport = Email::Sender::Transport::SMTP->new( %smtp_opt );
 299   }
 300
 301   push @to, $options{bcc} if defined($options{bcc});
 302   # fully unpack all addresses found in @to (including Bcc) to make the
 303   # envelope list
 304   my @env_to;
 305   foreach my $dest (@to) {
 306     push @env_to, map { $_->address } Email::Address->parse($dest);
 307   }
 308
 309   unless ( length($error) ) {
 310
 311     local $SIG{__DIE__}; # don't want Mason __DIE__ handler active
 312     local $@; # just in case
 313     eval { sendmail($message, { transport => $transport,
 314                                 from      => $from,
 315                                 to        => \@env_to }) };
 316
 317     if (ref($@) and $@->isa('Email::Sender::Failure')) {
 318       $error = $@->code.' ' if $@->code;
 319       $error .= $@->message;
 320     } else {
 321       $error = $@;
 322     }
 323
 324   }
 325
 326   # Logging
 327   if ( $conf->exists('log_sent_mail') ) {
 328     my $cust_msg = FS::cust_msg->new({
 329         'env_from'  => $options{'from'},
 330         'env_to'    => join(', ', @env_to),
 331         'header'    => $message->header_as_string,
 332         'body'      => $message->body_as_string,
 333         '_date'     => $time,
 334         'error'     => $error,
 335         'custnum'   => $options{'custnum'},
 336         'msgnum'    => $options{'msgnum'},
 337         'status'    => ($error ? 'failed' : 'sent'),
 338         'msgtype'   => $options{'msgtype'},
 339     });
 340     my $log_error = $cust_msg->insert;
 341     warn "Error logging message: $log_error\n" if $log_error; # at least warn
 342   }
 343
 344   $error;
 345
 346 }
 347
 348 =item generate_email OPTION => VALUE ...
 349
 350 Options:
 351
 352 =over 4
 353
 354 =item from
 355
 356 Sender address, required
 357
 358 =item to
 359
 360 Recipient address, required
 361
 362 =item bcc
 363
 364 Blind copy address, optional
 365
 366 =item subject
 367
 368 email subject, required
 369
 370 =item html_body
 371
 372 Email body (HTML alternative).  Arrayref of lines, or scalar.
 373
 374 Will be placed inside an HTML <BODY> tag.
 375
 376 =item text_body
 377
 378 Email body (Text alternative).  Arrayref of lines, or scalar.
 379
 380 =item custnum, msgnum (optional)
 381
 382 Customer and template numbers, passed through to send_email for logging.
 383
 384 =back
 385
 386 Constructs a multipart message from text_body and html_body.
 387
 388 =cut
 389
 390 #false laziness w/FS::cust_bill::generate_email
 391
 392 use MIME::Entity;
 393 use HTML::Entities;
 394
 395 sub generate_email {
 396   my %args = @_;
 397
 398   my $me = '[FS::Misc::generate_email]';
 399
 400   my @fields = qw(from to bcc subject custnum msgnum msgtype);
 401   my %return;
 402   @return{@fields} = @args{@fields};
 403
 404   warn "$me creating HTML/text multipart message"
 405     if $DEBUG;
 406
 407   $return{'nobody'} = 1;
 408
 409   my $alternative = build MIME::Entity
 410     'Type'        => 'multipart/alternative',
 411     'Encoding'    => '7bit',
 412     'Disposition' => 'inline'
 413   ;
 414
 415   my $data;
 416   if ( ref($args{'text_body'}) eq 'ARRAY' ) {
 417     $data = join("\n", @{ $args{'text_body'} });
 418   } else {
 419     $data = $args{'text_body'};
 420   }
 421
 422   $alternative->attach(
 423     'Type'        => 'text/plain',
 424     'Encoding'    => 'quoted-printable',
 425     'Charset'     => 'UTF-8',
 426     #'Encoding'    => '7bit',
 427     'Data'        => Encode::encode_utf8($data),
 428     'Disposition' => 'inline',
 429   );
 430
 431   my @html_data;
 432   if ( ref($args{'html_body'}) eq 'ARRAY' ) {
 433     @html_data = @{ $args{'html_body'} };
 434   } else {
 435     @html_data = split(/\n/, $args{'html_body'});
 436   }
 437
 438   $alternative->attach(
 439     'Type'        => 'text/html',
 440     'Encoding'    => 'quoted-printable',
 441     'Data'        => [ '<html>',
 442                        '  <head>',
 443                        '    <title>',
 444                        '      '. encode_entities($return{'subject'}),
 445                        '    </title>',
 446                        '  </head>',
 447                        '  <body bgcolor="#ffffff">',
 448                        ( map Encode::encode_utf8($_), @html_data ),
 449                        '  </body>',
 450                        '</html>',
 451                      ],
 452     'Disposition' => 'inline',
 453     #'Filename'    => 'invoice.pdf',
 454   );
 455
 456   #no other attachment:
 457   # multipart/related
 458   #   multipart/alternative
 459   #     text/plain
 460   #     text/html
 461
 462   $return{'content-type'} = 'multipart/related';
 463   $return{'mimeparts'} = [ $alternative ];
 464   $return{'type'} = 'multipart/alternative'; #Content-Type of first part...
 465   #$return{'disposition'} = 'inline';
 466
 467   %return;
 468
 469 }
 470
 471 =item send_fax OPTION => VALUE ...
 472
 473 Options:
 474
 475 I<dialstring> - (required) 10-digit phone number w/ area code
 476
 477 I<docdata> - (required) Array ref containing PostScript or TIFF Class F document
 478
 479 -or-
 480
 481 I<docfile> - (required) Filename of PostScript TIFF Class F document
 482
 483 ...any other options will be passed to L<Fax::Hylafax::Client::sendfax>
 484
 485
 486 =cut
 487
 488 sub send_fax {
 489
 490   my %options = @_;
 491
 492   die 'HylaFAX support has not been configured.'
 493     unless $conf->exists('hylafax');
 494
 495   if ( $DISABLE_ALL_NOTICES ) {
 496     warn 'send_fax() disabled by $FS::Misc::DISABLE_ALL_NOTICES' if $DEBUG;
 497     return;
 498   }
 499
 500   eval {
 501     require Fax::Hylafax::Client;
 502   };
 503
 504   if ($@) {
 505     if ($@ =~ /^Can't locate Fax.*/) {
 506       die "You must have Fax::Hylafax::Client installed to use invoice faxing."
 507     } else {
 508       die $@;
 509     }
 510   }
 511
 512   my %hylafax_opts = map { split /\s+/ } $conf->config('hylafax');
 513
 514   die 'Called send_fax without a \'dialstring\'.'
 515     unless exists($options{'dialstring'});
 516
 517   if (exists($options{'docdata'}) and ref($options{'docdata'}) eq 'ARRAY') {
 518       my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 519       my $fh = new File::Temp(
 520         TEMPLATE => 'faxdoc.'. $options{'dialstring'} . '.XXXXXXXX',
 521         DIR      => $dir,
 522         UNLINK   => 0,
 523       ) or die "can't open temp file: $!\n";
 524
 525       $options{docfile} = $fh->filename;
 526
 527       print $fh @{$options{'docdata'}};
 528       close $fh;
 529
 530       delete $options{'docdata'};
 531   }
 532
 533   die 'Called send_fax without a \'docfile\' or \'docdata\'.'
 534     unless exists($options{'docfile'});
 535
 536   #FIXME: Need to send canonical dialstring to HylaFAX, but this only
 537   #       works in the US.
 538
 539   $options{'dialstring'} =~ s/[^\d\+]//g;
 540   if ($options{'dialstring'} =~ /^\d{10}$/) {
 541     $options{dialstring} = '+1' . $options{'dialstring'};
 542   } else {
 543     return 'Invalid dialstring ' . $options{'dialstring'} . '.';
 544   }
 545
 546   my $faxjob = &Fax::Hylafax::Client::sendfax(%options, %hylafax_opts);
 547
 548   if ($faxjob->success) {
 549     warn "Successfully queued fax to '$options{dialstring}' with jobid " .
 550            $faxjob->jobid
 551       if $DEBUG;
 552     return '';
 553   } else {
 554     return 'Error while sending FAX: ' . $faxjob->trace;
 555   }
 556
 557 }
 558
 559 =item states_hash COUNTRY
 560
 561 Returns a list of key/value pairs containing state (or other sub-country
 562 division) abbriviations and names.
 563
 564 =cut
 565
 566 use FS::Record qw(qsearch);
 567 use Locale::SubCountry;
 568
 569 sub states_hash {
 570   my($country) = @_;
 571
 572   #a hash?  not expecting an explosion of business from unrecognized countries..
 573   return states_hash_nosubcountry($country) if $country eq 'XC';
 574
 575   my @states =
 576 #     sort
 577      map { s/[\n\r]//g; $_; }
 578      map { $_->state; }
 579          qsearch({
 580                    'select'    => 'state',
 581                    'table'     => 'cust_main_county',
 582                    'hashref'   => { 'country' => $country },
 583                    'extra_sql' => 'GROUP BY state',
 584                 });
 585
 586   #it could throw a fatal "Invalid country code" error (for example "AX")
 587   my $subcountry = eval { new Locale::SubCountry($country) }
 588     or return (); # ( '', '(n/a)' );
 589
 590   #"i see your schwartz is as big as mine!"
 591   map  { ( $_->[0] => $_->[1] ) }
 592   sort { $a->[1] cmp $b->[1] }
 593   map  { [ $_ => state_label($_, $subcountry) ] }
 594        @states;
 595 }
 596
 597 sub states_hash_nosubcountry {
 598   my($country) = @_;
 599
 600   my @states =
 601 #     sort
 602      map { s/[\n\r]//g; $_; }
 603      map { $_->state; }
 604          qsearch({
 605                    'select'    => 'state',
 606                    'table'     => 'cust_main_county',
 607                    'hashref'   => { 'country' => $country },
 608                    'extra_sql' => 'GROUP BY state',
 609                 });
 610
 611   #"i see your schwartz is as big as mine!"
 612   map  { ( $_->[0] => $_->[1] ) }
 613   sort { $a->[1] cmp $b->[1] }
 614   map  { [ $_ => $_ ] }
 615        @states;
 616 }
 617
 618 =item counties STATE COUNTRY
 619
 620 Returns a list of counties for this state and country.
 621
 622 =cut
 623
 624 sub counties {
 625   my( $state, $country ) = @_;
 626
 627   map { $_ } #return num_counties($state, $country) unless wantarray;
 628   sort map { s/[\n\r]//g; $_; }
 629        map { $_->county }
 630            qsearch({
 631              'select'  => 'DISTINCT county',
 632              'table'   => 'cust_main_county',
 633              'hashref' => { 'state'   => $state,
 634                             'country' => $country,
 635                           },
 636            });
 637 }
 638
 639 =item cities COUNTY STATE COUNTRY
 640
 641 Returns a list of cities for this county, state and country.
 642
 643 =cut
 644
 645 sub cities {
 646   my( $county, $state, $country ) = @_;
 647
 648   map { $_ } #return num_cities($county, $state, $country) unless wantarray;
 649   sort map { s/[\n\r]//g; $_; }
 650        map { $_->city }
 651            qsearch({
 652              'select'  => 'DISTINCT city',
 653              'table'   => 'cust_main_county',
 654              'hashref' => { 'county'  => $county,
 655                             'state'   => $state,
 656                             'country' => $country,
 657                           },
 658            });
 659 }
 660
 661 =item state_label STATE COUNTRY_OR_LOCALE_SUBCOUNRY_OBJECT
 662
 663 =cut
 664
 665 sub state_label {
 666   my( $state, $country ) = @_;
 667
 668   unless ( ref($country) ) {
 669     $country = eval { new Locale::SubCountry($country) }
 670       or return'(n/a)';
 671
 672   }
 673
 674   # US kludge to avoid changing existing behaviour
 675   # also we actually *use* the abbriviations...
 676   my $full_name = $country->country_code eq 'US'
 677                     ? ''
 678                     : $country->full_name($state);
 679
 680   $full_name = '' if $full_name eq 'unknown';
 681   $full_name =~ s/\(see also.*\)\s*$//;
 682   $full_name .= " ($state)" if $full_name;
 683
 684   $full_name || $state || '(n/a)';
 685
 686 }
 687
 688 =item card_types
 689
 690 Returns a hash reference of the accepted credit card types.  Keys are shorter
 691 identifiers and values are the longer strings used by the system (see
 692 L<Business::CreditCard>).
 693
 694 =cut
 695
 696 #$conf from above
 697
 698 sub card_types {
 699   my $conf = new FS::Conf;
 700
 701   my %card_types = (
 702     #displayname                    #value (Business::CreditCard)
 703     "VISA"                       => "VISA card",
 704     "MasterCard"                 => "MasterCard",
 705     "Discover"                   => "Discover card",
 706     "American Express"           => "American Express card",
 707     "Diner's Club/Carte Blanche" => "Diner's Club/Carte Blanche",
 708     "enRoute"                    => "enRoute",
 709     "JCB"                        => "JCB",
 710     "BankCard"                   => "BankCard",
 711     "Switch"                     => "Switch",
 712     "Solo"                       => "Solo",
 713   );
 714   my @conf_card_types = grep { ! /^\s*$/ } $conf->config('card-types');
 715   if ( @conf_card_types ) {
 716     #perhaps the hash is backwards for this, but this way works better for
 717     #usage in selfservice
 718     %card_types = map  { $_ => $card_types{$_} }
 719                   grep {
 720                          my $d = $_;
 721                            grep { $card_types{$d} eq $_ } @conf_card_types
 722                        }
 723                     keys %card_types;
 724   }
 725
 726   \%card_types;
 727 }
 728
 729 =item pkg_freqs
 730
 731 Returns a hash reference of allowed package billing frequencies.
 732
 733 =cut
 734
 735 sub pkg_freqs {
 736   tie my %freq, 'Tie::IxHash', (
 737     '0'    => '(no recurring fee)',
 738     '1h'   => 'hourly',
 739     '1d'   => 'daily',
 740     '2d'   => 'every two days',
 741     '3d'   => 'every three days',
 742     '1w'   => 'weekly',
 743     '2w'   => 'biweekly (every 2 weeks)',
 744     '1'    => 'monthly',
 745     '45d'  => 'every 45 days',
 746     '2'    => 'bimonthly (every 2 months)',
 747     '3'    => 'quarterly (every 3 months)',
 748     '4'    => 'every 4 months',
 749     '137d' => 'every 4 1/2 months (137 days)',
 750     '6'    => 'semiannually (every 6 months)',
 751     '12'   => 'annually',
 752     '13'   => 'every 13 months (annually +1 month)',
 753     '24'   => 'biannually (every 2 years)',
 754     '36'   => 'triannually (every 3 years)',
 755     '48'   => '(every 4 years)',
 756     '60'   => '(every 5 years)',
 757     '120'  => '(every 10 years)',
 758   ) ;
 759   \%freq;
 760 }
 761
 762 =item generate_ps FILENAME
 763
 764 Returns an postscript rendition of the LaTex file, as a scalar.
 765 FILENAME does not contain the .tex suffix and is unlinked by this function.
 766
 767 =cut
 768
 769 use String::ShellQuote;
 770
 771 sub generate_ps {
 772   my $file = shift;
 773
 774   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 775   chdir($dir);
 776
 777   _pslatex($file);
 778
 779   my $papersize = $conf->config('papersize') || 'letter';
 780
 781   local($SIG{CHLD}) = sub {};
 782
 783   system('dvips', '-q', '-t', $papersize, "$file.dvi", '-o', "$file.ps" ) == 0
 784     or die "dvips failed";
 785
 786   open(POSTSCRIPT, "<$file.ps")
 787     or die "can't open $file.ps: $! (error in LaTeX template?)\n";
 788
 789   unlink("$file.dvi", "$file.log", "$file.aux", "$file.ps", "$file.tex")
 790     unless $FS::CurrentUser::CurrentUser->option('save_tmp_typesetting');
 791
 792   my $ps = '';
 793
 794   if ( $conf->exists('lpr-postscript_prefix') ) {
 795     my $prefix = $conf->config('lpr-postscript_prefix');
 796     $ps .= eval qq("$prefix");
 797   }
 798
 799   while (<POSTSCRIPT>) {
 800     $ps .= $_;
 801   }
 802
 803   close POSTSCRIPT;
 804
 805   if ( $conf->exists('lpr-postscript_suffix') ) {
 806     my $suffix = $conf->config('lpr-postscript_suffix');
 807     $ps .= eval qq("$suffix");
 808   }
 809
 810   return $ps;
 811
 812 }
 813
 814 =item generate_pdf FILENAME
 815
 816 Returns an PDF rendition of the LaTex file, as a scalar.  FILENAME does not
 817 contain the .tex suffix and is unlinked by this function.
 818
 819 =cut
 820
 821 use String::ShellQuote;
 822
 823 sub generate_pdf {
 824   my $file = shift;
 825
 826   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 827   chdir($dir);
 828
 829   #system('pdflatex', "$file.tex");
 830   #system('pdflatex', "$file.tex");
 831   #! LaTeX Error: Unknown graphics extension: .eps.
 832
 833   _pslatex($file);
 834
 835   my $sfile = shell_quote $file;
 836
 837   #system('dvipdf', "$file.dvi", "$file.pdf" );
 838   my $papersize = $conf->config('papersize') || 'letter';
 839
 840   local($SIG{CHLD}) = sub {};
 841
 842   system(
 843     "dvips -q -f $sfile.dvi -t $papersize ".
 844     "| gs -q -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=$sfile.pdf ".
 845     "     -c save pop -"
 846   ) == 0
 847     or die "dvips | gs failed: $!";
 848
 849   open(PDF, "<$file.pdf")
 850     or die "can't open $file.pdf: $! (error in LaTeX template?)\n";
 851
 852   unlink("$file.dvi", "$file.log", "$file.aux", "$file.pdf", "$file.tex")
 853     unless $FS::CurrentUser::CurrentUser->option('save_tmp_typesetting');
 854
 855   my $pdf = '';
 856   while (<PDF>) {
 857     $pdf .= $_;
 858   }
 859
 860   close PDF;
 861
 862   return $pdf;
 863
 864 }
 865
 866 sub _pslatex {
 867   my $file = shift;
 868
 869   #my $sfile = shell_quote $file;
 870
 871   my @cmd = (
 872     'latex',
 873     '-interaction=batchmode',
 874     '\AtBeginDocument{\RequirePackage{pslatex}}',
 875     '\def\PSLATEXTMP{\futurelet\PSLATEXTMP\PSLATEXTMPB}',
 876     '\def\PSLATEXTMPB{\ifx\PSLATEXTMP\nonstopmode\else\input\fi}',
 877     '\PSLATEXTMP',
 878     "$file.tex"
 879   );
 880
 881   my $timeout = 30; #? should be more than enough
 882
 883   for ( 1, 2 ) {
 884
 885     local($SIG{CHLD}) = sub {};
 886     run( \@cmd, '>'=>'/dev/null', '2>'=>'/dev/null', timeout($timeout) )
 887       or warn "bad exit status from pslatex pass $_\n";
 888
 889   }
 890
 891   return if -e "$file.dvi" && -s "$file.dvi";
 892   die "pslatex $file.tex failed, see $file.log for details?\n";
 893
 894 }
 895
 896 =item do_print ARRAYREF [, OPTION => VALUE ... ]
 897
 898 Sends the lines in ARRAYREF to the printer.
 899
 900 Options available are:
 901
 902 =over 4
 903
 904 =item agentnum
 905
 906 Uses this agent's 'lpr' configuration setting override instead of the global
 907 value.
 908
 909 =item lpr
 910
 911 Uses this command instead of the configured lpr command (overrides both the
 912 global value and agentnum).
 913
 914 =cut
 915
 916 sub do_print {
 917   my( $data, %opt ) = @_;
 918
 919   if ( $DISABLE_ALL_NOTICES ) {
 920     warn 'do_print() disabled by $FS::Misc::DISABLE_ALL_NOTICES' if $DEBUG;
 921     return;
 922   }
 923
 924   my $lpr = ( exists($opt{'lpr'}) && $opt{'lpr'} )
 925               ? $opt{'lpr'}
 926               : $conf->config('lpr', $opt{'agentnum'} );
 927
 928   my $outerr = '';
 929   local($SIG{CHLD}) = sub {};
 930   run3 $lpr, $data, \$outerr, \$outerr;
 931   if ( $? ) {
 932     $outerr = ": $outerr" if length($outerr);
 933     die "Error from $lpr (exit status ". ($?>>8). ")$outerr\n";
 934   }
 935
 936 }
 937
 938 =item csv_from_fixed, FILEREF COUNTREF, [ LENGTH_LISTREF, [ CALLBACKS_LISTREF ] ]
 939
 940 Converts the filehandle referenced by FILEREF from fixed length record
 941 lines to a CSV file according to the lengths specified in LENGTH_LISTREF.
 942 The CALLBACKS_LISTREF refers to a correpsonding list of coderefs.  Each
 943 should return the value to be substituted in place of its single argument.
 944
 945 Returns false on success or an error if one occurs.
 946
 947 =cut
 948
 949 sub csv_from_fixed {
 950   my( $fhref, $countref, $lengths, $callbacks) = @_;
 951
 952   eval { require Text::CSV_XS; };
 953   return $@ if $@;
 954
 955   my $ofh = $$fhref;
 956   my $unpacker = new Text::CSV_XS;
 957   my $total = 0;
 958   my $template = join('', map {$total += $_; "A$_"} @$lengths) if $lengths;
 959
 960   my $dir = "%%%FREESIDE_CACHE%%%/cache.$FS::UID::datasrc";
 961   my $fh = new File::Temp( TEMPLATE => "FILE.csv.XXXXXXXX",
 962                            DIR      => $dir,
 963                            UNLINK   => 0,
 964                          ) or return "can't open temp file: $!\n"
 965     if $template;
 966
 967   while ( defined(my $line=<$ofh>) ) {
 968     $$countref++;
 969     if ( $template ) {
 970       my $column = 0;
 971
 972       chomp $line;
 973       return "unexpected input at line $$countref: $line".
 974              " -- expected $total but received ". length($line)
 975         unless length($line) == $total;
 976
 977       $unpacker->combine( map { my $i = $column++;
 978                                 defined( $callbacks->[$i] )
 979                                   ? &{ $callbacks->[$i] }( $_ )
 980                                   : $_
 981                               } unpack( $template, $line )
 982                         )
 983         or return "invalid data for CSV: ". $unpacker->error_input;
 984
 985       print $fh $unpacker->string(), "\n"
 986         or return "can't write temp file: $!\n";
 987     }
 988   }
 989
 990   if ( $template ) { close $$fhref; $$fhref = $fh }
 991
 992   seek $$fhref, 0, 0;
 993   '';
 994 }
 995
 996 =item ocr_image IMAGE_SCALAR
 997
 998 Runs OCR on the provided image data and returns a list of text lines.
 999
1000 =cut
1001
1002 sub ocr_image {
1003   my $logo_data = shift;
1004
1005   #XXX use conf dir location from Makefile
1006   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
1007   my $fh = new File::Temp(
1008     TEMPLATE => 'bizcard.XXXXXXXX',
1009     SUFFIX   => '.png', #XXX assuming, but should handle jpg, gif, etc. too
1010     DIR      => $dir,
1011     UNLINK   => 0,
1012   ) or die "can't open temp file: $!\n";
1013
1014   my $filename = $fh->filename;
1015
1016   print $fh $logo_data;
1017   close $fh;
1018
1019   local($SIG{CHLD}) = sub {};
1020
1021   run( [qw(ocroscript recognize), $filename], '>'=>"$filename.hocr" )
1022     or die "ocroscript recognize failed\n";
1023
1024   run( [qw(ocroscript hocr-to-text), "$filename.hocr"], '>pipe'=>\*OUT )
1025     or die "ocroscript hocr-to-text failed\n";
1026
1027   my @lines = split(/\n/, <OUT> );
1028
1029   foreach (@lines) { s/\.c0m\s*$/.com/; }
1030
1031   @lines;
1032 }
1033
1034 =item bytes_substr STRING, OFFSET[, LENGTH[, REPLACEMENT] ]
1035
1036 DEPRECATED
1037   Use Unicode::Truncate truncate_egc instead
1038
1039 A replacement for "substr" that counts raw bytes rather than logical
1040 characters. Unlike "bytes::substr", will suppress fragmented UTF-8 characters
1041 rather than output them. Unlike real "substr", is not an lvalue.
1042
1043 =cut
1044
1045 # sub bytes_substr {
1046 #   my ($string, $offset, $length, $repl) = @_;
1047 #   my $bytes = substr(
1048 #     Encode::encode('utf8', $string),
1049 #     $offset,
1050 #     $length,
1051 #     Encode::encode('utf8', $repl)
1052 #   );
1053 #   my $chk = $DEBUG ? Encode::FB_WARN : Encode::FB_QUIET;
1054 #   return Encode::decode('utf8', $bytes, $chk);
1055 # }
1056
1057 =item money_pretty
1058
1059 Accepts a postive or negative numerical value.
1060 Returns amount formatted for display,
1061 including money character.
1062
1063 =cut
1064
1065 sub money_pretty {
1066   my $amount = shift;
1067   my $money_char = $conf->{'money_char'} || '$';
1068   $amount = sprintf("%0.2f",$amount);
1069   $amount =~ s/^(-?)/$1$money_char/;
1070   return $amount;
1071 }
1072
1073 =back
1074
1075 =head1 BUGS
1076
1077 This package exists.
1078
1079 =head1 SEE ALSO
1080
1081 L<FS::UID>, L<FS::CGI>, L<FS::Record>, the base documentation.
1082
1083 L<Fax::Hylafax::Client>
1084
1085 =cut
1086
1087 1;