FS/FS/Misc.pm

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