FS/FS/Misc.pm

   1 package FS::Misc;
   2
   3 use strict;
   4 use vars qw ( @ISA @EXPORT_OK $DEBUG );
   5 use Exporter;
   6 use Carp;
   7 use Data::Dumper;
   8 use IPC::Run qw( run timeout );   # for _pslatex
   9 use IPC::Run3; # for do_print... should just use IPC::Run i guess
  10 use File::Temp;
  11 #do NOT depend on any FS:: modules here, causes weird (sometimes unreproducable
  12 #until on client machine) dependancy loops.  put them in FS::Misc::Something
  13 #instead
  14
  15 @ISA = qw( Exporter );
  16 @EXPORT_OK = qw( generate_email send_email send_fax
  17                  states_hash counties state_label
  18                  card_types
  19                  generate_ps generate_pdf do_print
  20                  csv_from_fixed
  21                );
  22
  23 $DEBUG = 0;
  24
  25 =head1 NAME
  26
  27 FS::Misc - Miscellaneous subroutines
  28
  29 =head1 SYNOPSIS
  30
  31   use FS::Misc qw(send_email);
  32
  33   send_email();
  34
  35 =head1 DESCRIPTION
  36
  37 Miscellaneous subroutines.  This module contains miscellaneous subroutines
  38 called from multiple other modules.  These are not OO or necessarily related,
  39 but are collected here to elimiate code duplication.
  40
  41 =head1 SUBROUTINES
  42
  43 =over 4
  44
  45 =item generate_email OPTION => VALUE ...
  46
  47 Options:
  48
  49 =over 4
  50
  51 =item from
  52
  53 Sender address, required
  54
  55 =item to
  56
  57 Recipient address, required
  58
  59 =item subject
  60
  61 email subject, required
  62
  63 =item html_body
  64
  65 Email body (HTML alternative).  Arrayref of lines, or scalar.
  66
  67 Will be placed inside an HTML <BODY> tag.
  68
  69 =item text_body
  70
  71 Email body (Text alternative).  Arrayref of lines, or scalar.
  72
  73 =back
  74
  75 Returns an argument list to be passsed to L<send_email>.
  76
  77 =cut
  78
  79 #false laziness w/FS::cust_bill::generate_email
  80
  81 use MIME::Entity;
  82 use HTML::Entities;
  83
  84 sub generate_email {
  85   my %args = @_;
  86
  87   my $me = '[FS::Misc::generate_email]';
  88
  89   my %return = (
  90     'from'    => $args{'from'},
  91     'to'      => $args{'to'},
  92     'subject' => $args{'subject'},
  93   );
  94
  95   #if (ref($args{'to'}) eq 'ARRAY') {
  96   #  $return{'to'} = $args{'to'};
  97   #} else {
  98   #  $return{'to'} = [ grep { $_ !~ /^(POST|FAX)$/ }
  99   #                         $self->cust_main->invoicing_list
 100   #                  ];
 101   #}
 102
 103   warn "$me creating HTML/text multipart message"
 104     if $DEBUG;
 105
 106   $return{'nobody'} = 1;
 107
 108   my $alternative = build MIME::Entity
 109     'Type'        => 'multipart/alternative',
 110     'Encoding'    => '7bit',
 111     'Disposition' => 'inline'
 112   ;
 113
 114   my $data;
 115   if ( ref($args{'text_body'}) eq 'ARRAY' ) {
 116     $data = $args{'text_body'};
 117   } else {
 118     $data = [ split(/\n/, $args{'text_body'}) ];
 119   }
 120
 121   $alternative->attach(
 122     'Type'        => 'text/plain',
 123     #'Encoding'    => 'quoted-printable',
 124     'Encoding'    => '7bit',
 125     'Data'        => $data,
 126     'Disposition' => 'inline',
 127   );
 128
 129   my @html_data;
 130   if ( ref($args{'html_body'}) eq 'ARRAY' ) {
 131     @html_data = @{ $args{'html_body'} };
 132   } else {
 133     @html_data = split(/\n/, $args{'html_body'});
 134   }
 135
 136   $alternative->attach(
 137     'Type'        => 'text/html',
 138     'Encoding'    => 'quoted-printable',
 139     'Data'        => [ '<html>',
 140                        '  <head>',
 141                        '    <title>',
 142                        '      '. encode_entities($return{'subject'}),
 143                        '    </title>',
 144                        '  </head>',
 145                        '  <body bgcolor="#e8e8e8">',
 146                        @html_data,
 147                        '  </body>',
 148                        '</html>',
 149                      ],
 150     'Disposition' => 'inline',
 151     #'Filename'    => 'invoice.pdf',
 152   );
 153
 154   #no other attachment:
 155   # multipart/related
 156   #   multipart/alternative
 157   #     text/plain
 158   #     text/html
 159
 160   $return{'content-type'} = 'multipart/related';
 161   $return{'mimeparts'} = [ $alternative ];
 162   $return{'type'} = 'multipart/alternative'; #Content-Type of first part...
 163   #$return{'disposition'} = 'inline';
 164
 165   %return;
 166
 167 }
 168
 169 =item send_email OPTION => VALUE ...
 170
 171 Options:
 172
 173 =over 4
 174
 175 =item from
 176
 177 (required)
 178
 179 =item to
 180
 181 (required) comma-separated scalar or arrayref of recipients
 182
 183 =item subject
 184
 185 (required)
 186
 187 =item content-type
 188
 189 (optional) MIME type for the body
 190
 191 =item body
 192
 193 (required unless I<nobody> is true) arrayref of body text lines
 194
 195 =item mimeparts
 196
 197 (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().
 198
 199 =item nobody
 200
 201 (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,
 202 I<content-type>, if specified, overrides the default "multipart/mixed" for the outermost MIME container.
 203
 204 =item content-encoding
 205
 206 (optional) when using nobody, optional top-level MIME
 207 encoding which, if specified, overrides the default "7bit".
 208
 209 =item type
 210
 211 (optional) type parameter for multipart/related messages
 212
 213 =back
 214
 215 =cut
 216
 217 use vars qw( $conf );
 218 use Date::Format;
 219 use Mail::Header;
 220 use Mail::Internet 2.00;
 221 use MIME::Entity;
 222 use FS::UID;
 223
 224 FS::UID->install_callback( sub {
 225   $conf = new FS::Conf;
 226 } );
 227
 228 sub send_email {
 229   my(%options) = @_;
 230   if ( $DEBUG ) {
 231     my %doptions = %options;
 232     $doptions{'body'} = '(full body not shown in debug)';
 233     warn "FS::Misc::send_email called with options:\n  ". Dumper(\%doptions);
 234 #         join("\n", map { "  $_: ". $options{$_} } keys %options ). "\n"
 235   }
 236
 237   $ENV{MAILADDRESS} = $options{'from'};
 238   my $to = ref($options{to}) ? join(', ', @{ $options{to} } ) : $options{to};
 239
 240   my @mimeargs = ();
 241   my @mimeparts = ();
 242   if ( $options{'nobody'} ) {
 243
 244     croak "'mimeparts' option required when 'nobody' option given\n"
 245       unless $options{'mimeparts'};
 246
 247     @mimeparts = @{$options{'mimeparts'}};
 248
 249     @mimeargs = (
 250       'Type'         => ( $options{'content-type'} || 'multipart/mixed' ),
 251       'Encoding'     => ( $options{'content-encoding'} || '7bit' ),
 252     );
 253
 254   } else {
 255
 256     @mimeparts = @{$options{'mimeparts'}}
 257       if ref($options{'mimeparts'}) eq 'ARRAY';
 258
 259     if (scalar(@mimeparts)) {
 260
 261       @mimeargs = (
 262         'Type'     => 'multipart/mixed',
 263         'Encoding' => '7bit',
 264       );
 265
 266       unshift @mimeparts, {
 267         'Type'        => ( $options{'content-type'} || 'text/plain' ),
 268         'Data'        => $options{'body'},
 269         'Encoding'    => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
 270         'Disposition' => 'inline',
 271       };
 272
 273     } else {
 274
 275       @mimeargs = (
 276         'Type'     => ( $options{'content-type'} || 'text/plain' ),
 277         'Data'     => $options{'body'},
 278         'Encoding' => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
 279       );
 280
 281     }
 282
 283   }
 284
 285   my $domain;
 286   if ( $options{'from'} =~ /\@([\w\.\-]+)/ ) {
 287     $domain = $1;
 288   } else {
 289     warn 'no domain found in invoice from address '. $options{'from'}.
 290          '; constructing Message-ID @example.com';
 291     $domain = 'example.com';
 292   }
 293   my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
 294
 295   my $message = MIME::Entity->build(
 296     'From'       => $options{'from'},
 297     'To'         => $to,
 298     'Sender'     => $options{'from'},
 299     'Reply-To'   => $options{'from'},
 300     'Date'       => time2str("%a, %d %b %Y %X %z", time),
 301     'Subject'    => $options{'subject'},
 302     'Message-ID' => "<$message_id>",
 303     @mimeargs,
 304   );
 305
 306   if ( $options{'type'} ) {
 307     #false laziness w/cust_bill::generate_email
 308     $message->head->replace('Content-type',
 309       $message->mime_type.
 310       '; boundary="'. $message->head->multipart_boundary. '"'.
 311       '; type='. $options{'type'}
 312     );
 313   }
 314
 315   foreach my $part (@mimeparts) {
 316
 317     if ( UNIVERSAL::isa($part, 'MIME::Entity') ) {
 318
 319       warn "attaching MIME part from MIME::Entity object\n"
 320         if $DEBUG;
 321       $message->add_part($part);
 322
 323     } elsif ( ref($part) eq 'HASH' ) {
 324
 325       warn "attaching MIME part from hashref:\n".
 326            join("\n", map "  $_: ".$part->{$_}, keys %$part ). "\n"
 327         if $DEBUG;
 328       $message->attach(%$part);
 329
 330     } else {
 331       croak "mimepart $part isn't a hashref or MIME::Entity object!";
 332     }
 333
 334   }
 335
 336   my $smtpmachine = $conf->config('smtpmachine');
 337   $!=0;
 338
 339   $message->mysmtpsend( 'Host'     => $smtpmachine,
 340                         'MailFrom' => $options{'from'},
 341                       );
 342
 343 }
 344
 345 #this kludges a "mysmtpsend" method into Mail::Internet for send_email above
 346 #now updated for MailTools v2!
 347 package Mail::Internet;
 348
 349 use Mail::Address;
 350 use Net::SMTP;
 351 use Net::Domain;
 352
 353 sub Mail::Internet::mysmtpsend($@) {
 354     my ($self, %opt) = @_;
 355
 356     my $host     = $opt{Host};
 357     my $envelope = $opt{MailFrom}; # || mailaddress();
 358     my $quit     = 1;
 359
 360     my ($smtp, @hello);
 361
 362     push @hello, Hello => $opt{Hello}
 363         if defined $opt{Hello};
 364
 365     push @hello, Port => $opt{Port}
 366         if exists $opt{Port};
 367
 368     push @hello, Debug => $opt{Debug}
 369         if exists $opt{Debug};
 370
 371 #    if(!defined $host)
 372 #    {   local $SIG{__DIE__};
 373 #        my @hosts = qw(mailhost localhost);
 374 #        unshift @hosts, split /\:/, $ENV{SMTPHOSTS}
 375 #            if defined $ENV{SMTPHOSTS};
 376 #
 377 #        foreach $host (@hosts)
 378 #        {   $smtp = eval { Net::SMTP->new($host, @hello) };
 379 #            last if defined $smtp;
 380 #        }
 381 #    }
 382 #    elsif(ref($host) && UNIVERSAL::isa($host,'Net::SMTP'))
 383     if(ref($host) && UNIVERSAL::isa($host,'Net::SMTP'))
 384     {   $smtp = $host;
 385         $quit = 0;
 386     }
 387     else
 388     {   #local $SIG{__DIE__};
 389         #$smtp = eval { Net::SMTP->new($host, @hello) };
 390         $smtp = Net::SMTP->new($host, @hello);
 391     }
 392
 393     unless ( defined($smtp) ) {
 394       my $err = $!;
 395       $err =~ s/Invalid argument/Unknown host/;
 396       return "can't connect to $host: $err"
 397     }
 398
 399     my $head = $self->cleaned_header_dup;
 400
 401     $head->delete('Bcc');
 402
 403     # Who is it to
 404
 405     my @rcpt = map { ref $_ ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'};
 406     @rcpt    = map { $head->get($_) } qw(To Cc Bcc)
 407         unless @rcpt;
 408
 409     my @addr = map {$_->address} Mail::Address->parse(@rcpt);
 410     #@addr or return ();
 411     return 'No valid destination addresses found!'
 412         unless(@addr);
 413
 414     # Send it
 415
 416     my $ok = $smtp->mail($envelope)
 417           && $smtp->to(@addr)
 418           && $smtp->data(join("", @{$head->header}, "\n", @{$self->body}));
 419
 420     #$quit && $smtp->quit;
 421     #$ok ? @addr : ();
 422     if ( $ok ) {
 423       $quit && $smtp->quit;
 424       return '';
 425     } else {
 426       return $smtp->code. ' '. $smtp->message;
 427     }
 428 }
 429 package FS::Misc;
 430 #eokludge
 431
 432 =item send_fax OPTION => VALUE ...
 433
 434 Options:
 435
 436 I<dialstring> - (required) 10-digit phone number w/ area code
 437
 438 I<docdata> - (required) Array ref containing PostScript or TIFF Class F document
 439
 440 -or-
 441
 442 I<docfile> - (required) Filename of PostScript TIFF Class F document
 443
 444 ...any other options will be passed to L<Fax::Hylafax::Client::sendfax>
 445
 446
 447 =cut
 448
 449 sub send_fax {
 450
 451   my %options = @_;
 452
 453   die 'HylaFAX support has not been configured.'
 454     unless $conf->exists('hylafax');
 455
 456   eval {
 457     require Fax::Hylafax::Client;
 458   };
 459
 460   if ($@) {
 461     if ($@ =~ /^Can't locate Fax.*/) {
 462       die "You must have Fax::Hylafax::Client installed to use invoice faxing."
 463     } else {
 464       die $@;
 465     }
 466   }
 467
 468   my %hylafax_opts = map { split /\s+/ } $conf->config('hylafax');
 469
 470   die 'Called send_fax without a \'dialstring\'.'
 471     unless exists($options{'dialstring'});
 472
 473   if (exists($options{'docdata'}) and ref($options{'docdata'}) eq 'ARRAY') {
 474       my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 475       my $fh = new File::Temp(
 476         TEMPLATE => 'faxdoc.'. $options{'dialstring'} . '.XXXXXXXX',
 477         DIR      => $dir,
 478         UNLINK   => 0,
 479       ) or die "can't open temp file: $!\n";
 480
 481       $options{docfile} = $fh->filename;
 482
 483       print $fh @{$options{'docdata'}};
 484       close $fh;
 485
 486       delete $options{'docdata'};
 487   }
 488
 489   die 'Called send_fax without a \'docfile\' or \'docdata\'.'
 490     unless exists($options{'docfile'});
 491
 492   #FIXME: Need to send canonical dialstring to HylaFAX, but this only
 493   #       works in the US.
 494
 495   $options{'dialstring'} =~ s/[^\d\+]//g;
 496   if ($options{'dialstring'} =~ /^\d{10}$/) {
 497     $options{dialstring} = '+1' . $options{'dialstring'};
 498   } else {
 499     return 'Invalid dialstring ' . $options{'dialstring'} . '.';
 500   }
 501
 502   my $faxjob = &Fax::Hylafax::Client::sendfax(%options, %hylafax_opts);
 503
 504   if ($faxjob->success) {
 505     warn "Successfully queued fax to '$options{dialstring}' with jobid " .
 506            $faxjob->jobid
 507       if $DEBUG;
 508     return '';
 509   } else {
 510     return 'Error while sending FAX: ' . $faxjob->trace;
 511   }
 512
 513 }
 514
 515 =item states_hash COUNTRY
 516
 517 Returns a list of key/value pairs containing state (or other sub-country
 518 division) abbriviations and names.
 519
 520 =cut
 521
 522 use FS::Record qw(qsearch);
 523 use Locale::SubCountry;
 524
 525 sub states_hash {
 526   my($country) = @_;
 527
 528   my @states =
 529 #     sort
 530      map { s/[\n\r]//g; $_; }
 531      map { $_->state; }
 532          qsearch({
 533                    'select'    => 'state',
 534                    'table'     => 'cust_main_county',
 535                    'hashref'   => { 'country' => $country },
 536                    'extra_sql' => 'GROUP BY state',
 537                 });
 538
 539   #it could throw a fatal "Invalid country code" error (for example "AX")
 540   my $subcountry = eval { new Locale::SubCountry($country) }
 541     or return ( '', '(n/a)' );
 542
 543   #"i see your schwartz is as big as mine!"
 544   map  { ( $_->[0] => $_->[1] ) }
 545   sort { $a->[1] cmp $b->[1] }
 546   map  { [ $_ => state_label($_, $subcountry) ] }
 547        @states;
 548 }
 549
 550 =item counties STATE COUNTRY
 551
 552 Returns a list of counties for this state and country.
 553
 554 =cut
 555
 556 sub counties {
 557   my( $state, $country ) = @_;
 558
 559   sort map { s/[\n\r]//g; $_; }
 560        map { $_->county }
 561            qsearch({
 562              'select'  => 'DISTINCT county',
 563              'table'   => 'cust_main_county',
 564              'hashref' => { 'state'   => $state,
 565                             'country' => $country,
 566                           },
 567            });
 568 }
 569
 570 =item state_label STATE COUNTRY_OR_LOCALE_SUBCOUNRY_OBJECT
 571
 572 =cut
 573
 574 sub state_label {
 575   my( $state, $country ) = @_;
 576
 577   unless ( ref($country) ) {
 578     $country = eval { new Locale::SubCountry($country) }
 579       or return'(n/a)';
 580
 581   }
 582
 583   # US kludge to avoid changing existing behaviour
 584   # also we actually *use* the abbriviations...
 585   my $full_name = $country->country_code eq 'US'
 586                     ? ''
 587                     : $country->full_name($state);
 588
 589   $full_name = '' if $full_name eq 'unknown';
 590   $full_name =~ s/\(see also.*\)\s*$//;
 591   $full_name .= " ($state)" if $full_name;
 592
 593   $full_name || $state || '(n/a)';
 594
 595 }
 596
 597 =item card_types
 598
 599 Returns a hash reference of the accepted credit card types.  Keys are shorter
 600 identifiers and values are the longer strings used by the system (see
 601 L<Business::CreditCard>).
 602
 603 =cut
 604
 605 #$conf from above
 606
 607 sub card_types {
 608   my $conf = new FS::Conf;
 609
 610   my %card_types = (
 611     #displayname                    #value (Business::CreditCard)
 612     "VISA"                       => "VISA card",
 613     "MasterCard"                 => "MasterCard",
 614     "Discover"                   => "Discover card",
 615     "American Express"           => "American Express card",
 616     "Diner's Club/Carte Blanche" => "Diner's Club/Carte Blanche",
 617     "enRoute"                    => "enRoute",
 618     "JCB"                        => "JCB",
 619     "BankCard"                   => "BankCard",
 620     "Switch"                     => "Switch",
 621     "Solo"                       => "Solo",
 622   );
 623   my @conf_card_types = grep { ! /^\s*$/ } $conf->config('card-types');
 624   if ( @conf_card_types ) {
 625     #perhaps the hash is backwards for this, but this way works better for
 626     #usage in selfservice
 627     %card_types = map  { $_ => $card_types{$_} }
 628                   grep {
 629                          my $d = $_;
 630                            grep { $card_types{$d} eq $_ } @conf_card_types
 631                        }
 632                     keys %card_types;
 633   }
 634
 635   \%card_types;
 636 }
 637
 638 =item generate_ps FILENAME
 639
 640 Returns an postscript rendition of the LaTex file, as a scalar.
 641 FILENAME does not contain the .tex suffix and is unlinked by this function.
 642
 643 =cut
 644
 645 use String::ShellQuote;
 646
 647 sub generate_ps {
 648   my $file = shift;
 649
 650   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 651   chdir($dir);
 652
 653   _pslatex($file);
 654
 655   system('dvips', '-q', '-t', 'letter', "$file.dvi", '-o', "$file.ps" ) == 0
 656     or die "dvips failed";
 657
 658   open(POSTSCRIPT, "<$file.ps")
 659     or die "can't open $file.ps: $! (error in LaTeX template?)\n";
 660
 661   unlink("$file.dvi", "$file.log", "$file.aux", "$file.ps", "$file.tex");
 662
 663   my $ps = '';
 664
 665   if ( $conf->exists('lpr-postscript_prefix') ) {
 666     my $prefix = $conf->config('lpr-postscript_prefix');
 667     $ps .= eval qq("$prefix");
 668   }
 669
 670   while (<POSTSCRIPT>) {
 671     $ps .= $_;
 672   }
 673
 674   close POSTSCRIPT;
 675
 676   if ( $conf->exists('lpr-postscript_suffix') ) {
 677     my $suffix = $conf->config('lpr-postscript_suffix');
 678     $ps .= eval qq("$suffix");
 679   }
 680
 681   return $ps;
 682
 683 }
 684
 685 =item generate_pdf FILENAME
 686
 687 Returns an PDF rendition of the LaTex file, as a scalar.  FILENAME does not
 688 contain the .tex suffix and is unlinked by this function.
 689
 690 =cut
 691
 692 use String::ShellQuote;
 693
 694 sub generate_pdf {
 695   my $file = shift;
 696
 697   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 698   chdir($dir);
 699
 700   #system('pdflatex', "$file.tex");
 701   #system('pdflatex', "$file.tex");
 702   #! LaTeX Error: Unknown graphics extension: .eps.
 703
 704   _pslatex($file);
 705
 706   my $sfile = shell_quote $file;
 707
 708   #system('dvipdf', "$file.dvi", "$file.pdf" );
 709   system(
 710     "dvips -q -t letter -f $sfile.dvi ".
 711     "| gs -q -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=$sfile.pdf ".
 712     "     -c save pop -"
 713   ) == 0
 714     or die "dvips | gs failed: $!";
 715
 716   open(PDF, "<$file.pdf")
 717     or die "can't open $file.pdf: $! (error in LaTeX template?)\n";
 718
 719   unlink("$file.dvi", "$file.log", "$file.aux", "$file.pdf", "$file.tex");
 720
 721   my $pdf = '';
 722   while (<PDF>) {
 723     $pdf .= $_;
 724   }
 725
 726   close PDF;
 727
 728   return $pdf;
 729
 730 }
 731
 732 sub _pslatex {
 733   my $file = shift;
 734
 735   #my $sfile = shell_quote $file;
 736
 737   my @cmd = (
 738     'latex',
 739     '-interaction=batchmode',
 740     '\AtBeginDocument{\RequirePackage{pslatex}}',
 741     '\def\PSLATEXTMP{\futurelet\PSLATEXTMP\PSLATEXTMPB}',
 742     '\def\PSLATEXTMPB{\ifx\PSLATEXTMP\nonstopmode\else\input\fi}',
 743     '\PSLATEXTMP',
 744     "$file.tex"
 745   );
 746
 747   my $timeout = 30; #? should be more than enough
 748
 749   for ( 1, 2 ) {
 750
 751     local($SIG{CHLD}) = sub {};
 752     run( \@cmd, '>'=>'/dev/null', '2>'=>'/dev/null', timeout($timeout) )
 753       or die "pslatex $file.tex failed; see $file.log for details?\n";
 754
 755   }
 756
 757 }
 758
 759 =item print ARRAYREF
 760
 761 Sends the lines in ARRAYREF to the printer.
 762
 763 =cut
 764
 765 sub do_print {
 766   my $data = shift;
 767
 768   my $lpr = $conf->config('lpr');
 769
 770   my $outerr = '';
 771   run3 $lpr, $data, \$outerr, \$outerr;
 772   if ( $? ) {
 773     $outerr = ": $outerr" if length($outerr);
 774     die "Error from $lpr (exit status ". ($?>>8). ")$outerr\n";
 775   }
 776
 777 }
 778
 779 =item csv_from_fixed, FILEREF COUNTREF, [ LENGTH_LISTREF, [ CALLBACKS_LISTREF ] ]
 780
 781 Converts the filehandle referenced by FILEREF from fixed length record
 782 lines to a CSV file according to the lengths specified in LENGTH_LISTREF.
 783 The CALLBACKS_LISTREF refers to a correpsonding list of coderefs.  Each
 784 should return the value to be substituted in place of its single argument.
 785
 786 Returns false on success or an error if one occurs.
 787
 788 =cut
 789
 790 sub csv_from_fixed {
 791   my( $fhref, $countref, $lengths, $callbacks) = @_;
 792
 793   eval { require Text::CSV_XS; };
 794   return $@ if $@;
 795
 796   my $ofh = $$fhref;
 797   my $unpacker = new Text::CSV_XS;
 798   my $total = 0;
 799   my $template = join('', map {$total += $_; "A$_"} @$lengths) if $lengths;
 800
 801   my $dir = "%%%FREESIDE_CACHE%%%/cache.$FS::UID::datasrc";
 802   my $fh = new File::Temp( TEMPLATE => "CODE.csv.XXXXXXXX",
 803                            DIR      => $dir,
 804                            UNLINK   => 0,
 805                          ) or return "can't open temp file: $!\n"
 806     if $template;
 807
 808   while ( defined(my $line=<$ofh>) ) {
 809     $$countref++;
 810     if ( $template ) {
 811       my $column = 0;
 812
 813       chomp $line;
 814       return "unexpected input at line $$countref: $line".
 815              " -- expected $total but received ". length($line)
 816         unless length($line) == $total;
 817
 818       $unpacker->combine( map { my $i = $column++;
 819                                 defined( $callbacks->[$i] )
 820                                   ? &{ $callbacks->[$i] }( $_ )
 821                                   : $_
 822                               } unpack( $template, $line )
 823                         )
 824         or return "invalid data for CSV: ". $unpacker->error_input;
 825
 826       print $fh $unpacker->string(), "\n"
 827         or return "can't write temp file: $!\n";
 828     }
 829   }
 830
 831   if ( $template ) { close $$fhref; $$fhref = $fh }
 832
 833   seek $$fhref, 0, 0;
 834   '';
 835 }
 836
 837
 838 =back
 839
 840 =head1 BUGS
 841
 842 This package exists.
 843
 844 =head1 SEE ALSO
 845
 846 L<FS::UID>, L<FS::CGI>, L<FS::Record>, the base documentation.
 847
 848 L<Fax::Hylafax::Client>
 849
 850 =cut
 851
 852 1;