4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
9 $username_uppercase $username_percent
10 $password_noampersand $password_noexclamation
11 $warning_template $warning_from $warning_subject $warning_mimetype
14 $radius_password $radius_ip
20 use Crypt::PasswdMD5 1.2;
22 use Authen::Passphrase;
23 use FS::UID qw( datasrc driver_name );
25 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
26 use FS::Msgcat qw(gettext);
27 use FS::UI::bytecount;
32 use FS::cust_main_invoice;
36 use FS::radius_usergroup;
43 @ISA = qw( FS::svc_Common );
46 $me = '[FS::svc_acct]';
48 #ask FS::UID to run this stuff for us later
49 $FS::UID::callback{'FS::svc_acct'} = sub {
51 $dir_prefix = $conf->config('home');
52 @shells = $conf->config('shells');
53 $usernamemin = $conf->config('usernamemin') || 2;
54 $usernamemax = $conf->config('usernamemax');
55 $passwordmin = $conf->config('passwordmin') || 6;
56 $passwordmax = $conf->config('passwordmax') || 8;
57 $username_letter = $conf->exists('username-letter');
58 $username_letterfirst = $conf->exists('username-letterfirst');
59 $username_noperiod = $conf->exists('username-noperiod');
60 $username_nounderscore = $conf->exists('username-nounderscore');
61 $username_nodash = $conf->exists('username-nodash');
62 $username_uppercase = $conf->exists('username-uppercase');
63 $username_ampersand = $conf->exists('username-ampersand');
64 $username_percent = $conf->exists('username-percent');
65 $password_noampersand = $conf->exists('password-noexclamation');
66 $password_noexclamation = $conf->exists('password-noexclamation');
67 $dirhash = $conf->config('dirhash') || 0;
68 if ( $conf->exists('warning_email') ) {
69 $warning_template = new Text::Template (
71 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
72 ) or warn "can't create warning email template: $Text::Template::ERROR";
73 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
74 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
75 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
76 $warning_cc = $conf->config('warning_email-cc');
78 $warning_template = '';
80 $warning_subject = '';
81 $warning_mimetype = '';
84 $smtpmachine = $conf->config('smtpmachine');
85 $radius_password = $conf->config('radius-password') || 'Password';
86 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
87 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
90 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
91 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
95 my ( $hashref, $cache ) = @_;
96 if ( $hashref->{'svc_acct_svcnum'} ) {
97 $self->{'_domsvc'} = FS::svc_domain->new( {
98 'svcnum' => $hashref->{'domsvc'},
99 'domain' => $hashref->{'svc_acct_domain'},
100 'catchall' => $hashref->{'svc_acct_catchall'},
107 FS::svc_acct - Object methods for svc_acct records
113 $record = new FS::svc_acct \%hash;
114 $record = new FS::svc_acct { 'column' => 'value' };
116 $error = $record->insert;
118 $error = $new_record->replace($old_record);
120 $error = $record->delete;
122 $error = $record->check;
124 $error = $record->suspend;
126 $error = $record->unsuspend;
128 $error = $record->cancel;
130 %hash = $record->radius;
132 %hash = $record->radius_reply;
134 %hash = $record->radius_check;
136 $domain = $record->domain;
138 $svc_domain = $record->svc_domain;
140 $email = $record->email;
142 $seconds_since = $record->seconds_since($timestamp);
146 An FS::svc_acct object represents an account. FS::svc_acct inherits from
147 FS::svc_Common. The following fields are currently supported:
151 =item svcnum - primary key (assigned automatcially for new accounts)
155 =item _password - generated if blank
157 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
159 =item sec_phrase - security phrase
161 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
169 =item dir - set automatically if blank (and uid is not)
173 =item quota - (unimplementd)
175 =item slipip - IP address
185 =item domsvc - svcnum from svc_domain
187 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
189 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
199 Creates a new account. To add the account to the database, see L<"insert">.
206 'longname_plural' => 'Access accounts and mailboxes',
207 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
208 'display_weight' => 10,
209 'cancel_weight' => 50,
211 'dir' => 'Home directory',
214 def_label => 'UID (set to fixed and blank for no UIDs)',
217 'slipip' => 'IP address',
218 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
220 label => 'Access number',
222 select_table => 'svc_acct_pop',
223 select_key => 'popnum',
224 select_label => 'city',
230 disable_default => 1,
237 disable_inventory => 1,
240 '_password' => 'Password',
243 def_label => 'GID (when blank, defaults to UID)',
247 #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
249 def_label=> 'Shell (set to blank for no shell tracking)',
251 select_list => [ $conf->config('shells') ],
252 disable_inventory => 1,
255 'finger' => 'Real name (GECOS)',
258 #def_label => 'svcnum from svc_domain',
260 select_table => 'svc_domain',
261 select_key => 'svcnum',
262 select_label => 'domain',
263 disable_inventory => 1,
267 label => 'RADIUS groups',
268 type => 'radius_usergroup_selector',
269 disable_inventory => 1,
272 'seconds' => { label => 'Seconds',
273 label_sort => 'with Time Remaining',
275 disable_inventory => 1,
278 'upbytes' => { label => 'Upload',
280 disable_inventory => 1,
282 'format' => \&FS::UI::bytecount::display_bytecount,
283 'parse' => \&FS::UI::bytecount::parse_bytecount,
285 'downbytes' => { label => 'Download',
287 disable_inventory => 1,
289 'format' => \&FS::UI::bytecount::display_bytecount,
290 'parse' => \&FS::UI::bytecount::parse_bytecount,
292 'totalbytes'=> { label => 'Total up and download',
294 disable_inventory => 1,
296 'format' => \&FS::UI::bytecount::display_bytecount,
297 'parse' => \&FS::UI::bytecount::parse_bytecount,
299 'seconds_threshold' => { label => 'Seconds threshold',
301 disable_inventory => 1,
304 'upbytes_threshold' => { label => 'Upload threshold',
306 disable_inventory => 1,
308 'format' => \&FS::UI::bytecount::display_bytecount,
309 'parse' => \&FS::UI::bytecount::parse_bytecount,
311 'downbytes_threshold' => { label => 'Download threshold',
313 disable_inventory => 1,
315 'format' => \&FS::UI::bytecount::display_bytecount,
316 'parse' => \&FS::UI::bytecount::parse_bytecount,
318 'totalbytes_threshold'=> { label => 'Total up and download threshold',
320 disable_inventory => 1,
322 'format' => \&FS::UI::bytecount::display_bytecount,
323 'parse' => \&FS::UI::bytecount::parse_bytecount,
326 label => 'Last login',
330 label => 'Last logout',
337 sub table { 'svc_acct'; }
341 #false laziness with edit/svc_acct.cgi
343 my( $self, $groups ) = @_;
344 if ( ref($groups) eq 'ARRAY' ) {
346 } elsif ( length($groups) ) {
347 [ split(/\s*,\s*/, $groups) ];
356 shift->_lastlog('in', @_);
360 shift->_lastlog('out', @_);
364 my( $self, $op, $time ) = @_;
366 if ( defined($time) ) {
367 warn "$me last_log$op called on svcnum ". $self->svcnum.
368 ' ('. $self->email. "): $time\n"
371 local $SIG{HUP} = 'IGNORE';
372 local $SIG{INT} = 'IGNORE';
373 local $SIG{QUIT} = 'IGNORE';
374 local $SIG{TERM} = 'IGNORE';
375 local $SIG{TSTP} = 'IGNORE';
376 local $SIG{PIPE} = 'IGNORE';
378 my $oldAutoCommit = $FS::UID::AutoCommit;
379 local $FS::UID::AutoCommit = 0;
382 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
386 my $sth = $dbh->prepare( $sql )
387 or die "Error preparing $sql: ". $dbh->errstr;
388 my $rv = $sth->execute($time, $self->svcnum);
389 die "Error executing $sql: ". $sth->errstr
391 die "Can't update last_log$op for svcnum". $self->svcnum
394 warn "$me update successful; committing\n"
396 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
397 $self->{'Hash'}->{"last_log$op"} = $time;
399 $self->getfield("last_log$op");
403 =item search_sql STRING
405 Class method which returns an SQL fragment to search for the given string.
410 my( $class, $string ) = @_;
411 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
412 my( $username, $domain ) = ( $1, $2 );
413 my $q_username = dbh->quote($username);
414 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
416 "svc_acct.username = $q_username AND ( ".
417 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
422 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
424 $class->search_sql_field('slipip', $string ).
426 $class->search_sql_field('username', $string ).
429 $class->search_sql_field('username', $string);
433 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
435 Returns the "username@domain" string for this account.
437 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
449 =item insert [ , OPTION => VALUE ... ]
451 Adds this account to the database. If there is an error, returns the error,
452 otherwise returns false.
454 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
455 defined. An FS::cust_svc record will be created and inserted.
457 The additional field I<usergroup> can optionally be defined; if so it should
458 contain an arrayref of group names. See L<FS::radius_usergroup>.
460 The additional field I<child_objects> can optionally be defined; if so it
461 should contain an arrayref of FS::tablename objects. They will have their
462 svcnum fields set and will be inserted after this record, but before any
463 exports are run. Each element of the array can also optionally be a
464 two-element array reference containing the child object and the name of an
465 alternate field to be filled in with the newly-inserted svcnum, for example
466 C<[ $svc_forward, 'srcsvc' ]>
468 Currently available options are: I<depend_jobnum>
470 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
471 jobnums), all provisioning jobs will have a dependancy on the supplied
472 jobnum(s) (they will not run until the specific job(s) complete(s)).
474 (TODOC: L<FS::queue> and L<freeside-queued>)
476 (TODOC: new exports!)
485 warn "[$me] insert called on $self: ". Dumper($self).
486 "\nwith options: ". Dumper(%options);
489 local $SIG{HUP} = 'IGNORE';
490 local $SIG{INT} = 'IGNORE';
491 local $SIG{QUIT} = 'IGNORE';
492 local $SIG{TERM} = 'IGNORE';
493 local $SIG{TSTP} = 'IGNORE';
494 local $SIG{PIPE} = 'IGNORE';
496 my $oldAutoCommit = $FS::UID::AutoCommit;
497 local $FS::UID::AutoCommit = 0;
500 my $error = $self->check;
501 return $error if $error;
503 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
504 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
505 unless ( $cust_svc ) {
506 $dbh->rollback if $oldAutoCommit;
507 return "no cust_svc record found for svcnum ". $self->svcnum;
509 $self->pkgnum($cust_svc->pkgnum);
510 $self->svcpart($cust_svc->svcpart);
513 $error = $self->_check_duplicate;
515 $dbh->rollback if $oldAutoCommit;
520 $error = $self->SUPER::insert(
521 'jobnums' => \@jobnums,
522 'child_objects' => $self->child_objects,
526 $dbh->rollback if $oldAutoCommit;
530 if ( $self->usergroup ) {
531 foreach my $groupname ( @{$self->usergroup} ) {
532 my $radius_usergroup = new FS::radius_usergroup ( {
533 svcnum => $self->svcnum,
534 groupname => $groupname,
536 my $error = $radius_usergroup->insert;
538 $dbh->rollback if $oldAutoCommit;
544 unless ( $skip_fuzzyfiles ) {
545 $error = $self->queue_fuzzyfiles_update;
547 $dbh->rollback if $oldAutoCommit;
548 return "updating fuzzy search cache: $error";
552 my $cust_pkg = $self->cust_svc->cust_pkg;
555 my $cust_main = $cust_pkg->cust_main;
556 my $agentnum = $cust_main->agentnum;
558 if ( $conf->exists('emailinvoiceautoalways')
559 || $conf->exists('emailinvoiceauto')
560 && ! $cust_main->invoicing_list_emailonly
562 my @invoicing_list = $cust_main->invoicing_list;
563 push @invoicing_list, $self->email;
564 $cust_main->invoicing_list(\@invoicing_list);
568 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
569 = ('','','','','','');
571 if ( $conf->exists('welcome_email', $agentnum) ) {
572 $welcome_template = new Text::Template (
574 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
575 ) or warn "can't create welcome email template: $Text::Template::ERROR";
576 $welcome_from = $conf->config('welcome_email-from', $agentnum);
577 # || 'your-isp-is-dum'
578 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
580 $welcome_subject_template = new Text::Template (
582 SOURCE => $welcome_subject,
583 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
584 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
587 if ( $welcome_template && $cust_pkg ) {
588 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
592 'custnum' => $self->custnum,
593 'username' => $self->username,
594 'password' => $self->_password,
595 'first' => $cust_main->first,
596 'last' => $cust_main->getfield('last'),
597 'pkg' => $cust_pkg->part_pkg->pkg,
599 my $wqueue = new FS::queue {
600 'svcnum' => $self->svcnum,
601 'job' => 'FS::svc_acct::send_email'
603 my $error = $wqueue->insert(
605 'from' => $welcome_from,
606 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
607 'mimetype' => $welcome_mimetype,
608 'body' => $welcome_template->fill_in( HASH => \%hash, ),
611 $dbh->rollback if $oldAutoCommit;
612 return "error queuing welcome email: $error";
615 if ( $options{'depend_jobnum'} ) {
616 warn "$me depend_jobnum found; adding to welcome email dependancies"
618 if ( ref($options{'depend_jobnum'}) ) {
619 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
620 "to welcome email dependancies"
622 push @jobnums, @{ $options{'depend_jobnum'} };
624 warn "$me adding job $options{'depend_jobnum'} ".
625 "to welcome email dependancies"
627 push @jobnums, $options{'depend_jobnum'};
631 foreach my $jobnum ( @jobnums ) {
632 my $error = $wqueue->depend_insert($jobnum);
634 $dbh->rollback if $oldAutoCommit;
635 return "error queuing welcome email job dependancy: $error";
645 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
651 Deletes this account from the database. If there is an error, returns the
652 error, otherwise returns false.
654 The corresponding FS::cust_svc record will be deleted as well.
656 (TODOC: new exports!)
663 return "can't delete system account" if $self->_check_system;
665 return "Can't delete an account which is a (svc_forward) source!"
666 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
668 return "Can't delete an account which is a (svc_forward) destination!"
669 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
671 return "Can't delete an account with (svc_www) web service!"
672 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
674 # what about records in session ? (they should refer to history table)
676 local $SIG{HUP} = 'IGNORE';
677 local $SIG{INT} = 'IGNORE';
678 local $SIG{QUIT} = 'IGNORE';
679 local $SIG{TERM} = 'IGNORE';
680 local $SIG{TSTP} = 'IGNORE';
681 local $SIG{PIPE} = 'IGNORE';
683 my $oldAutoCommit = $FS::UID::AutoCommit;
684 local $FS::UID::AutoCommit = 0;
687 foreach my $cust_main_invoice (
688 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
690 unless ( defined($cust_main_invoice) ) {
691 warn "WARNING: something's wrong with qsearch";
694 my %hash = $cust_main_invoice->hash;
695 $hash{'dest'} = $self->email;
696 my $new = new FS::cust_main_invoice \%hash;
697 my $error = $new->replace($cust_main_invoice);
699 $dbh->rollback if $oldAutoCommit;
704 foreach my $svc_domain (
705 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
707 my %hash = new FS::svc_domain->hash;
708 $hash{'catchall'} = '';
709 my $new = new FS::svc_domain \%hash;
710 my $error = $new->replace($svc_domain);
712 $dbh->rollback if $oldAutoCommit;
717 my $error = $self->SUPER::delete;
719 $dbh->rollback if $oldAutoCommit;
723 foreach my $radius_usergroup (
724 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
726 my $error = $radius_usergroup->delete;
728 $dbh->rollback if $oldAutoCommit;
733 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
737 =item replace OLD_RECORD
739 Replaces OLD_RECORD with this one in the database. If there is an error,
740 returns the error, otherwise returns false.
742 The additional field I<usergroup> can optionally be defined; if so it should
743 contain an arrayref of group names. See L<FS::radius_usergroup>.
749 my ( $new, $old ) = ( shift, shift );
751 warn "$me replacing $old with $new\n" if $DEBUG;
753 # We absolutely have to have an old vs. new record to make this work.
754 if (!defined($old)) {
755 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
758 return "can't modify system account" if $old->_check_system;
761 #no warnings 'numeric'; #alas, a 5.006-ism
764 foreach my $xid (qw( uid gid )) {
766 return "Can't change $xid!"
767 if ! $conf->exists("svc_acct-edit_$xid")
768 && $old->$xid() != $new->$xid()
769 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
774 #change homdir when we change username
775 $new->setfield('dir', '') if $old->username ne $new->username;
777 local $SIG{HUP} = 'IGNORE';
778 local $SIG{INT} = 'IGNORE';
779 local $SIG{QUIT} = 'IGNORE';
780 local $SIG{TERM} = 'IGNORE';
781 local $SIG{TSTP} = 'IGNORE';
782 local $SIG{PIPE} = 'IGNORE';
784 my $oldAutoCommit = $FS::UID::AutoCommit;
785 local $FS::UID::AutoCommit = 0;
788 # redundant, but so $new->usergroup gets set
789 $error = $new->check;
790 return $error if $error;
792 $old->usergroup( [ $old->radius_groups ] );
794 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
795 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
797 if ( $new->usergroup ) {
798 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
799 my @newgroups = @{$new->usergroup};
800 foreach my $oldgroup ( @{$old->usergroup} ) {
801 if ( grep { $oldgroup eq $_ } @newgroups ) {
802 @newgroups = grep { $oldgroup ne $_ } @newgroups;
805 my $radius_usergroup = qsearchs('radius_usergroup', {
806 svcnum => $old->svcnum,
807 groupname => $oldgroup,
809 my $error = $radius_usergroup->delete;
811 $dbh->rollback if $oldAutoCommit;
812 return "error deleting radius_usergroup $oldgroup: $error";
816 foreach my $newgroup ( @newgroups ) {
817 my $radius_usergroup = new FS::radius_usergroup ( {
818 svcnum => $new->svcnum,
819 groupname => $newgroup,
821 my $error = $radius_usergroup->insert;
823 $dbh->rollback if $oldAutoCommit;
824 return "error adding radius_usergroup $newgroup: $error";
830 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
831 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
832 $error = $new->_check_duplicate;
834 $dbh->rollback if $oldAutoCommit;
839 $error = $new->SUPER::replace($old, @_);
841 $dbh->rollback if $oldAutoCommit;
842 return $error if $error;
845 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
846 $error = $new->queue_fuzzyfiles_update;
848 $dbh->rollback if $oldAutoCommit;
849 return "updating fuzzy search cache: $error";
853 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
857 =item queue_fuzzyfiles_update
859 Used by insert & replace to update the fuzzy search cache
863 sub queue_fuzzyfiles_update {
866 local $SIG{HUP} = 'IGNORE';
867 local $SIG{INT} = 'IGNORE';
868 local $SIG{QUIT} = 'IGNORE';
869 local $SIG{TERM} = 'IGNORE';
870 local $SIG{TSTP} = 'IGNORE';
871 local $SIG{PIPE} = 'IGNORE';
873 my $oldAutoCommit = $FS::UID::AutoCommit;
874 local $FS::UID::AutoCommit = 0;
877 my $queue = new FS::queue {
878 'svcnum' => $self->svcnum,
879 'job' => 'FS::svc_acct::append_fuzzyfiles'
881 my $error = $queue->insert($self->username);
883 $dbh->rollback if $oldAutoCommit;
884 return "queueing job (transaction rolled back): $error";
887 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
895 Suspends this account by calling export-specific suspend hooks. If there is
896 an error, returns the error, otherwise returns false.
898 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
904 return "can't suspend system account" if $self->_check_system;
905 $self->SUPER::suspend(@_);
910 Unsuspends this account by by calling export-specific suspend hooks. If there
911 is an error, returns the error, otherwise returns false.
913 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
919 my %hash = $self->hash;
920 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
921 $hash{_password} = $1;
922 my $new = new FS::svc_acct ( \%hash );
923 my $error = $new->replace($self);
924 return $error if $error;
927 $self->SUPER::unsuspend(@_);
932 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
934 If the B<auto_unset_catchall> configuration option is set, this method will
935 automatically remove any references to the canceled service in the catchall
936 field of svc_domain. This allows packages that contain both a svc_domain and
937 its catchall svc_acct to be canceled in one step.
942 # Only one thing to do at this level
944 foreach my $svc_domain (
945 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
946 if($conf->exists('auto_unset_catchall')) {
947 my %hash = $svc_domain->hash;
948 $hash{catchall} = '';
949 my $new = new FS::svc_domain ( \%hash );
950 my $error = $new->replace($svc_domain);
951 return $error if $error;
953 return "cannot unprovision svc_acct #".$self->svcnum.
954 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
958 $self->SUPER::cancel(@_);
964 Checks all fields to make sure this is a valid service. If there is an error,
965 returns the error, otherwise returns false. Called by the insert and replace
968 Sets any fixed values; see L<FS::part_svc>.
975 my($recref) = $self->hashref;
977 my $x = $self->setfixed( $self->_fieldhandlers );
978 return $x unless ref($x);
981 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
983 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
986 my $error = $self->ut_numbern('svcnum')
987 #|| $self->ut_number('domsvc')
988 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
989 || $self->ut_textn('sec_phrase')
990 || $self->ut_snumbern('seconds')
991 || $self->ut_snumbern('upbytes')
992 || $self->ut_snumbern('downbytes')
993 || $self->ut_snumbern('totalbytes')
994 || $self->ut_enum( '_password_encoding',
995 [ '', qw( plain crypt ldap ) ]
998 return $error if $error;
1000 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1001 if ( $username_uppercase ) {
1002 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
1003 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1004 $recref->{username} = $1;
1006 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
1007 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1008 $recref->{username} = $1;
1011 if ( $username_letterfirst ) {
1012 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1013 } elsif ( $username_letter ) {
1014 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1016 if ( $username_noperiod ) {
1017 $recref->{username} =~ /\./ and return gettext('illegal_username');
1019 if ( $username_nounderscore ) {
1020 $recref->{username} =~ /_/ and return gettext('illegal_username');
1022 if ( $username_nodash ) {
1023 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1025 unless ( $username_ampersand ) {
1026 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1028 unless ( $username_percent ) {
1029 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1032 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1033 $recref->{popnum} = $1;
1034 return "Unknown popnum" unless
1035 ! $recref->{popnum} ||
1036 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1038 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1040 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1041 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1043 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1044 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1045 #not all systems use gid=uid
1046 #you can set a fixed gid in part_svc
1048 return "Only root can have uid 0"
1049 if $recref->{uid} == 0
1050 && $recref->{username} !~ /^(root|toor|smtp)$/;
1052 unless ( $recref->{username} eq 'sync' ) {
1053 if ( grep $_ eq $recref->{shell}, @shells ) {
1054 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1056 return "Illegal shell \`". $self->shell. "\'; ".
1057 "shells configuration value contains: @shells";
1060 $recref->{shell} = '/bin/sync';
1064 $recref->{gid} ne '' ?
1065 return "Can't have gid without uid" : ( $recref->{gid}='' );
1066 #$recref->{dir} ne '' ?
1067 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1068 $recref->{shell} ne '' ?
1069 return "Can't have shell without uid" : ( $recref->{shell}='' );
1072 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1074 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1075 or return "Illegal directory: ". $recref->{dir};
1076 $recref->{dir} = $1;
1077 return "Illegal directory"
1078 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1079 return "Illegal directory"
1080 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1081 unless ( $recref->{dir} ) {
1082 $recref->{dir} = $dir_prefix . '/';
1083 if ( $dirhash > 0 ) {
1084 for my $h ( 1 .. $dirhash ) {
1085 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1087 } elsif ( $dirhash < 0 ) {
1088 for my $h ( reverse $dirhash .. -1 ) {
1089 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1092 $recref->{dir} .= $recref->{username};
1098 # $error = $self->ut_textn('finger');
1099 # return $error if $error;
1100 if ( $self->getfield('finger') eq '' ) {
1101 my $cust_pkg = $self->svcnum
1102 ? $self->cust_svc->cust_pkg
1103 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1105 my $cust_main = $cust_pkg->cust_main;
1106 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1109 $self->getfield('finger') =~
1110 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1111 or return "Illegal finger: ". $self->getfield('finger');
1112 $self->setfield('finger', $1);
1114 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1115 $recref->{quota} = $1;
1117 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1118 if ( $recref->{slipip} eq '' ) {
1119 $recref->{slipip} = '';
1120 } elsif ( $recref->{slipip} eq '0e0' ) {
1121 $recref->{slipip} = '0e0';
1123 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1124 or return "Illegal slipip: ". $self->slipip;
1125 $recref->{slipip} = $1;
1130 #arbitrary RADIUS stuff; allow ut_textn for now
1131 foreach ( grep /^radius_/, fields('svc_acct') ) {
1132 $self->ut_textn($_);
1135 if ( $recref->{_password_encoding} eq 'ldap' ) {
1137 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1138 $recref->{_password} = uc($1).$2;
1140 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1143 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1145 if ( $recref->{_password} =~
1146 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1147 /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1150 $recref->{_password} = $1.$2;
1153 return 'Illegal (crypt-encoded) password';
1156 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1158 #generate a password if it is blank
1159 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1160 unless length( $recref->{_password} );
1162 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1163 $recref->{_password} = $1;
1165 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1166 FS::Msgcat::_gettext('illegal_password_characters').
1167 ": ". $recref->{_password};
1170 if ( $password_noampersand ) {
1171 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1173 if ( $password_noexclamation ) {
1174 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1179 #carp "warning: _password_encoding unspecified\n";
1181 #generate a password if it is blank
1182 unless ( length( $recref->{_password} ) ) {
1184 $recref->{_password} =
1185 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1186 $recref->{_password_encoding} = 'plain';
1190 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1191 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1192 $recref->{_password} = $1.$3;
1193 $recref->{_password_encoding} = 'plain';
1194 } elsif ( $recref->{_password} =~
1195 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1197 $recref->{_password} = $1.$3;
1198 $recref->{_password_encoding} = 'crypt';
1199 } elsif ( $recref->{_password} eq '*' ) {
1200 $recref->{_password} = '*';
1201 $recref->{_password_encoding} = 'crypt';
1202 } elsif ( $recref->{_password} eq '!' ) {
1203 $recref->{_password_encoding} = 'crypt';
1204 $recref->{_password} = '!';
1205 } elsif ( $recref->{_password} eq '!!' ) {
1206 $recref->{_password} = '!!';
1207 $recref->{_password_encoding} = 'crypt';
1209 #return "Illegal password";
1210 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1211 FS::Msgcat::_gettext('illegal_password_characters').
1212 ": ". $recref->{_password};
1219 $self->SUPER::check;
1225 Internal function to check the username against the list of system usernames
1226 from the I<system_usernames> configuration value. Returns true if the username
1227 is listed on the system username list.
1233 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1234 $conf->config('system_usernames')
1238 =item _check_duplicate
1240 Internal function to check for duplicates usernames, username@domain pairs and
1243 If the I<global_unique-username> configuration value is set to B<username> or
1244 B<username@domain>, enforces global username or username@domain uniqueness.
1246 In all cases, check for duplicate uids and usernames or username@domain pairs
1247 per export and with identical I<svcpart> values.
1251 sub _check_duplicate {
1254 my $global_unique = $conf->config('global_unique-username') || 'none';
1255 return '' if $global_unique eq 'disabled';
1257 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1258 if ( driver_name =~ /^Pg/i ) {
1259 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1261 } elsif ( driver_name =~ /^mysql/i ) {
1262 dbh->do("SELECT * FROM duplicate_lock
1263 WHERE lockname = 'svc_acct'
1265 ) or die dbh->errstr;
1267 die "unknown database ". driver_name.
1268 "; don't know how to lock for duplicate search";
1270 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1272 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1273 unless ( $part_svc ) {
1274 return 'unknown svcpart '. $self->svcpart;
1277 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1278 qsearch( 'svc_acct', { 'username' => $self->username } );
1279 return gettext('username_in_use')
1280 if $global_unique eq 'username' && @dup_user;
1282 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1283 qsearch( 'svc_acct', { 'username' => $self->username,
1284 'domsvc' => $self->domsvc } );
1285 return gettext('username_in_use')
1286 if $global_unique eq 'username@domain' && @dup_userdomain;
1289 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1290 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1291 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1292 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1297 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1298 my $exports = FS::part_export::export_info('svc_acct');
1299 my %conflict_user_svcpart;
1300 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1302 foreach my $part_export ( $part_svc->part_export ) {
1304 #this will catch to the same exact export
1305 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1307 #this will catch to exports w/same exporthost+type ???
1308 #my @other_part_export = qsearch('part_export', {
1309 # 'machine' => $part_export->machine,
1310 # 'exporttype' => $part_export->exporttype,
1312 #foreach my $other_part_export ( @other_part_export ) {
1313 # push @svcparts, map { $_->svcpart }
1314 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1317 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1318 #silly kludge to avoid uninitialized value errors
1319 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1320 ? $exports->{$part_export->exporttype}{'nodomain'}
1322 if ( $nodomain =~ /^Y/i ) {
1323 $conflict_user_svcpart{$_} = $part_export->exportnum
1326 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1331 foreach my $dup_user ( @dup_user ) {
1332 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1333 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1334 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1335 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1339 foreach my $dup_userdomain ( @dup_userdomain ) {
1340 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1341 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1342 return "duplicate username\@domain: conflicts with svcnum ".
1343 $dup_userdomain->svcnum. " via exportnum ".
1344 $conflict_userdomain_svcpart{$dup_svcpart};
1348 foreach my $dup_uid ( @dup_uid ) {
1349 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1350 if ( exists($conflict_user_svcpart{$dup_svcpart})
1351 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1352 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1353 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1354 || $conflict_userdomain_svcpart{$dup_svcpart};
1366 Depriciated, use radius_reply instead.
1371 carp "FS::svc_acct::radius depriciated, use radius_reply";
1372 $_[0]->radius_reply;
1377 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1378 reply attributes of this record.
1380 Note that this is now the preferred method for reading RADIUS attributes -
1381 accessing the columns directly is discouraged, as the column names are
1382 expected to change in the future.
1389 return %{ $self->{'radius_reply'} }
1390 if exists $self->{'radius_reply'};
1395 my($column, $attrib) = ($1, $2);
1396 #$attrib =~ s/_/\-/g;
1397 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1398 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1400 if ( $self->slipip && $self->slipip ne '0e0' ) {
1401 $reply{$radius_ip} = $self->slipip;
1404 if ( $self->seconds !~ /^$/ ) {
1405 $reply{'Session-Timeout'} = $self->seconds;
1413 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1414 check attributes of this record.
1416 Note that this is now the preferred method for reading RADIUS attributes -
1417 accessing the columns directly is discouraged, as the column names are
1418 expected to change in the future.
1425 return %{ $self->{'radius_check'} }
1426 if exists $self->{'radius_check'};
1431 my($column, $attrib) = ($1, $2);
1432 #$attrib =~ s/_/\-/g;
1433 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1434 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1436 my $password = $self->_password;
1437 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1439 my $cust_svc = $self->cust_svc;
1440 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1442 my $cust_pkg = $cust_svc->cust_pkg;
1443 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1444 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1453 This method instructs the object to "snapshot" or freeze RADIUS check and
1454 reply attributes to the current values.
1458 #bah, my english is too broken this morning
1459 #Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill. (This is used by
1460 #the FS::cust_pkg's replace method to trigger the correct export updates when
1461 #package dates change)
1466 $self->{$_} = { $self->$_() }
1467 foreach qw( radius_reply radius_check );
1471 =item forget_snapshot
1473 This methos instructs the object to forget any previously snapshotted
1474 RADIUS check and reply attributes.
1478 sub forget_snapshot {
1482 foreach qw( radius_reply radius_check );
1486 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1488 Returns the domain associated with this account.
1490 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1497 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1498 my $svc_domain = $self->svc_domain(@_)
1499 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1500 $svc_domain->domain;
1505 Returns the FS::svc_domain record for this account's domain (see
1510 # FS::h_svc_acct has a history-aware svc_domain override
1515 ? $self->{'_domsvc'}
1516 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1521 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1525 #inherited from svc_Common
1527 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1529 Returns an email address associated with the account.
1531 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1538 $self->username. '@'. $self->domain(@_);
1543 Returns an array of FS::acct_snarf records associated with the account.
1544 If the acct_snarf table does not exist or there are no associated records,
1545 an empty list is returned
1551 return () unless dbdef->table('acct_snarf');
1552 eval "use FS::acct_snarf;";
1554 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1557 =item decrement_upbytes OCTETS
1559 Decrements the I<upbytes> field of this record by the given amount. If there
1560 is an error, returns the error, otherwise returns false.
1564 sub decrement_upbytes {
1565 shift->_op_usage('-', 'upbytes', @_);
1568 =item increment_upbytes OCTETS
1570 Increments the I<upbytes> field of this record by the given amount. If there
1571 is an error, returns the error, otherwise returns false.
1575 sub increment_upbytes {
1576 shift->_op_usage('+', 'upbytes', @_);
1579 =item decrement_downbytes OCTETS
1581 Decrements the I<downbytes> field of this record by the given amount. If there
1582 is an error, returns the error, otherwise returns false.
1586 sub decrement_downbytes {
1587 shift->_op_usage('-', 'downbytes', @_);
1590 =item increment_downbytes OCTETS
1592 Increments the I<downbytes> field of this record by the given amount. If there
1593 is an error, returns the error, otherwise returns false.
1597 sub increment_downbytes {
1598 shift->_op_usage('+', 'downbytes', @_);
1601 =item decrement_totalbytes OCTETS
1603 Decrements the I<totalbytes> field of this record by the given amount. If there
1604 is an error, returns the error, otherwise returns false.
1608 sub decrement_totalbytes {
1609 shift->_op_usage('-', 'totalbytes', @_);
1612 =item increment_totalbytes OCTETS
1614 Increments the I<totalbytes> field of this record by the given amount. If there
1615 is an error, returns the error, otherwise returns false.
1619 sub increment_totalbytes {
1620 shift->_op_usage('+', 'totalbytes', @_);
1623 =item decrement_seconds SECONDS
1625 Decrements the I<seconds> field of this record by the given amount. If there
1626 is an error, returns the error, otherwise returns false.
1630 sub decrement_seconds {
1631 shift->_op_usage('-', 'seconds', @_);
1634 =item increment_seconds SECONDS
1636 Increments the I<seconds> field of this record by the given amount. If there
1637 is an error, returns the error, otherwise returns false.
1641 sub increment_seconds {
1642 shift->_op_usage('+', 'seconds', @_);
1650 my %op2condition = (
1651 '-' => sub { my($self, $column, $amount) = @_;
1652 $self->$column - $amount <= 0;
1654 '+' => sub { my($self, $column, $amount) = @_;
1655 $self->$column + $amount > 0;
1658 my %op2warncondition = (
1659 '-' => sub { my($self, $column, $amount) = @_;
1660 my $threshold = $column . '_threshold';
1661 $self->$column - $amount <= $self->$threshold + 0;
1663 '+' => sub { my($self, $column, $amount) = @_;
1664 $self->$column + $amount > 0;
1669 my( $self, $op, $column, $amount ) = @_;
1671 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1672 ' ('. $self->email. "): $op $amount\n"
1675 return '' unless $amount;
1677 local $SIG{HUP} = 'IGNORE';
1678 local $SIG{INT} = 'IGNORE';
1679 local $SIG{QUIT} = 'IGNORE';
1680 local $SIG{TERM} = 'IGNORE';
1681 local $SIG{TSTP} = 'IGNORE';
1682 local $SIG{PIPE} = 'IGNORE';
1684 my $oldAutoCommit = $FS::UID::AutoCommit;
1685 local $FS::UID::AutoCommit = 0;
1688 my $sql = "UPDATE svc_acct SET $column = ".
1689 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1690 " $op ? WHERE svcnum = ?";
1694 my $sth = $dbh->prepare( $sql )
1695 or die "Error preparing $sql: ". $dbh->errstr;
1696 my $rv = $sth->execute($amount, $self->svcnum);
1697 die "Error executing $sql: ". $sth->errstr
1698 unless defined($rv);
1699 die "Can't update $column for svcnum". $self->svcnum
1702 my $action = $op2action{$op};
1704 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1705 ( $action eq 'suspend' && !$self->overlimit
1706 || $action eq 'unsuspend' && $self->overlimit )
1708 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1709 if ($part_export->option('overlimit_groups')) {
1711 my $other = new FS::svc_acct $self->hashref;
1712 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1713 ($self, $part_export->option('overlimit_groups'));
1714 $other->usergroup( $groups );
1715 if ($action eq 'suspend'){
1716 $new = $other; $old = $self;
1718 $new = $self; $old = $other;
1720 my $error = $part_export->export_replace($new, $old);
1721 $error ||= $self->overlimit($action);
1723 $dbh->rollback if $oldAutoCommit;
1724 return "Error replacing radius groups in export, ${op}: $error";
1730 if ( $conf->exists("svc_acct-usage_$action")
1731 && &{$op2condition{$op}}($self, $column, $amount) ) {
1732 #my $error = $self->$action();
1733 my $error = $self->cust_svc->cust_pkg->$action();
1734 # $error ||= $self->overlimit($action);
1736 $dbh->rollback if $oldAutoCommit;
1737 return "Error ${action}ing: $error";
1741 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1742 my $wqueue = new FS::queue {
1743 'svcnum' => $self->svcnum,
1744 'job' => 'FS::svc_acct::reached_threshold',
1749 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1753 my $error = $wqueue->insert(
1754 'svcnum' => $self->svcnum,
1756 'column' => $column,
1760 $dbh->rollback if $oldAutoCommit;
1761 return "Error queuing threshold activity: $error";
1765 warn "$me update successful; committing\n"
1767 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1773 my( $self, $valueref ) = @_;
1775 warn "$me set_usage called for svcnum ". $self->svcnum.
1776 ' ('. $self->email. "): ".
1777 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1780 local $SIG{HUP} = 'IGNORE';
1781 local $SIG{INT} = 'IGNORE';
1782 local $SIG{QUIT} = 'IGNORE';
1783 local $SIG{TERM} = 'IGNORE';
1784 local $SIG{TSTP} = 'IGNORE';
1785 local $SIG{PIPE} = 'IGNORE';
1787 local $FS::svc_Common::noexport_hack = 1;
1788 my $oldAutoCommit = $FS::UID::AutoCommit;
1789 local $FS::UID::AutoCommit = 0;
1794 foreach my $field (keys %$valueref){
1795 $reset = 1 if $valueref->{$field};
1796 $self->setfield($field, $valueref->{$field});
1797 $self->setfield( $field.'_threshold',
1798 int($self->getfield($field)
1799 * ( $conf->exists('svc_acct-usage_threshold')
1800 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1805 $handyhash{$field} = $self->getfield($field);
1806 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1808 #my $error = $self->replace; #NO! we avoid the call to ->check for
1809 #die $error if $error; #services not explicity changed via the UI
1811 my $sql = "UPDATE svc_acct SET " .
1812 join (',', map { "$_ = ?" } (keys %handyhash) ).
1813 " WHERE svcnum = ?";
1818 if (scalar(keys %handyhash)) {
1819 my $sth = $dbh->prepare( $sql )
1820 or die "Error preparing $sql: ". $dbh->errstr;
1821 my $rv = $sth->execute((values %handyhash), $self->svcnum);
1822 die "Error executing $sql: ". $sth->errstr
1823 unless defined($rv);
1824 die "Can't update usage for svcnum ". $self->svcnum
1831 if ($self->overlimit) {
1832 $error = $self->overlimit('unsuspend');
1833 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1834 if ($part_export->option('overlimit_groups')) {
1835 my $old = new FS::svc_acct $self->hashref;
1836 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1837 ($self, $part_export->option('overlimit_groups'));
1838 $old->usergroup( $groups );
1839 $error ||= $part_export->export_replace($self, $old);
1844 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1845 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1848 $dbh->rollback if $oldAutoCommit;
1849 return "Error unsuspending: $error";
1853 warn "$me update successful; committing\n"
1855 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1861 =item recharge HASHREF
1863 Increments usage columns by the amount specified in HASHREF as
1864 column=>amount pairs.
1869 my ($self, $vhash) = @_;
1872 warn "[$me] recharge called on $self: ". Dumper($self).
1873 "\nwith vhash: ". Dumper($vhash);
1876 my $oldAutoCommit = $FS::UID::AutoCommit;
1877 local $FS::UID::AutoCommit = 0;
1881 foreach my $column (keys %$vhash){
1882 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1886 $dbh->rollback if $oldAutoCommit;
1888 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1893 =item is_rechargeable
1895 Returns true if this svc_account can be "recharged" and false otherwise.
1899 sub is_rechargable {
1901 $self->seconds ne ''
1902 || $self->upbytes ne ''
1903 || $self->downbytes ne ''
1904 || $self->totalbytes ne '';
1907 =item seconds_since TIMESTAMP
1909 Returns the number of seconds this account has been online since TIMESTAMP,
1910 according to the session monitor (see L<FS::Session>).
1912 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1913 L<Time::Local> and L<Date::Parse> for conversion functions.
1917 #note: POD here, implementation in FS::cust_svc
1920 $self->cust_svc->seconds_since(@_);
1923 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1925 Returns the numbers of seconds this account has been online between
1926 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1927 external SQL radacct table, specified via sqlradius export. Sessions which
1928 started in the specified range but are still open are counted from session
1929 start to the end of the range (unless they are over 1 day old, in which case
1930 they are presumed missing their stop record and not counted). Also, sessions
1931 which end in the range but started earlier are counted from the start of the
1932 range to session end. Finally, sessions which start before the range but end
1933 after are counted for the entire range.
1935 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1936 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1941 #note: POD here, implementation in FS::cust_svc
1942 sub seconds_since_sqlradacct {
1944 $self->cust_svc->seconds_since_sqlradacct(@_);
1947 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1949 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1950 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1951 TIMESTAMP_END (exclusive).
1953 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1954 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1959 #note: POD here, implementation in FS::cust_svc
1960 sub attribute_since_sqlradacct {
1962 $self->cust_svc->attribute_since_sqlradacct(@_);
1965 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1967 Returns an array of hash references of this customers login history for the
1968 given time range. (document this better)
1972 sub get_session_history {
1974 $self->cust_svc->get_session_history(@_);
1977 =item last_login_text
1979 Returns text describing the time of last login.
1983 sub last_login_text {
1985 $self->last_login ? ctime($self->last_login) : 'unknown';
1988 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1993 my($self, $start, $end, %opt ) = @_;
1995 my $did = $self->username; #yup
1997 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1999 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2001 #SELECT $for_update * FROM cdr
2002 # WHERE calldate >= $start #need a conversion
2003 # AND calldate < $end #ditto
2004 # AND ( charged_party = "$did"
2005 # OR charged_party = "$prefix$did" #if length($prefix);
2006 # OR ( ( charged_party IS NULL OR charged_party = '' )
2008 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2011 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2014 if ( length($prefix) ) {
2016 " AND ( charged_party = '$did'
2017 OR charged_party = '$prefix$did'
2018 OR ( ( charged_party IS NULL OR charged_party = '' )
2020 ( src = '$did' OR src = '$prefix$did' )
2026 " AND ( charged_party = '$did'
2027 OR ( ( charged_party IS NULL OR charged_party = '' )
2037 'select' => "$for_update *",
2040 #( freesidestatus IS NULL OR freesidestatus = '' )
2041 'freesidestatus' => '',
2043 'extra_sql' => $charged_or_src,
2051 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2057 if ( $self->usergroup ) {
2058 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2059 unless ref($self->usergroup) eq 'ARRAY';
2060 #when provisioning records, export callback runs in svc_Common.pm before
2061 #radius_usergroup records can be inserted...
2062 @{$self->usergroup};
2064 map { $_->groupname }
2065 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2069 =item clone_suspended
2071 Constructor used by FS::part_export::_export_suspend fallback. Document
2076 sub clone_suspended {
2078 my %hash = $self->hash;
2079 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2080 new FS::svc_acct \%hash;
2083 =item clone_kludge_unsuspend
2085 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2090 sub clone_kludge_unsuspend {
2092 my %hash = $self->hash;
2093 $hash{_password} = '';
2094 new FS::svc_acct \%hash;
2097 =item check_password
2099 Checks the supplied password against the (possibly encrypted) password in the
2100 database. Returns true for a successful authentication, false for no match.
2102 Currently supported encryptions are: classic DES crypt() and MD5
2106 sub check_password {
2107 my($self, $check_password) = @_;
2109 #remove old-style SUSPENDED kludge, they should be allowed to login to
2110 #self-service and pay up
2111 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2113 if ( $self->_password_encoding eq 'ldap' ) {
2115 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2116 return $auth->match($check_password);
2118 } elsif ( $self->_password_encoding eq 'crypt' ) {
2120 my $auth = from_crypt Authen::Passphrase $self->_password;
2121 return $auth->match($check_password);
2123 } elsif ( $self->_password_encoding eq 'plain' ) {
2125 return $check_password eq $password;
2129 #XXX this could be replaced with Authen::Passphrase stuff
2131 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2133 } elsif ( length($password) < 13 ) { #plaintext
2134 $check_password eq $password;
2135 } elsif ( length($password) == 13 ) { #traditional DES crypt
2136 crypt($check_password, $password) eq $password;
2137 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2138 unix_md5_crypt($check_password, $password) eq $password;
2139 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2140 warn "Can't check password: Blowfish encryption not yet supported, ".
2141 "svcnum ". $self->svcnum. "\n";
2144 warn "Can't check password: Unrecognized encryption for svcnum ".
2145 $self->svcnum. "\n";
2153 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2155 Returns an encrypted password, either by passing through an encrypted password
2156 in the database or by encrypting a plaintext password from the database.
2158 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2159 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2160 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2161 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2162 encryption type is only used if the password is not already encrypted in the
2167 sub crypt_password {
2170 if ( $self->_password_encoding eq 'ldap' ) {
2172 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2175 #XXX this could be replaced with Authen::Passphrase stuff
2177 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2178 if ( $encryption eq 'crypt' ) {
2181 $saltset[int(rand(64))].$saltset[int(rand(64))]
2183 } elsif ( $encryption eq 'md5' ) {
2184 unix_md5_crypt( $self->_password );
2185 } elsif ( $encryption eq 'blowfish' ) {
2186 croak "unknown encryption method $encryption";
2188 croak "unknown encryption method $encryption";
2191 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2195 } elsif ( $self->_password_encoding eq 'crypt' ) {
2197 return $self->_password;
2199 } elsif ( $self->_password_encoding eq 'plain' ) {
2201 #XXX this could be replaced with Authen::Passphrase stuff
2203 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2204 if ( $encryption eq 'crypt' ) {
2207 $saltset[int(rand(64))].$saltset[int(rand(64))]
2209 } elsif ( $encryption eq 'md5' ) {
2210 unix_md5_crypt( $self->_password );
2211 } elsif ( $encryption eq 'blowfish' ) {
2212 croak "unknown encryption method $encryption";
2214 croak "unknown encryption method $encryption";
2219 if ( length($self->_password) == 13
2220 || $self->_password =~ /^\$(1|2a?)\$/
2221 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2227 #XXX this could be replaced with Authen::Passphrase stuff
2229 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2230 if ( $encryption eq 'crypt' ) {
2233 $saltset[int(rand(64))].$saltset[int(rand(64))]
2235 } elsif ( $encryption eq 'md5' ) {
2236 unix_md5_crypt( $self->_password );
2237 } elsif ( $encryption eq 'blowfish' ) {
2238 croak "unknown encryption method $encryption";
2240 croak "unknown encryption method $encryption";
2249 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2251 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2252 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2253 "{MD5}5426824942db4253f87a1009fd5d2d4".
2255 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2256 to work the same as the B</crypt_password> method.
2262 #eventually should check a "password-encoding" field
2264 if ( $self->_password_encoding eq 'ldap' ) {
2266 return $self->_password;
2268 } elsif ( $self->_password_encoding eq 'crypt' ) {
2270 if ( length($self->_password) == 13 ) { #crypt
2271 return '{CRYPT}'. $self->_password;
2272 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2274 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2275 # die "Blowfish encryption not supported in this context, svcnum ".
2276 # $self->svcnum. "\n";
2278 warn "encryption method not (yet?) supported in LDAP context";
2279 return '{CRYPT}*'; #unsupported, should not auth
2282 } elsif ( $self->_password_encoding eq 'plain' ) {
2284 return '{PLAIN}'. $self->_password;
2286 #return '{CLEARTEXT}'. $self->_password; #?
2290 if ( length($self->_password) == 13 ) { #crypt
2291 return '{CRYPT}'. $self->_password;
2292 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2294 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2295 warn "Blowfish encryption not supported in this context, svcnum ".
2296 $self->svcnum. "\n";
2299 #are these two necessary anymore?
2300 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2301 return '{SSHA}'. $1;
2302 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2303 return '{NS-MTA-MD5}'. $1;
2306 return '{PLAIN}'. $self->_password;
2308 #return '{CLEARTEXT}'. $self->_password; #?
2310 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2311 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2312 #if ( $encryption eq 'crypt' ) {
2313 # return '{CRYPT}'. crypt(
2315 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2317 #} elsif ( $encryption eq 'md5' ) {
2318 # unix_md5_crypt( $self->_password );
2319 #} elsif ( $encryption eq 'blowfish' ) {
2320 # croak "unknown encryption method $encryption";
2322 # croak "unknown encryption method $encryption";
2330 =item domain_slash_username
2332 Returns $domain/$username/
2336 sub domain_slash_username {
2338 $self->domain. '/'. $self->username. '/';
2341 =item virtual_maildir
2343 Returns $domain/maildirs/$username/
2347 sub virtual_maildir {
2349 $self->domain. '/maildirs/'. $self->username. '/';
2360 This is the FS::svc_acct job-queue-able version. It still uses
2361 FS::Misc::send_email under-the-hood.
2368 eval "use FS::Misc qw(send_email)";
2371 $opt{mimetype} ||= 'text/plain';
2372 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2374 my $error = send_email(
2375 'from' => $opt{from},
2377 'subject' => $opt{subject},
2378 'content-type' => $opt{mimetype},
2379 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2381 die $error if $error;
2384 =item check_and_rebuild_fuzzyfiles
2388 sub check_and_rebuild_fuzzyfiles {
2389 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2390 -e "$dir/svc_acct.username"
2391 or &rebuild_fuzzyfiles;
2394 =item rebuild_fuzzyfiles
2398 sub rebuild_fuzzyfiles {
2400 use Fcntl qw(:flock);
2402 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2406 open(USERNAMELOCK,">>$dir/svc_acct.username")
2407 or die "can't open $dir/svc_acct.username: $!";
2408 flock(USERNAMELOCK,LOCK_EX)
2409 or die "can't lock $dir/svc_acct.username: $!";
2411 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2413 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2414 or die "can't open $dir/svc_acct.username.tmp: $!";
2415 print USERNAMECACHE join("\n", @all_username), "\n";
2416 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2418 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2428 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2429 open(USERNAMECACHE,"<$dir/svc_acct.username")
2430 or die "can't open $dir/svc_acct.username: $!";
2431 my @array = map { chomp; $_; } <USERNAMECACHE>;
2432 close USERNAMECACHE;
2436 =item append_fuzzyfiles USERNAME
2440 sub append_fuzzyfiles {
2441 my $username = shift;
2443 &check_and_rebuild_fuzzyfiles;
2445 use Fcntl qw(:flock);
2447 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2449 open(USERNAME,">>$dir/svc_acct.username")
2450 or die "can't open $dir/svc_acct.username: $!";
2451 flock(USERNAME,LOCK_EX)
2452 or die "can't lock $dir/svc_acct.username: $!";
2454 print USERNAME "$username\n";
2456 flock(USERNAME,LOCK_UN)
2457 or die "can't unlock $dir/svc_acct.username: $!";
2465 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2469 sub radius_usergroup_selector {
2470 my $sel_groups = shift;
2471 my %sel_groups = map { $_=>1 } @$sel_groups;
2473 my $selectname = shift || 'radius_usergroup';
2476 my $sth = $dbh->prepare(
2477 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2478 ) or die $dbh->errstr;
2479 $sth->execute() or die $sth->errstr;
2480 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2484 function ${selectname}_doadd(object) {
2485 var myvalue = object.${selectname}_add.value;
2486 var optionName = new Option(myvalue,myvalue,false,true);
2487 var length = object.$selectname.length;
2488 object.$selectname.options[length] = optionName;
2489 object.${selectname}_add.value = "";
2492 <SELECT MULTIPLE NAME="$selectname">
2495 foreach my $group ( @all_groups ) {
2496 $html .= qq(<OPTION VALUE="$group");
2497 if ( $sel_groups{$group} ) {
2498 $html .= ' SELECTED';
2499 $sel_groups{$group} = 0;
2501 $html .= ">$group</OPTION>\n";
2503 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2504 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2506 $html .= '</SELECT>';
2508 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2509 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2514 =item reached_threshold
2516 Performs some activities when svc_acct thresholds (such as number of seconds
2517 remaining) are reached.
2521 sub reached_threshold {
2524 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2525 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2527 if ( $opt{'op'} eq '+' ){
2528 $svc_acct->setfield( $opt{'column'}.'_threshold',
2529 int($svc_acct->getfield($opt{'column'})
2530 * ( $conf->exists('svc_acct-usage_threshold')
2531 ? $conf->config('svc_acct-usage_threshold')/100
2536 my $error = $svc_acct->replace;
2537 die $error if $error;
2538 }elsif ( $opt{'op'} eq '-' ){
2540 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2541 return '' if ($threshold eq '' );
2543 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2544 my $error = $svc_acct->replace;
2545 die $error if $error; # email next time, i guess
2547 if ( $warning_template ) {
2548 eval "use FS::Misc qw(send_email)";
2551 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2552 my $cust_main = $cust_pkg->cust_main;
2554 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2555 $cust_main->invoicing_list,
2556 ($opt{'to'} ? $opt{'to'} : ())
2559 my $mimetype = $warning_mimetype;
2560 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2562 my $body = $warning_template->fill_in( HASH => {
2563 'custnum' => $cust_main->custnum,
2564 'username' => $svc_acct->username,
2565 'password' => $svc_acct->_password,
2566 'first' => $cust_main->first,
2567 'last' => $cust_main->getfield('last'),
2568 'pkg' => $cust_pkg->part_pkg->pkg,
2569 'column' => $opt{'column'},
2570 'amount' => $opt{'column'} =~/bytes/
2571 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2572 : $svc_acct->getfield($opt{'column'}),
2573 'threshold' => $opt{'column'} =~/bytes/
2574 ? FS::UI::bytecount::display_bytecount($threshold)
2579 my $error = send_email(
2580 'from' => $warning_from,
2582 'subject' => $warning_subject,
2583 'content-type' => $mimetype,
2584 'body' => [ map "$_\n", split("\n", $body) ],
2586 die $error if $error;
2589 die "unknown op: " . $opt{'op'};
2597 The $recref stuff in sub check should be cleaned up.
2599 The suspend, unsuspend and cancel methods update the database, but not the
2600 current object. This is probably a bug as it's unexpected and
2603 radius_usergroup_selector? putting web ui components in here? they should
2604 probably live somewhere else...
2606 insertion of RADIUS group stuff in insert could be done with child_objects now
2607 (would probably clean up export of them too)
2611 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2612 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2613 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2614 L<freeside-queued>), L<FS::svc_acct_pop>,
2615 schema.html from the base documentation.
2619 =item domain_select_hash %OPTIONS
2621 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2622 may at present purchase.
2624 Currently available options are: I<pkgnum> I<svcpart>
2628 sub domain_select_hash {
2629 my ($self, %options) = @_;
2635 $part_svc = $self->part_svc;
2636 $cust_pkg = $self->cust_svc->cust_pkg
2640 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2641 if $options{'svcpart'};
2643 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2644 if $options{'pkgnum'};
2646 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2647 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2648 %domains = map { $_->svcnum => $_->domain }
2649 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2650 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2651 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2652 %domains = map { $_->svcnum => $_->domain }
2653 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2654 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2655 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2657 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2660 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2661 my $svc_domain = qsearchs('svc_domain',
2662 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2663 if ( $svc_domain ) {
2664 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2666 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2667 $part_svc->part_svc_column('domsvc')->columnvalue;