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