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