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