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