FS/FS/Misc.pm

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