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