svc_acct events for usage limits, #13202
[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 =back
266
267 =cut
268
269 sub prepare {
270   my( $self, %opt ) = @_;
271
272   my $cust_main = $opt{'cust_main'};
273   my $object = $opt{'object'};
274
275   # localization
276   my $locale = $cust_main->locale || '';
277   warn "no locale for cust#".$cust_main->custnum."; using default content\n"
278     if $DEBUG and !$locale;
279   my $content = $self->content($cust_main->locale);
280   warn "preparing template '".$self->msgname."' to cust#".$cust_main->custnum."\n"
281     if($DEBUG);
282
283   my $subs = $self->substitutions;
284
285   ###
286   # create substitution table
287   ###  
288   my %hash;
289   my @objects = ($cust_main);
290   my @prefixes = ('');
291   my $svc;
292   if( ref $object ) {
293     if( ref($object) eq 'ARRAY' ) {
294       # [new, old], for provisioning tickets
295       push @objects, $object->[0], $object->[1];
296       push @prefixes, 'new_', 'old_';
297       $svc = $object->[0] if $object->[0]->isa('FS::svc_Common');
298     }
299     else {
300       push @objects, $object;
301       push @prefixes, '';
302       $svc = $object if $object->isa('FS::svc_Common');
303     }
304   }
305   if( $svc ) {
306     push @objects, $svc->cust_svc->cust_pkg;
307     push @prefixes, '';
308   }
309
310   foreach my $obj (@objects) {
311     my $prefix = shift @prefixes;
312     foreach my $name (@{ $subs->{$obj->table} }) {
313       if(!ref($name)) {
314         # simple case
315         $hash{$prefix.$name} = $obj->$name();
316       }
317       elsif( ref($name) eq 'ARRAY' ) {
318         # [ foo => sub { ... } ]
319         $hash{$prefix.($name->[0])} = $name->[1]->($obj);
320       }
321       else {
322         warn "bad msg_template substitution: '$name'\n";
323         #skip it?
324       } 
325     } 
326   } 
327   $_ = encode_entities($_ || '') foreach values(%hash);
328
329
330   ###
331   # clean up template
332   ###
333   my $subject_tmpl = new Text::Template (
334     TYPE   => 'STRING',
335     SOURCE => $content->subject,
336   );
337   my $subject = $subject_tmpl->fill_in( HASH => \%hash );
338
339   my $body = $content->body;
340   my ($skin, $guts) = eviscerate($body);
341   @$guts = map { 
342     $_ = decode_entities($_); # turn all punctuation back into itself
343     s/\r//gs;           # remove \r's
344     s/<br[^>]*>/\n/gsi; # and <br /> tags
345     s/<p>/\n/gsi;       # and <p>
346     s/<\/p>//gsi;       # and </p>
347     s/\240/ /gs;        # and &nbsp;
348     $_
349   } @$guts;
350   
351   $body = '{ use Date::Format qw(time2str); "" }';
352   while(@$skin || @$guts) {
353     $body .= shift(@$skin) || '';
354     $body .= shift(@$guts) || '';
355   }
356
357   ###
358   # fill-in
359   ###
360
361   my $body_tmpl = new Text::Template (
362     TYPE          => 'STRING',
363     SOURCE        => $body,
364   );
365
366   $body = $body_tmpl->fill_in( HASH => \%hash );
367
368   ###
369   # and email
370   ###
371
372   my @to;
373   if ( exists($opt{'to'}) ) {
374     @to = split(/\s*,\s*/, $opt{'to'});
375   }
376   else {
377     @to = $cust_main->invoicing_list_emailonly;
378   }
379   # no warning when preparing with no destination
380
381   my $from_addr = $self->from_addr;
382
383   if ( !$from_addr ) {
384     if ( $opt{'from_config'} ) {
385       $from_addr = scalar( $conf->config($opt{'from_config'}, 
386                                          $cust_main->agentnum) );
387     }
388     $from_addr ||= scalar( $conf->config('invoice_from',
389                                          $cust_main->agentnum) );
390   }
391 #  my @cust_msg = ();
392 #  if ( $conf->exists('log_sent_mail') and !$opt{'preview'} ) {
393 #    my $cust_msg = FS::cust_msg->new({
394 #        'custnum' => $cust_main->custnum,
395 #        'msgnum'  => $self->msgnum,
396 #        'status'  => 'prepared',
397 #      });
398 #    $cust_msg->insert;
399 #    @cust_msg = ('cust_msg' => $cust_msg);
400 #  }
401
402   (
403     'custnum' => $cust_main->custnum,
404     'msgnum'  => $self->msgnum,
405     'from' => $from_addr,
406     'to'   => \@to,
407     'bcc'  => $self->bcc_addr || undef,
408     'subject'   => $subject,
409     'html_body' => $body,
410     'text_body' => HTML::FormatText->new(leftmargin => 0, rightmargin => 70
411                     )->format( HTML::TreeBuilder->new_from_content($body) ),
412   );
413
414 }
415
416 =item send OPTION => VALUE
417
418 Fills in the template and sends it to the customer.  Options are as for 
419 'prepare'.
420
421 =cut
422
423 # broken out from prepare() in case we want to queue the sending,
424 # preview it, etc.
425 sub send {
426   my $self = shift;
427   send_email(generate_email($self->prepare(@_)));
428 }
429
430 # helper sub for package dates
431 my $ymd = sub { $_[0] ? time2str('%Y-%m-%d', $_[0]) : '' };
432
433 # helper sub for usage-related messages
434 my $usage_warning = sub {
435   my $svc = shift;
436   foreach my $col (qw(seconds upbytes downbytes totalbytes)) {
437     my $amount = $svc->$col; next if $amount eq '';
438     my $method = $col.'_threshold';
439     my $threshold = $svc->$method; next if $threshold eq '';
440     return [$col, $amount, $threshold] if $amount <= $threshold;
441     # this only returns the first one that's below threshold, if there are 
442     # several.
443   }
444   return ['', '', ''];
445 };
446
447 #my $conf = new FS::Conf;
448
449 #return contexts and fill-in values
450 # If you add anything, be sure to add a description in 
451 # httemplate/edit/msg_template.html.
452 sub substitutions {
453   { 'cust_main' => [qw(
454       display_custnum agentnum agent_name
455
456       last first company
457       name name_short contact contact_firstlast
458       address1 address2 city county state zip
459       country
460       daytime night fax
461
462       has_ship_address
463       ship_last ship_first ship_company
464       ship_name ship_name_short ship_contact ship_contact_firstlast
465       ship_address1 ship_address2 ship_city ship_county ship_state ship_zip
466       ship_country
467       ship_daytime ship_night ship_fax
468
469       paymask payname paytype payip
470       num_cancelled_pkgs num_ncancelled_pkgs num_pkgs
471       classname categoryname
472       balance
473       credit_limit
474       invoicing_list_emailonly
475       cust_status ucfirst_cust_status cust_statuscolor
476
477       signupdate dundate
478       packages recurdates
479       ),
480       [ expdate           => sub { shift->paydate_epoch } ], #compatibility
481       [ signupdate_ymd    => sub { $ymd->(shift->signupdate) } ],
482       [ dundate_ymd       => sub { $ymd->(shift->dundate) } ],
483       [ paydate_my        => sub { sprintf('%02d/%04d', shift->paydate_monthyear) } ],
484       [ otaker_first      => sub { shift->access_user->first } ],
485       [ otaker_last       => sub { shift->access_user->last } ],
486       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
487       [ company_name      => sub { 
488           $conf->config('company_name', shift->agentnum) 
489         } ],
490       [ company_address   => sub {
491           $conf->config('company_address', shift->agentnum)
492         } ],
493       [ company_phonenum  => sub {
494           $conf->config('company_phonenum', shift->agentnum)
495         } ],
496     ],
497     # next_bill_date
498     'cust_pkg'  => [qw( 
499       pkgnum pkg_label pkg_label_long
500       location_label
501       status statuscolor
502     
503       start_date setup bill last_bill 
504       adjourn susp expire 
505       labels_short
506       ),
507       [ pkg               => sub { shift->part_pkg->pkg } ],
508       [ cancel            => sub { shift->getfield('cancel') } ], # grrr...
509       [ start_ymd         => sub { $ymd->(shift->getfield('start_date')) } ],
510       [ setup_ymd         => sub { $ymd->(shift->getfield('setup')) } ],
511       [ next_bill_ymd     => sub { $ymd->(shift->getfield('bill')) } ],
512       [ last_bill_ymd     => sub { $ymd->(shift->getfield('last_bill')) } ],
513       [ adjourn_ymd       => sub { $ymd->(shift->getfield('adjourn')) } ],
514       [ susp_ymd          => sub { $ymd->(shift->getfield('susp')) } ],
515       [ expire_ymd        => sub { $ymd->(shift->getfield('expire')) } ],
516       [ cancel_ymd        => sub { $ymd->(shift->getfield('cancel')) } ],
517     ],
518     'cust_bill' => [qw(
519       invnum
520       _date
521     )],
522     #XXX not really thinking about cust_bill substitutions quite yet
523     
524     # for welcome and limit warning messages
525     'svc_acct' => [qw(
526       svcnum
527       username
528       domain
529       ),
530       [ password          => sub { shift->getfield('_password') } ],
531       [ column            => sub { &$usage_warning(shift)->[0] } ],
532       [ amount            => sub { &$usage_warning(shift)->[1] } ],
533       [ threshold         => sub { &$usage_warning(shift)->[2] } ],
534     ],
535     'svc_domain' => [qw(
536       svcnum
537       domain
538       ),
539       [ registrar         => sub {
540           my $registrar = qsearchs('registrar', 
541             { registrarnum => shift->registrarnum} );
542           $registrar ? $registrar->registrarname : ''
543         }
544       ],
545       [ catchall          => sub { 
546           my $svc_acct = qsearchs('svc_acct', { svcnum => shift->catchall });
547           $svc_acct ? $svc_acct->email : ''
548         }
549       ],
550     ],
551     'svc_phone' => [qw(
552       svcnum
553       phonenum
554       countrycode
555       domain
556       )
557     ],
558     'svc_broadband' => [qw(
559       svcnum
560       speed_up
561       speed_down
562       ip_addr
563       mac_addr
564       )
565     ],
566     # for payment receipts
567     'cust_pay' => [qw(
568       paynum
569       _date
570       ),
571       [ paid              => sub { sprintf("%.2f", shift->paid) } ],
572       # overrides the one in cust_main in cases where a cust_pay is passed
573       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
574       [ date              => sub { time2str("%a %B %o, %Y", shift->_date) } ],
575       [ payinfo           => sub { 
576           my $cust_pay = shift;
577           ($cust_pay->payby eq 'CARD' || $cust_pay->payby eq 'CHEK') ?
578             $cust_pay->paymask : $cust_pay->decrypt($cust_pay->payinfo)
579         } ],
580     ],
581     # for payment decline messages
582     # try to support all cust_pay fields
583     # 'error' is a special case, it contains the raw error from the gateway
584     'cust_pay_pending' => [qw(
585       _date
586       error
587       ),
588       [ paid              => sub { sprintf("%.2f", shift->paid) } ],
589       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
590       [ date              => sub { time2str("%a %B %o, %Y", shift->_date) } ],
591       [ payinfo           => sub {
592           my $pending = shift;
593           ($pending->payby eq 'CARD' || $pending->payby eq 'CHEK') ?
594             $pending->paymask : $pending->decrypt($pending->payinfo)
595         } ],
596     ],
597   };
598 }
599
600 =item content LOCALE
601
602 Returns the L<FS::template_content> object appropriate to LOCALE, if there 
603 is one.  If not, returns the one with a NULL locale.
604
605 =cut
606
607 sub content {
608   my $self = shift;
609   my $locale = shift;
610   qsearchs('template_content', 
611             { 'msgnum' => $self->msgnum, 'locale' => $locale }) || 
612   qsearchs('template_content',
613             { 'msgnum' => $self->msgnum, 'locale' => '' });
614 }
615
616 =item agent
617
618 Returns the L<FS::agent> object for this template.
619
620 =cut
621
622 sub agent {
623   qsearchs('agent', { 'agentnum' => $_[0]->agentnum });
624 }
625
626 sub _upgrade_data {
627   my ($self, %opts) = @_;
628
629   my @fixes = (
630     [ 'alerter_msgnum',  'alerter_template',   '',               '', '' ],
631     [ 'cancel_msgnum',   'cancelmessage',      'cancelsubject',  '', '' ],
632     [ 'decline_msgnum',  'declinetemplate',    '',               '', '' ],
633     [ 'impending_recur_msgnum', 'impending_recur_template', '',  '', 'impending_recur_bcc' ],
634     [ 'payment_receipt_msgnum', 'payment_receipt_email', '',     '', '' ],
635     [ 'welcome_msgnum',  'welcome_email',      'welcome_email-subject', 'welcome_email-from', '' ],
636     [ 'warning_msgnum',  'warning_email',      'warning_email-subject', 'warning_email-from', '' ],
637   );
638  
639   my @agentnums = ('', map {$_->agentnum} qsearch('agent', {}));
640   foreach my $agentnum (@agentnums) {
641     foreach (@fixes) {
642       my ($newname, $oldname, $subject, $from, $bcc) = @$_;
643       if ($conf->exists($oldname, $agentnum)) {
644         my $new = new FS::msg_template({
645           'msgname'   => $oldname,
646           'agentnum'  => $agentnum,
647           'from_addr' => ($from && $conf->config($from, $agentnum)) || 
648                          $conf->config('invoice_from', $agentnum),
649           'bcc_addr'  => ($bcc && $conf->config($from, $agentnum)) || '',
650           'subject'   => ($subject && $conf->config($subject, $agentnum)) || '',
651           'mime_type' => 'text/html',
652           'body'      => join('<BR>',$conf->config($oldname, $agentnum)),
653         });
654         my $error = $new->insert;
655         die $error if $error;
656         $conf->set($newname, $new->msgnum, $agentnum);
657         $conf->delete($oldname, $agentnum);
658         $conf->delete($from, $agentnum) if $from;
659         $conf->delete($subject, $agentnum) if $subject;
660       }
661     }
662   }
663   foreach my $msg_template ( qsearch('msg_template', {}) ) {
664     if ( $msg_template->subject || $msg_template->body ) {
665       # create new default content
666       my %content;
667       foreach ('subject','body') {
668         $content{$_} = $msg_template->$_;
669         $msg_template->setfield($_, '');
670       }
671
672       my $error = $msg_template->replace(%content);
673       die $error if $error;
674     }
675   }
676 }
677
678 sub eviscerate {
679   # Every bit as pleasant as it sounds.
680   #
681   # We do this because Text::Template::Preprocess doesn't
682   # actually work.  It runs the entire template through 
683   # the preprocessor, instead of the code segments.  Which 
684   # is a shame, because Text::Template already contains
685   # the code to do this operation.
686   my $body = shift;
687   my (@outside, @inside);
688   my $depth = 0;
689   my $chunk = '';
690   while($body || $chunk) {
691     my ($first, $delim, $rest);
692     # put all leading non-delimiters into $first
693     ($first, $rest) =
694         ($body =~ /^((?:\\[{}]|[^{}])*)(.*)$/s);
695     $chunk .= $first;
696     # put a leading delimiter into $delim if there is one
697     ($delim, $rest) =
698       ($rest =~ /^([{}]?)(.*)$/s);
699
700     if( $delim eq '{' ) {
701       $chunk .= '{';
702       if( $depth == 0 ) {
703         push @outside, $chunk;
704         $chunk = '';
705       }
706       $depth++;
707     }
708     elsif( $delim eq '}' ) {
709       $depth--;
710       if( $depth == 0 ) {
711         push @inside, $chunk;
712         $chunk = '';
713       }
714       $chunk .= '}';
715     }
716     else {
717       # no more delimiters
718       if( $depth == 0 ) {
719         push @outside, $chunk . $rest;
720       } # else ? something wrong
721       last;
722     }
723     $body = $rest;
724   }
725   (\@outside, \@inside);
726 }
727
728 =back
729
730 =head1 BUGS
731
732 =head1 SEE ALSO
733
734 L<FS::Record>, schema.html from the base documentation.
735
736 =cut
737
738 1;
739