customer bill/ship location refactoring, #940
[freeside.git] / FS / FS / msg_template.pm
1 package FS::msg_template;
2
3 use strict;
4 use base qw( FS::Record );
5 use Text::Template;
6 use FS::Misc qw( generate_email send_email );
7 use FS::Conf;
8 use FS::Record qw( qsearch qsearchs );
9 use FS::UID qw( dbh );
10
11 use FS::cust_main;
12 use FS::cust_msg;
13 use FS::template_content;
14
15 use Date::Format qw( time2str );
16 use HTML::Entities qw( decode_entities encode_entities ) ;
17 use HTML::FormatText;
18 use HTML::TreeBuilder;
19 use vars qw( $DEBUG $conf );
20
21 FS::UID->install_callback( sub { $conf = new FS::Conf; } );
22
23 $DEBUG=0;
24
25 =head1 NAME
26
27 FS::msg_template - Object methods for msg_template records
28
29 =head1 SYNOPSIS
30
31   use FS::msg_template;
32
33   $record = new FS::msg_template \%hash;
34   $record = new FS::msg_template { 'column' => 'value' };
35
36   $error = $record->insert;
37
38   $error = $new_record->replace($old_record);
39
40   $error = $record->delete;
41
42   $error = $record->check;
43
44 =head1 DESCRIPTION
45
46 An FS::msg_template object represents a customer message template.
47 FS::msg_template inherits from FS::Record.  The following fields are currently
48 supported:
49
50 =over 4
51
52 =item msgnum - primary key
53
54 =item msgname - Name of the template.  This will appear in the user interface;
55 if it needs to be localized for some users, add it to the message catalog.
56
57 =item agentnum - Agent associated with this template.  Can be NULL for a 
58 global template.
59
60 =item mime_type - MIME type.  Defaults to text/html.
61
62 =item from_addr - Source email address.
63
64 =item disabled - disabled ('Y' or NULL).
65
66 =back
67
68 =head1 METHODS
69
70 =over 4
71
72 =item new HASHREF
73
74 Creates a new template.  To add the template to the database, see L<"insert">.
75
76 Note that this stores the hash reference, not a distinct copy of the hash it
77 points to.  You can ask the object for a copy with the I<hash> method.
78
79 =cut
80
81 # the new method can be inherited from FS::Record, if a table method is defined
82
83 sub table { 'msg_template'; }
84
85 =item insert [ CONTENT ]
86
87 Adds this record to the database.  If there is an error, returns the error,
88 otherwise returns false.
89
90 A default (no locale) L<FS::template_content> object will be created.  CONTENT 
91 is an optional hash containing 'subject' and 'body' for this object.
92
93 =cut
94
95 sub insert {
96   my $self = shift;
97   my %content = @_;
98
99   my $oldAutoCommit = $FS::UID::AutoCommit;
100   local $FS::UID::AutoCommit = 0;
101   my $dbh = dbh;
102
103   my $error = $self->SUPER::insert;
104   if ( !$error ) {
105     $content{'msgnum'} = $self->msgnum;
106     $content{'subject'} ||= '';
107     $content{'body'} ||= '';
108     my $template_content = new FS::template_content (\%content);
109     $error = $template_content->insert;
110   }
111
112   if ( $error ) {
113     $dbh->rollback if $oldAutoCommit;
114     return $error;
115   }
116
117   $dbh->commit if $oldAutoCommit;
118   return;
119 }
120
121 =item delete
122
123 Delete this record from the database.
124
125 =cut
126
127 # the delete method can be inherited from FS::Record
128
129 =item replace [ OLD_RECORD ] [ CONTENT ]
130
131 Replaces the OLD_RECORD with this one in the database.  If there is an error,
132 returns the error, otherwise returns false.
133
134 CONTENT is an optional hash containing 'subject', 'body', and 'locale'.  If 
135 supplied, an L<FS::template_content> object will be created (or modified, if 
136 one already exists for this locale).
137
138 =cut
139
140 sub replace {
141   my $self = shift;
142   my $old = ( ref($_[0]) and $_[0]->isa('FS::Record') ) 
143               ? shift
144               : $self->replace_old;
145   my %content = @_;
146   
147   my $oldAutoCommit = $FS::UID::AutoCommit;
148   local $FS::UID::AutoCommit = 0;
149   my $dbh = dbh;
150
151   my $error = $self->SUPER::replace($old);
152
153   if ( !$error and %content ) {
154     $content{'locale'} ||= '';
155     my $new_content = qsearchs('template_content', {
156                         'msgnum' => $self->msgnum,
157                         'locale' => $content{'locale'},
158                       } );
159     if ( $new_content ) {
160       $new_content->subject($content{'subject'});
161       $new_content->body($content{'body'});
162       $error = $new_content->replace;
163     }
164     else {
165       $content{'msgnum'} = $self->msgnum;
166       $new_content = new FS::template_content \%content;
167       $error = $new_content->insert;
168     }
169   }
170
171   if ( $error ) {
172     $dbh->rollback if $oldAutoCommit;
173     return $error;
174   }
175
176   warn "committing FS::msg_template->replace\n" if $DEBUG and $oldAutoCommit;
177   $dbh->commit if $oldAutoCommit;
178   return;
179 }
180     
181
182
183 =item check
184
185 Checks all fields to make sure this is a valid template.  If there is
186 an error, returns the error, otherwise returns false.  Called by the insert
187 and replace methods.
188
189 =cut
190
191 # the check method should currently be supplied - FS::Record contains some
192 # data checking routines
193
194 sub check {
195   my $self = shift;
196
197   my $error = 
198     $self->ut_numbern('msgnum')
199     || $self->ut_text('msgname')
200     || $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum')
201     || $self->ut_textn('mime_type')
202     || $self->ut_enum('disabled', [ '', 'Y' ] )
203     || $self->ut_textn('from_addr')
204   ;
205   return $error if $error;
206
207   $self->mime_type('text/html') unless $self->mime_type;
208
209   $self->SUPER::check;
210 }
211
212 =item content_locales
213
214 Returns a hashref of the L<FS::template_content> objects attached to 
215 this template, with the locale as key.
216
217 =cut
218
219 sub content_locales {
220   my $self = shift;
221   return $self->{'_content_locales'} ||= +{
222     map { $_->locale , $_ } 
223     qsearch('template_content', { 'msgnum' => $self->msgnum })
224   };
225 }
226
227 =item prepare OPTION => VALUE
228
229 Fills in the template and returns a hash of the 'from' address, 'to' 
230 addresses, subject line, and body.
231
232 Options are passed as a list of name/value pairs:
233
234 =over 4
235
236 =item cust_main
237
238 Customer object (required).
239
240 =item object
241
242 Additional context object (currently, can be a cust_main, cust_pkg, 
243 cust_bill, cust_pay, cust_pay_pending, or svc_(acct, phone, broadband, 
244 domain) ).  If the object is a svc_*, its cust_pkg will be fetched and 
245 used for substitution.
246
247 As a special case, this may be an arrayref of two objects.  Both 
248 objects will be available for substitution, with their field names 
249 prefixed with 'new_' and 'old_' respectively.  This is used in the 
250 rt_ticket export when exporting "replace" events.
251
252 =item from_config
253
254 Configuration option to use as the source address, based on the customer's 
255 agentnum.  If unspecified (or the named option is empty), 'invoice_from' 
256 will be used.
257
258 The I<from_addr> field in the template takes precedence over this.
259
260 =item to
261
262 Destination address.  The default is to use the customer's 
263 invoicing_list addresses.  Multiple addresses may be comma-separated.
264
265 =item substitutions
266
267 A hash reference of additional substitutions
268
269 =back
270
271 =cut
272
273 sub prepare {
274   my( $self, %opt ) = @_;
275
276   my $cust_main = $opt{'cust_main'};
277   my $object = $opt{'object'};
278
279   # localization
280   my $locale = $cust_main->locale || '';
281   warn "no locale for cust#".$cust_main->custnum."; using default content\n"
282     if $DEBUG and !$locale;
283   my $content = $self->content($cust_main->locale);
284   warn "preparing template '".$self->msgname."' to cust#".$cust_main->custnum."\n"
285     if($DEBUG);
286
287   my $subs = $self->substitutions;
288
289   ###
290   # create substitution table
291   ###  
292   my %hash;
293   my @objects = ($cust_main);
294   my @prefixes = ('');
295   my $svc;
296   if( ref $object ) {
297     if( ref($object) eq 'ARRAY' ) {
298       # [new, old], for provisioning tickets
299       push @objects, $object->[0], $object->[1];
300       push @prefixes, 'new_', 'old_';
301       $svc = $object->[0] if $object->[0]->isa('FS::svc_Common');
302     }
303     else {
304       push @objects, $object;
305       push @prefixes, '';
306       $svc = $object if $object->isa('FS::svc_Common');
307     }
308   }
309   if( $svc ) {
310     push @objects, $svc->cust_svc->cust_pkg;
311     push @prefixes, '';
312   }
313
314   foreach my $obj (@objects) {
315     my $prefix = shift @prefixes;
316     foreach my $name (@{ $subs->{$obj->table} }) {
317       if(!ref($name)) {
318         # simple case
319         $hash{$prefix.$name} = $obj->$name();
320       }
321       elsif( ref($name) eq 'ARRAY' ) {
322         # [ foo => sub { ... } ]
323         $hash{$prefix.($name->[0])} = $name->[1]->($obj);
324       }
325       else {
326         warn "bad msg_template substitution: '$name'\n";
327         #skip it?
328       } 
329     } 
330   } 
331
332   if ( $opt{substitutions} ) {
333     $hash{$_} = $opt{substitutions}->{$_} foreach keys %{$opt{substitutions}};
334   }
335
336   $_ = encode_entities($_ || '') foreach values(%hash);
337
338   ###
339   # clean up template
340   ###
341   my $subject_tmpl = new Text::Template (
342     TYPE   => 'STRING',
343     SOURCE => $content->subject,
344   );
345   my $subject = $subject_tmpl->fill_in( HASH => \%hash );
346
347   my $body = $content->body;
348   my ($skin, $guts) = eviscerate($body);
349   @$guts = map { 
350     $_ = decode_entities($_); # turn all punctuation back into itself
351     s/\r//gs;           # remove \r's
352     s/<br[^>]*>/\n/gsi; # and <br /> tags
353     s/<p>/\n/gsi;       # and <p>
354     s/<\/p>//gsi;       # and </p>
355     s/\240/ /gs;        # and &nbsp;
356     $_
357   } @$guts;
358   
359   $body = '{ use Date::Format qw(time2str); "" }';
360   while(@$skin || @$guts) {
361     $body .= shift(@$skin) || '';
362     $body .= shift(@$guts) || '';
363   }
364
365   ###
366   # fill-in
367   ###
368
369   my $body_tmpl = new Text::Template (
370     TYPE          => 'STRING',
371     SOURCE        => $body,
372   );
373
374   $body = $body_tmpl->fill_in( HASH => \%hash );
375
376   ###
377   # and email
378   ###
379
380   my @to;
381   if ( exists($opt{'to'}) ) {
382     @to = split(/\s*,\s*/, $opt{'to'});
383   }
384   else {
385     @to = $cust_main->invoicing_list_emailonly;
386   }
387   # no warning when preparing with no destination
388
389   my $from_addr = $self->from_addr;
390
391   if ( !$from_addr ) {
392     if ( $opt{'from_config'} ) {
393       $from_addr = scalar( $conf->config($opt{'from_config'}, 
394                                          $cust_main->agentnum) );
395     }
396     $from_addr ||= scalar( $conf->config('invoice_from',
397                                          $cust_main->agentnum) );
398   }
399 #  my @cust_msg = ();
400 #  if ( $conf->exists('log_sent_mail') and !$opt{'preview'} ) {
401 #    my $cust_msg = FS::cust_msg->new({
402 #        'custnum' => $cust_main->custnum,
403 #        'msgnum'  => $self->msgnum,
404 #        'status'  => 'prepared',
405 #      });
406 #    $cust_msg->insert;
407 #    @cust_msg = ('cust_msg' => $cust_msg);
408 #  }
409
410   (
411     'custnum' => $cust_main->custnum,
412     'msgnum'  => $self->msgnum,
413     'from' => $from_addr,
414     'to'   => \@to,
415     'bcc'  => $self->bcc_addr || undef,
416     'subject'   => $subject,
417     'html_body' => $body,
418     'text_body' => HTML::FormatText->new(leftmargin => 0, rightmargin => 70
419                     )->format( HTML::TreeBuilder->new_from_content($body) ),
420   );
421
422 }
423
424 =item send OPTION => VALUE
425
426 Fills in the template and sends it to the customer.  Options are as for 
427 'prepare'.
428
429 =cut
430
431 # broken out from prepare() in case we want to queue the sending,
432 # preview it, etc.
433 sub send {
434   my $self = shift;
435   send_email(generate_email($self->prepare(@_)));
436 }
437
438 # helper sub for package dates
439 my $ymd = sub { $_[0] ? time2str('%Y-%m-%d', $_[0]) : '' };
440
441 # helper sub for usage-related messages
442 my $usage_warning = sub {
443   my $svc = shift;
444   foreach my $col (qw(seconds upbytes downbytes totalbytes)) {
445     my $amount = $svc->$col; next if $amount eq '';
446     my $method = $col.'_threshold';
447     my $threshold = $svc->$method; next if $threshold eq '';
448     return [$col, $amount, $threshold] if $amount <= $threshold;
449     # this only returns the first one that's below threshold, if there are 
450     # several.
451   }
452   return ['', '', ''];
453 };
454
455 #my $conf = new FS::Conf;
456
457 #return contexts and fill-in values
458 # If you add anything, be sure to add a description in 
459 # httemplate/edit/msg_template.html.
460 sub substitutions {
461   { 'cust_main' => [qw(
462       display_custnum agentnum agent_name
463
464       last first company
465       name name_short contact contact_firstlast
466       address1 address2 city county state zip
467       country
468       daytime night mobile fax
469
470       has_ship_address
471       ship_last ship_first ship_company
472       ship_name ship_name_short ship_contact ship_contact_firstlast
473       ship_address1 ship_address2 ship_city ship_county ship_state ship_zip
474       ship_country
475       ship_daytime ship_night ship_mobile ship_fax
476
477       paymask payname paytype payip
478       num_cancelled_pkgs num_ncancelled_pkgs num_pkgs
479       classname categoryname
480       balance
481       credit_limit
482       invoicing_list_emailonly
483       cust_status ucfirst_cust_status cust_statuscolor
484
485       signupdate dundate
486       packages recurdates
487       ),
488       #compatibility: obsolete ship_ fields
489       map ( { [ "ship_$_"   => sub { shift->$_ } ] } 
490         qw( last first company name name_short contact contact_firstlast
491             daytime night fax )
492       ),
493       [ expdate           => sub { shift->paydate_epoch } ], #compatibility
494       [ signupdate_ymd    => sub { $ymd->(shift->signupdate) } ],
495       [ dundate_ymd       => sub { $ymd->(shift->dundate) } ],
496       [ paydate_my        => sub { sprintf('%02d/%04d', shift->paydate_monthyear) } ],
497       [ otaker_first      => sub { shift->access_user->first } ],
498       [ otaker_last       => sub { shift->access_user->last } ],
499       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
500       [ company_name      => sub { 
501           $conf->config('company_name', shift->agentnum) 
502         } ],
503       [ company_address   => sub {
504           $conf->config('company_address', shift->agentnum)
505         } ],
506       [ company_phonenum  => sub {
507           $conf->config('company_phonenum', shift->agentnum)
508         } ],
509     ],
510     # next_bill_date
511     'cust_pkg'  => [qw( 
512       pkgnum pkg_label pkg_label_long
513       location_label
514       status statuscolor
515     
516       start_date setup bill last_bill 
517       adjourn susp expire 
518       labels_short
519       ),
520       [ pkg               => sub { shift->part_pkg->pkg } ],
521       [ cancel            => sub { shift->getfield('cancel') } ], # grrr...
522       [ start_ymd         => sub { $ymd->(shift->getfield('start_date')) } ],
523       [ setup_ymd         => sub { $ymd->(shift->getfield('setup')) } ],
524       [ next_bill_ymd     => sub { $ymd->(shift->getfield('bill')) } ],
525       [ last_bill_ymd     => sub { $ymd->(shift->getfield('last_bill')) } ],
526       [ adjourn_ymd       => sub { $ymd->(shift->getfield('adjourn')) } ],
527       [ susp_ymd          => sub { $ymd->(shift->getfield('susp')) } ],
528       [ expire_ymd        => sub { $ymd->(shift->getfield('expire')) } ],
529       [ cancel_ymd        => sub { $ymd->(shift->getfield('cancel')) } ],
530     ],
531     'cust_bill' => [qw(
532       invnum
533       _date
534     )],
535     #XXX not really thinking about cust_bill substitutions quite yet
536     
537     # for welcome and limit warning messages
538     'svc_acct' => [qw(
539       svcnum
540       username
541       domain
542       ),
543       [ password          => sub { shift->getfield('_password') } ],
544       [ column            => sub { &$usage_warning(shift)->[0] } ],
545       [ amount            => sub { &$usage_warning(shift)->[1] } ],
546       [ threshold         => sub { &$usage_warning(shift)->[2] } ],
547     ],
548     'svc_domain' => [qw(
549       svcnum
550       domain
551       ),
552       [ registrar         => sub {
553           my $registrar = qsearchs('registrar', 
554             { registrarnum => shift->registrarnum} );
555           $registrar ? $registrar->registrarname : ''
556         }
557       ],
558       [ catchall          => sub { 
559           my $svc_acct = qsearchs('svc_acct', { svcnum => shift->catchall });
560           $svc_acct ? $svc_acct->email : ''
561         }
562       ],
563     ],
564     'svc_phone' => [qw(
565       svcnum
566       phonenum
567       countrycode
568       domain
569       )
570     ],
571     'svc_broadband' => [qw(
572       svcnum
573       speed_up
574       speed_down
575       ip_addr
576       mac_addr
577       )
578     ],
579     # for payment receipts
580     'cust_pay' => [qw(
581       paynum
582       _date
583       ),
584       [ paid              => sub { sprintf("%.2f", shift->paid) } ],
585       # overrides the one in cust_main in cases where a cust_pay is passed
586       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
587       [ date              => sub { time2str("%a %B %o, %Y", shift->_date) } ],
588       [ payinfo           => sub { 
589           my $cust_pay = shift;
590           ($cust_pay->payby eq 'CARD' || $cust_pay->payby eq 'CHEK') ?
591             $cust_pay->paymask : $cust_pay->decrypt($cust_pay->payinfo)
592         } ],
593     ],
594     # for payment decline messages
595     # try to support all cust_pay fields
596     # 'error' is a special case, it contains the raw error from the gateway
597     'cust_pay_pending' => [qw(
598       _date
599       error
600       ),
601       [ paid              => sub { sprintf("%.2f", shift->paid) } ],
602       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
603       [ date              => sub { time2str("%a %B %o, %Y", shift->_date) } ],
604       [ payinfo           => sub {
605           my $pending = shift;
606           ($pending->payby eq 'CARD' || $pending->payby eq 'CHEK') ?
607             $pending->paymask : $pending->decrypt($pending->payinfo)
608         } ],
609     ],
610   };
611 }
612
613 =item content LOCALE
614
615 Returns the L<FS::template_content> object appropriate to LOCALE, if there 
616 is one.  If not, returns the one with a NULL locale.
617
618 =cut
619
620 sub content {
621   my $self = shift;
622   my $locale = shift;
623   qsearchs('template_content', 
624             { 'msgnum' => $self->msgnum, 'locale' => $locale }) || 
625   qsearchs('template_content',
626             { 'msgnum' => $self->msgnum, 'locale' => '' });
627 }
628
629 =item agent
630
631 Returns the L<FS::agent> object for this template.
632
633 =cut
634
635 sub agent {
636   qsearchs('agent', { 'agentnum' => $_[0]->agentnum });
637 }
638
639 sub _upgrade_data {
640   my ($self, %opts) = @_;
641
642   my @fixes = (
643     [ 'alerter_msgnum',  'alerter_template',   '',               '', '' ],
644     [ 'cancel_msgnum',   'cancelmessage',      'cancelsubject',  '', '' ],
645     [ 'decline_msgnum',  'declinetemplate',    '',               '', '' ],
646     [ 'impending_recur_msgnum', 'impending_recur_template', '',  '', 'impending_recur_bcc' ],
647     [ 'payment_receipt_msgnum', 'payment_receipt_email', '',     '', '' ],
648     [ 'welcome_msgnum',  'welcome_email',      'welcome_email-subject', 'welcome_email-from', '' ],
649     [ 'warning_msgnum',  'warning_email',      'warning_email-subject', 'warning_email-from', '' ],
650   );
651  
652   my @agentnums = ('', map {$_->agentnum} qsearch('agent', {}));
653   foreach my $agentnum (@agentnums) {
654     foreach (@fixes) {
655       my ($newname, $oldname, $subject, $from, $bcc) = @$_;
656       if ($conf->exists($oldname, $agentnum)) {
657         my $new = new FS::msg_template({
658           'msgname'   => $oldname,
659           'agentnum'  => $agentnum,
660           'from_addr' => ($from && $conf->config($from, $agentnum)) || '',
661           'bcc_addr'  => ($bcc && $conf->config($from, $agentnum)) || '',
662           'subject'   => ($subject && $conf->config($subject, $agentnum)) || '',
663           'mime_type' => 'text/html',
664           'body'      => join('<BR>',$conf->config($oldname, $agentnum)),
665         });
666         my $error = $new->insert;
667         die $error if $error;
668         $conf->set($newname, $new->msgnum, $agentnum);
669         $conf->delete($oldname, $agentnum);
670         $conf->delete($from, $agentnum) if $from;
671         $conf->delete($subject, $agentnum) if $subject;
672       }
673     }
674   }
675   foreach my $msg_template ( qsearch('msg_template', {}) ) {
676     if ( $msg_template->subject || $msg_template->body ) {
677       # create new default content
678       my %content;
679       foreach ('subject','body') {
680         $content{$_} = $msg_template->$_;
681         $msg_template->setfield($_, '');
682       }
683
684       my $error = $msg_template->replace(%content);
685       die $error if $error;
686     }
687   }
688 }
689
690 sub eviscerate {
691   # Every bit as pleasant as it sounds.
692   #
693   # We do this because Text::Template::Preprocess doesn't
694   # actually work.  It runs the entire template through 
695   # the preprocessor, instead of the code segments.  Which 
696   # is a shame, because Text::Template already contains
697   # the code to do this operation.
698   my $body = shift;
699   my (@outside, @inside);
700   my $depth = 0;
701   my $chunk = '';
702   while($body || $chunk) {
703     my ($first, $delim, $rest);
704     # put all leading non-delimiters into $first
705     ($first, $rest) =
706         ($body =~ /^((?:\\[{}]|[^{}])*)(.*)$/s);
707     $chunk .= $first;
708     # put a leading delimiter into $delim if there is one
709     ($delim, $rest) =
710       ($rest =~ /^([{}]?)(.*)$/s);
711
712     if( $delim eq '{' ) {
713       $chunk .= '{';
714       if( $depth == 0 ) {
715         push @outside, $chunk;
716         $chunk = '';
717       }
718       $depth++;
719     }
720     elsif( $delim eq '}' ) {
721       $depth--;
722       if( $depth == 0 ) {
723         push @inside, $chunk;
724         $chunk = '';
725       }
726       $chunk .= '}';
727     }
728     else {
729       # no more delimiters
730       if( $depth == 0 ) {
731         push @outside, $chunk . $rest;
732       } # else ? something wrong
733       last;
734     }
735     $body = $rest;
736   }
737   (\@outside, \@inside);
738 }
739
740 =back
741
742 =head1 BUGS
743
744 =head1 SEE ALSO
745
746 L<FS::Record>, schema.html from the base documentation.
747
748 =cut
749
750 1;
751