FS/FS/Misc.pm

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