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
17 use Scalar::Util qw( blessed );
21 use Crypt::PasswdMD5 1.2;
23 use Authen::Passphrase;
24 use FS::UID qw( datasrc driver_name );
26 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
27 use FS::Msgcat qw(gettext);
28 use FS::UI::bytecount;
33 use FS::cust_main_invoice;
37 use FS::radius_usergroup;
44 @ISA = qw( FS::svc_Common );
47 $me = '[FS::svc_acct]';
49 #ask FS::UID to run this stuff for us later
50 $FS::UID::callback{'FS::svc_acct'} = sub {
52 $dir_prefix = $conf->config('home');
53 @shells = $conf->config('shells');
54 $usernamemin = $conf->config('usernamemin') || 2;
55 $usernamemax = $conf->config('usernamemax');
56 $passwordmin = $conf->config('passwordmin') || 6;
57 $passwordmax = $conf->config('passwordmax') || 8;
58 $username_letter = $conf->exists('username-letter');
59 $username_letterfirst = $conf->exists('username-letterfirst');
60 $username_noperiod = $conf->exists('username-noperiod');
61 $username_nounderscore = $conf->exists('username-nounderscore');
62 $username_nodash = $conf->exists('username-nodash');
63 $username_uppercase = $conf->exists('username-uppercase');
64 $username_ampersand = $conf->exists('username-ampersand');
65 $username_percent = $conf->exists('username-percent');
66 $password_noampersand = $conf->exists('password-noexclamation');
67 $password_noexclamation = $conf->exists('password-noexclamation');
68 $dirhash = $conf->config('dirhash') || 0;
69 if ( $conf->exists('warning_email') ) {
70 $warning_template = new Text::Template (
72 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
73 ) or warn "can't create warning email template: $Text::Template::ERROR";
74 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
75 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
76 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
77 $warning_cc = $conf->config('warning_email-cc');
79 $warning_template = '';
81 $warning_subject = '';
82 $warning_mimetype = '';
85 $smtpmachine = $conf->config('smtpmachine');
86 $radius_password = $conf->config('radius-password') || 'Password';
87 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
88 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
91 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
92 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
96 my ( $hashref, $cache ) = @_;
97 if ( $hashref->{'svc_acct_svcnum'} ) {
98 $self->{'_domsvc'} = FS::svc_domain->new( {
99 'svcnum' => $hashref->{'domsvc'},
100 'domain' => $hashref->{'svc_acct_domain'},
101 'catchall' => $hashref->{'svc_acct_catchall'},
108 FS::svc_acct - Object methods for svc_acct records
114 $record = new FS::svc_acct \%hash;
115 $record = new FS::svc_acct { 'column' => 'value' };
117 $error = $record->insert;
119 $error = $new_record->replace($old_record);
121 $error = $record->delete;
123 $error = $record->check;
125 $error = $record->suspend;
127 $error = $record->unsuspend;
129 $error = $record->cancel;
131 %hash = $record->radius;
133 %hash = $record->radius_reply;
135 %hash = $record->radius_check;
137 $domain = $record->domain;
139 $svc_domain = $record->svc_domain;
141 $email = $record->email;
143 $seconds_since = $record->seconds_since($timestamp);
147 An FS::svc_acct object represents an account. FS::svc_acct inherits from
148 FS::svc_Common. The following fields are currently supported:
152 =item svcnum - primary key (assigned automatcially for new accounts)
156 =item _password - generated if blank
158 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
160 =item sec_phrase - security phrase
162 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
170 =item dir - set automatically if blank (and uid is not)
174 =item quota - (unimplementd)
176 =item slipip - IP address
186 =item domsvc - svcnum from svc_domain
188 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
190 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
200 Creates a new account. To add the account to the database, see L<"insert">.
207 'longname_plural' => 'Access accounts and mailboxes',
208 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
209 'display_weight' => 10,
210 'cancel_weight' => 50,
212 'dir' => 'Home directory',
215 def_label => 'UID (set to fixed and blank for no UIDs)',
218 'slipip' => 'IP address',
219 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
221 label => 'Access number',
223 select_table => 'svc_acct_pop',
224 select_key => 'popnum',
225 select_label => 'city',
231 disable_default => 1,
238 disable_inventory => 1,
241 '_password' => 'Password',
244 def_label => 'GID (when blank, defaults to UID)',
248 #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)',
250 def_label=> 'Shell (set to blank for no shell tracking)',
252 select_list => [ $conf->config('shells') ],
253 disable_inventory => 1,
256 'finger' => 'Real name (GECOS)',
259 #def_label => 'svcnum from svc_domain',
261 select_table => 'svc_domain',
262 select_key => 'svcnum',
263 select_label => 'domain',
264 disable_inventory => 1,
268 label => 'RADIUS groups',
269 type => 'radius_usergroup_selector',
270 disable_inventory => 1,
273 'seconds' => { label => 'Seconds',
274 label_sort => 'with Time Remaining',
276 disable_inventory => 1,
279 'upbytes' => { label => 'Upload',
281 disable_inventory => 1,
283 'format' => \&FS::UI::bytecount::display_bytecount,
284 'parse' => \&FS::UI::bytecount::parse_bytecount,
286 'downbytes' => { label => 'Download',
288 disable_inventory => 1,
290 'format' => \&FS::UI::bytecount::display_bytecount,
291 'parse' => \&FS::UI::bytecount::parse_bytecount,
293 'totalbytes'=> { label => 'Total up and download',
295 disable_inventory => 1,
297 'format' => \&FS::UI::bytecount::display_bytecount,
298 'parse' => \&FS::UI::bytecount::parse_bytecount,
300 'seconds_threshold' => { label => 'Seconds threshold',
302 disable_inventory => 1,
305 'upbytes_threshold' => { label => 'Upload threshold',
307 disable_inventory => 1,
309 'format' => \&FS::UI::bytecount::display_bytecount,
310 'parse' => \&FS::UI::bytecount::parse_bytecount,
312 'downbytes_threshold' => { label => 'Download threshold',
314 disable_inventory => 1,
316 'format' => \&FS::UI::bytecount::display_bytecount,
317 'parse' => \&FS::UI::bytecount::parse_bytecount,
319 'totalbytes_threshold'=> { label => 'Total up and download threshold',
321 disable_inventory => 1,
323 'format' => \&FS::UI::bytecount::display_bytecount,
324 'parse' => \&FS::UI::bytecount::parse_bytecount,
327 label => 'Last login',
331 label => 'Last logout',
338 sub table { 'svc_acct'; }
342 #false laziness with edit/svc_acct.cgi
344 my( $self, $groups ) = @_;
345 if ( ref($groups) eq 'ARRAY' ) {
347 } elsif ( length($groups) ) {
348 [ split(/\s*,\s*/, $groups) ];
357 shift->_lastlog('in', @_);
361 shift->_lastlog('out', @_);
365 my( $self, $op, $time ) = @_;
367 if ( defined($time) ) {
368 warn "$me last_log$op called on svcnum ". $self->svcnum.
369 ' ('. $self->email. "): $time\n"
374 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
378 my $sth = $dbh->prepare( $sql )
379 or die "Error preparing $sql: ". $dbh->errstr;
380 my $rv = $sth->execute($time, $self->svcnum);
381 die "Error executing $sql: ". $sth->errstr
383 die "Can't update last_log$op for svcnum". $self->svcnum
386 $self->{'Hash'}->{"last_log$op"} = $time;
388 $self->getfield("last_log$op");
392 =item search_sql STRING
394 Class method which returns an SQL fragment to search for the given string.
399 my( $class, $string ) = @_;
400 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
401 my( $username, $domain ) = ( $1, $2 );
402 my $q_username = dbh->quote($username);
403 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
405 "svc_acct.username = $q_username AND ( ".
406 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
411 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
413 $class->search_sql_field('slipip', $string ).
415 $class->search_sql_field('username', $string ).
418 $class->search_sql_field('username', $string);
422 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
424 Returns the "username@domain" string for this account.
426 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
438 =item insert [ , OPTION => VALUE ... ]
440 Adds this account to the database. If there is an error, returns the error,
441 otherwise returns false.
443 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
444 defined. An FS::cust_svc record will be created and inserted.
446 The additional field I<usergroup> can optionally be defined; if so it should
447 contain an arrayref of group names. See L<FS::radius_usergroup>.
449 The additional field I<child_objects> can optionally be defined; if so it
450 should contain an arrayref of FS::tablename objects. They will have their
451 svcnum fields set and will be inserted after this record, but before any
452 exports are run. Each element of the array can also optionally be a
453 two-element array reference containing the child object and the name of an
454 alternate field to be filled in with the newly-inserted svcnum, for example
455 C<[ $svc_forward, 'srcsvc' ]>
457 Currently available options are: I<depend_jobnum>
459 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
460 jobnums), all provisioning jobs will have a dependancy on the supplied
461 jobnum(s) (they will not run until the specific job(s) complete(s)).
463 (TODOC: L<FS::queue> and L<freeside-queued>)
465 (TODOC: new exports!)
474 warn "[$me] insert called on $self: ". Dumper($self).
475 "\nwith options: ". Dumper(%options);
478 local $SIG{HUP} = 'IGNORE';
479 local $SIG{INT} = 'IGNORE';
480 local $SIG{QUIT} = 'IGNORE';
481 local $SIG{TERM} = 'IGNORE';
482 local $SIG{TSTP} = 'IGNORE';
483 local $SIG{PIPE} = 'IGNORE';
485 my $oldAutoCommit = $FS::UID::AutoCommit;
486 local $FS::UID::AutoCommit = 0;
489 my $error = $self->check;
490 return $error if $error;
492 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
493 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
494 unless ( $cust_svc ) {
495 $dbh->rollback if $oldAutoCommit;
496 return "no cust_svc record found for svcnum ". $self->svcnum;
498 $self->pkgnum($cust_svc->pkgnum);
499 $self->svcpart($cust_svc->svcpart);
502 $error = $self->_check_duplicate;
504 $dbh->rollback if $oldAutoCommit;
509 $error = $self->SUPER::insert(
510 'jobnums' => \@jobnums,
511 'child_objects' => $self->child_objects,
515 $dbh->rollback if $oldAutoCommit;
519 if ( $self->usergroup ) {
520 foreach my $groupname ( @{$self->usergroup} ) {
521 my $radius_usergroup = new FS::radius_usergroup ( {
522 svcnum => $self->svcnum,
523 groupname => $groupname,
525 my $error = $radius_usergroup->insert;
527 $dbh->rollback if $oldAutoCommit;
533 unless ( $skip_fuzzyfiles ) {
534 $error = $self->queue_fuzzyfiles_update;
536 $dbh->rollback if $oldAutoCommit;
537 return "updating fuzzy search cache: $error";
541 my $cust_pkg = $self->cust_svc->cust_pkg;
544 my $cust_main = $cust_pkg->cust_main;
545 my $agentnum = $cust_main->agentnum;
547 if ( $conf->exists('emailinvoiceautoalways')
548 || $conf->exists('emailinvoiceauto')
549 && ! $cust_main->invoicing_list_emailonly
551 my @invoicing_list = $cust_main->invoicing_list;
552 push @invoicing_list, $self->email;
553 $cust_main->invoicing_list(\@invoicing_list);
557 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
558 = ('','','','','','');
560 if ( $conf->exists('welcome_email', $agentnum) ) {
561 $welcome_template = new Text::Template (
563 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
564 ) or warn "can't create welcome email template: $Text::Template::ERROR";
565 $welcome_from = $conf->config('welcome_email-from', $agentnum);
566 # || 'your-isp-is-dum'
567 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
569 $welcome_subject_template = new Text::Template (
571 SOURCE => $welcome_subject,
572 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
573 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
576 if ( $welcome_template && $cust_pkg ) {
577 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
581 'custnum' => $self->custnum,
582 'username' => $self->username,
583 'password' => $self->_password,
584 'first' => $cust_main->first,
585 'last' => $cust_main->getfield('last'),
586 'pkg' => $cust_pkg->part_pkg->pkg,
588 my $wqueue = new FS::queue {
589 'svcnum' => $self->svcnum,
590 'job' => 'FS::svc_acct::send_email'
592 my $error = $wqueue->insert(
594 'from' => $welcome_from,
595 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
596 'mimetype' => $welcome_mimetype,
597 'body' => $welcome_template->fill_in( HASH => \%hash, ),
600 $dbh->rollback if $oldAutoCommit;
601 return "error queuing welcome email: $error";
604 if ( $options{'depend_jobnum'} ) {
605 warn "$me depend_jobnum found; adding to welcome email dependancies"
607 if ( ref($options{'depend_jobnum'}) ) {
608 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
609 "to welcome email dependancies"
611 push @jobnums, @{ $options{'depend_jobnum'} };
613 warn "$me adding job $options{'depend_jobnum'} ".
614 "to welcome email dependancies"
616 push @jobnums, $options{'depend_jobnum'};
620 foreach my $jobnum ( @jobnums ) {
621 my $error = $wqueue->depend_insert($jobnum);
623 $dbh->rollback if $oldAutoCommit;
624 return "error queuing welcome email job dependancy: $error";
634 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
640 Deletes this account from the database. If there is an error, returns the
641 error, otherwise returns false.
643 The corresponding FS::cust_svc record will be deleted as well.
645 (TODOC: new exports!)
652 return "can't delete system account" if $self->_check_system;
654 return "Can't delete an account which is a (svc_forward) source!"
655 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
657 return "Can't delete an account which is a (svc_forward) destination!"
658 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
660 return "Can't delete an account with (svc_www) web service!"
661 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
663 # what about records in session ? (they should refer to history table)
665 local $SIG{HUP} = 'IGNORE';
666 local $SIG{INT} = 'IGNORE';
667 local $SIG{QUIT} = 'IGNORE';
668 local $SIG{TERM} = 'IGNORE';
669 local $SIG{TSTP} = 'IGNORE';
670 local $SIG{PIPE} = 'IGNORE';
672 my $oldAutoCommit = $FS::UID::AutoCommit;
673 local $FS::UID::AutoCommit = 0;
676 foreach my $cust_main_invoice (
677 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
679 unless ( defined($cust_main_invoice) ) {
680 warn "WARNING: something's wrong with qsearch";
683 my %hash = $cust_main_invoice->hash;
684 $hash{'dest'} = $self->email;
685 my $new = new FS::cust_main_invoice \%hash;
686 my $error = $new->replace($cust_main_invoice);
688 $dbh->rollback if $oldAutoCommit;
693 foreach my $svc_domain (
694 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
696 my %hash = new FS::svc_domain->hash;
697 $hash{'catchall'} = '';
698 my $new = new FS::svc_domain \%hash;
699 my $error = $new->replace($svc_domain);
701 $dbh->rollback if $oldAutoCommit;
706 my $error = $self->SUPER::delete;
708 $dbh->rollback if $oldAutoCommit;
712 foreach my $radius_usergroup (
713 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
715 my $error = $radius_usergroup->delete;
717 $dbh->rollback if $oldAutoCommit;
722 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
726 =item replace OLD_RECORD
728 Replaces OLD_RECORD with this one in the database. If there is an error,
729 returns the error, otherwise returns false.
731 The additional field I<usergroup> can optionally be defined; if so it should
732 contain an arrayref of group names. See L<FS::radius_usergroup>.
740 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
744 warn "$me replacing $old with $new\n" if $DEBUG;
748 return "can't modify system account" if $old->_check_system;
751 #no warnings 'numeric'; #alas, a 5.006-ism
754 foreach my $xid (qw( uid gid )) {
756 return "Can't change $xid!"
757 if ! $conf->exists("svc_acct-edit_$xid")
758 && $old->$xid() != $new->$xid()
759 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
764 #change homdir when we change username
765 $new->setfield('dir', '') if $old->username ne $new->username;
767 local $SIG{HUP} = 'IGNORE';
768 local $SIG{INT} = 'IGNORE';
769 local $SIG{QUIT} = 'IGNORE';
770 local $SIG{TERM} = 'IGNORE';
771 local $SIG{TSTP} = 'IGNORE';
772 local $SIG{PIPE} = 'IGNORE';
774 my $oldAutoCommit = $FS::UID::AutoCommit;
775 local $FS::UID::AutoCommit = 0;
778 # redundant, but so $new->usergroup gets set
779 $error = $new->check;
780 return $error if $error;
782 $old->usergroup( [ $old->radius_groups ] );
784 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
785 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
787 if ( $new->usergroup ) {
788 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
789 my @newgroups = @{$new->usergroup};
790 foreach my $oldgroup ( @{$old->usergroup} ) {
791 if ( grep { $oldgroup eq $_ } @newgroups ) {
792 @newgroups = grep { $oldgroup ne $_ } @newgroups;
795 my $radius_usergroup = qsearchs('radius_usergroup', {
796 svcnum => $old->svcnum,
797 groupname => $oldgroup,
799 my $error = $radius_usergroup->delete;
801 $dbh->rollback if $oldAutoCommit;
802 return "error deleting radius_usergroup $oldgroup: $error";
806 foreach my $newgroup ( @newgroups ) {
807 my $radius_usergroup = new FS::radius_usergroup ( {
808 svcnum => $new->svcnum,
809 groupname => $newgroup,
811 my $error = $radius_usergroup->insert;
813 $dbh->rollback if $oldAutoCommit;
814 return "error adding radius_usergroup $newgroup: $error";
820 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
821 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
822 $error = $new->_check_duplicate;
824 $dbh->rollback if $oldAutoCommit;
829 $error = $new->SUPER::replace($old, @_);
831 $dbh->rollback if $oldAutoCommit;
832 return $error if $error;
835 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
836 $error = $new->queue_fuzzyfiles_update;
838 $dbh->rollback if $oldAutoCommit;
839 return "updating fuzzy search cache: $error";
843 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
847 =item queue_fuzzyfiles_update
849 Used by insert & replace to update the fuzzy search cache
853 sub queue_fuzzyfiles_update {
856 local $SIG{HUP} = 'IGNORE';
857 local $SIG{INT} = 'IGNORE';
858 local $SIG{QUIT} = 'IGNORE';
859 local $SIG{TERM} = 'IGNORE';
860 local $SIG{TSTP} = 'IGNORE';
861 local $SIG{PIPE} = 'IGNORE';
863 my $oldAutoCommit = $FS::UID::AutoCommit;
864 local $FS::UID::AutoCommit = 0;
867 my $queue = new FS::queue {
868 'svcnum' => $self->svcnum,
869 'job' => 'FS::svc_acct::append_fuzzyfiles'
871 my $error = $queue->insert($self->username);
873 $dbh->rollback if $oldAutoCommit;
874 return "queueing job (transaction rolled back): $error";
877 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
885 Suspends this account by calling export-specific suspend hooks. If there is
886 an error, returns the error, otherwise returns false.
888 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
894 return "can't suspend system account" if $self->_check_system;
895 $self->SUPER::suspend(@_);
900 Unsuspends this account by by calling export-specific suspend hooks. If there
901 is an error, returns the error, otherwise returns false.
903 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
909 my %hash = $self->hash;
910 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
911 $hash{_password} = $1;
912 my $new = new FS::svc_acct ( \%hash );
913 my $error = $new->replace($self);
914 return $error if $error;
917 $self->SUPER::unsuspend(@_);
922 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
924 If the B<auto_unset_catchall> configuration option is set, this method will
925 automatically remove any references to the canceled service in the catchall
926 field of svc_domain. This allows packages that contain both a svc_domain and
927 its catchall svc_acct to be canceled in one step.
932 # Only one thing to do at this level
934 foreach my $svc_domain (
935 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
936 if($conf->exists('auto_unset_catchall')) {
937 my %hash = $svc_domain->hash;
938 $hash{catchall} = '';
939 my $new = new FS::svc_domain ( \%hash );
940 my $error = $new->replace($svc_domain);
941 return $error if $error;
943 return "cannot unprovision svc_acct #".$self->svcnum.
944 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
948 $self->SUPER::cancel(@_);
954 Checks all fields to make sure this is a valid service. If there is an error,
955 returns the error, otherwise returns false. Called by the insert and replace
958 Sets any fixed values; see L<FS::part_svc>.
965 my($recref) = $self->hashref;
967 my $x = $self->setfixed( $self->_fieldhandlers );
968 return $x unless ref($x);
971 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
973 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
976 my $error = $self->ut_numbern('svcnum')
977 #|| $self->ut_number('domsvc')
978 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
979 || $self->ut_textn('sec_phrase')
980 || $self->ut_snumbern('seconds')
981 || $self->ut_snumbern('upbytes')
982 || $self->ut_snumbern('downbytes')
983 || $self->ut_snumbern('totalbytes')
984 || $self->ut_enum( '_password_encoding',
985 [ '', qw( plain crypt ldap ) ]
988 return $error if $error;
990 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
991 if ( $username_uppercase ) {
992 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
993 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
994 $recref->{username} = $1;
996 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
997 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
998 $recref->{username} = $1;
1001 if ( $username_letterfirst ) {
1002 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1003 } elsif ( $username_letter ) {
1004 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1006 if ( $username_noperiod ) {
1007 $recref->{username} =~ /\./ and return gettext('illegal_username');
1009 if ( $username_nounderscore ) {
1010 $recref->{username} =~ /_/ and return gettext('illegal_username');
1012 if ( $username_nodash ) {
1013 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1015 unless ( $username_ampersand ) {
1016 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1018 unless ( $username_percent ) {
1019 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1022 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1023 $recref->{popnum} = $1;
1024 return "Unknown popnum" unless
1025 ! $recref->{popnum} ||
1026 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1028 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1030 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1031 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1033 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1034 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1035 #not all systems use gid=uid
1036 #you can set a fixed gid in part_svc
1038 return "Only root can have uid 0"
1039 if $recref->{uid} == 0
1040 && $recref->{username} !~ /^(root|toor|smtp)$/;
1042 unless ( $recref->{username} eq 'sync' ) {
1043 if ( grep $_ eq $recref->{shell}, @shells ) {
1044 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1046 return "Illegal shell \`". $self->shell. "\'; ".
1047 "shells configuration value contains: @shells";
1050 $recref->{shell} = '/bin/sync';
1054 $recref->{gid} ne '' ?
1055 return "Can't have gid without uid" : ( $recref->{gid}='' );
1056 #$recref->{dir} ne '' ?
1057 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1058 $recref->{shell} ne '' ?
1059 return "Can't have shell without uid" : ( $recref->{shell}='' );
1062 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1064 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1065 or return "Illegal directory: ". $recref->{dir};
1066 $recref->{dir} = $1;
1067 return "Illegal directory"
1068 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1069 return "Illegal directory"
1070 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1071 unless ( $recref->{dir} ) {
1072 $recref->{dir} = $dir_prefix . '/';
1073 if ( $dirhash > 0 ) {
1074 for my $h ( 1 .. $dirhash ) {
1075 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1077 } elsif ( $dirhash < 0 ) {
1078 for my $h ( reverse $dirhash .. -1 ) {
1079 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1082 $recref->{dir} .= $recref->{username};
1088 # $error = $self->ut_textn('finger');
1089 # return $error if $error;
1090 if ( $self->getfield('finger') eq '' ) {
1091 my $cust_pkg = $self->svcnum
1092 ? $self->cust_svc->cust_pkg
1093 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1095 my $cust_main = $cust_pkg->cust_main;
1096 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1099 $self->getfield('finger') =~
1100 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1101 or return "Illegal finger: ". $self->getfield('finger');
1102 $self->setfield('finger', $1);
1104 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1105 $recref->{quota} = $1;
1107 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1108 if ( $recref->{slipip} eq '' ) {
1109 $recref->{slipip} = '';
1110 } elsif ( $recref->{slipip} eq '0e0' ) {
1111 $recref->{slipip} = '0e0';
1113 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1114 or return "Illegal slipip: ". $self->slipip;
1115 $recref->{slipip} = $1;
1120 #arbitrary RADIUS stuff; allow ut_textn for now
1121 foreach ( grep /^radius_/, fields('svc_acct') ) {
1122 $self->ut_textn($_);
1125 if ( $recref->{_password_encoding} eq 'ldap' ) {
1127 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1128 $recref->{_password} = uc($1).$2;
1130 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1133 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1135 if ( $recref->{_password} =~
1136 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1137 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1140 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1143 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1146 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1148 #generate a password if it is blank
1149 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1150 unless length( $recref->{_password} );
1152 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1153 $recref->{_password} = $1;
1155 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1156 FS::Msgcat::_gettext('illegal_password_characters').
1157 ": ". $recref->{_password};
1160 if ( $password_noampersand ) {
1161 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1163 if ( $password_noexclamation ) {
1164 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1169 #carp "warning: _password_encoding unspecified\n";
1171 #generate a password if it is blank
1172 unless ( length( $recref->{_password} ) ) {
1174 $recref->{_password} =
1175 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1176 $recref->{_password_encoding} = 'plain';
1180 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1181 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1182 $recref->{_password} = $1.$3;
1183 $recref->{_password_encoding} = 'plain';
1184 } elsif ( $recref->{_password} =~
1185 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1187 $recref->{_password} = $1.$3;
1188 $recref->{_password_encoding} = 'crypt';
1189 } elsif ( $recref->{_password} eq '*' ) {
1190 $recref->{_password} = '*';
1191 $recref->{_password_encoding} = 'crypt';
1192 } elsif ( $recref->{_password} eq '!' ) {
1193 $recref->{_password_encoding} = 'crypt';
1194 $recref->{_password} = '!';
1195 } elsif ( $recref->{_password} eq '!!' ) {
1196 $recref->{_password} = '!!';
1197 $recref->{_password_encoding} = 'crypt';
1199 #return "Illegal password";
1200 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1201 FS::Msgcat::_gettext('illegal_password_characters').
1202 ": ". $recref->{_password};
1209 $self->SUPER::check;
1215 Internal function to check the username against the list of system usernames
1216 from the I<system_usernames> configuration value. Returns true if the username
1217 is listed on the system username list.
1223 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1224 $conf->config('system_usernames')
1228 =item _check_duplicate
1230 Internal function to check for duplicates usernames, username@domain pairs and
1233 If the I<global_unique-username> configuration value is set to B<username> or
1234 B<username@domain>, enforces global username or username@domain uniqueness.
1236 In all cases, check for duplicate uids and usernames or username@domain pairs
1237 per export and with identical I<svcpart> values.
1241 sub _check_duplicate {
1244 my $global_unique = $conf->config('global_unique-username') || 'none';
1245 return '' if $global_unique eq 'disabled';
1247 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1248 if ( driver_name =~ /^Pg/i ) {
1249 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1251 } elsif ( driver_name =~ /^mysql/i ) {
1252 dbh->do("SELECT * FROM duplicate_lock
1253 WHERE lockname = 'svc_acct'
1255 ) or die dbh->errstr;
1257 die "unknown database ". driver_name.
1258 "; don't know how to lock for duplicate search";
1260 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1262 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1263 unless ( $part_svc ) {
1264 return 'unknown svcpart '. $self->svcpart;
1267 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1268 qsearch( 'svc_acct', { 'username' => $self->username } );
1269 return gettext('username_in_use')
1270 if $global_unique eq 'username' && @dup_user;
1272 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1273 qsearch( 'svc_acct', { 'username' => $self->username,
1274 'domsvc' => $self->domsvc } );
1275 return gettext('username_in_use')
1276 if $global_unique eq 'username@domain' && @dup_userdomain;
1279 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1280 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1281 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1282 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1287 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1288 my $exports = FS::part_export::export_info('svc_acct');
1289 my %conflict_user_svcpart;
1290 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1292 foreach my $part_export ( $part_svc->part_export ) {
1294 #this will catch to the same exact export
1295 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1297 #this will catch to exports w/same exporthost+type ???
1298 #my @other_part_export = qsearch('part_export', {
1299 # 'machine' => $part_export->machine,
1300 # 'exporttype' => $part_export->exporttype,
1302 #foreach my $other_part_export ( @other_part_export ) {
1303 # push @svcparts, map { $_->svcpart }
1304 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1307 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1308 #silly kludge to avoid uninitialized value errors
1309 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1310 ? $exports->{$part_export->exporttype}{'nodomain'}
1312 if ( $nodomain =~ /^Y/i ) {
1313 $conflict_user_svcpart{$_} = $part_export->exportnum
1316 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1321 foreach my $dup_user ( @dup_user ) {
1322 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1323 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1324 return "duplicate username ". $self->username.
1325 ": conflicts with svcnum ". $dup_user->svcnum.
1326 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1330 foreach my $dup_userdomain ( @dup_userdomain ) {
1331 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1332 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1333 return "duplicate username\@domain ". $self->email.
1334 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1335 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1339 foreach my $dup_uid ( @dup_uid ) {
1340 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1341 if ( exists($conflict_user_svcpart{$dup_svcpart})
1342 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1343 return "duplicate uid ". $self->uid.
1344 ": conflicts with svcnum ". $dup_uid->svcnum.
1346 ( $conflict_user_svcpart{$dup_svcpart}
1347 || $conflict_userdomain_svcpart{$dup_svcpart} );
1359 Depriciated, use radius_reply instead.
1364 carp "FS::svc_acct::radius depriciated, use radius_reply";
1365 $_[0]->radius_reply;
1370 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1371 reply attributes of this record.
1373 Note that this is now the preferred method for reading RADIUS attributes -
1374 accessing the columns directly is discouraged, as the column names are
1375 expected to change in the future.
1382 return %{ $self->{'radius_reply'} }
1383 if exists $self->{'radius_reply'};
1388 my($column, $attrib) = ($1, $2);
1389 #$attrib =~ s/_/\-/g;
1390 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1391 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1393 if ( $self->slipip && $self->slipip ne '0e0' ) {
1394 $reply{$radius_ip} = $self->slipip;
1397 if ( $self->seconds !~ /^$/ ) {
1398 $reply{'Session-Timeout'} = $self->seconds;
1406 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1407 check attributes of this record.
1409 Note that this is now the preferred method for reading RADIUS attributes -
1410 accessing the columns directly is discouraged, as the column names are
1411 expected to change in the future.
1418 return %{ $self->{'radius_check'} }
1419 if exists $self->{'radius_check'};
1424 my($column, $attrib) = ($1, $2);
1425 #$attrib =~ s/_/\-/g;
1426 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1427 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1430 my($pw_attrib, $password) = $self->radius_password;
1431 $check{$pw_attrib} = $password;
1433 my $cust_svc = $self->cust_svc;
1434 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1436 my $cust_pkg = $cust_svc->cust_pkg;
1437 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1438 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1445 =item radius_password
1447 Returns a key/value pair containing the RADIUS attribute name and value
1452 sub radius_password {
1455 my($pw_attrib, $password);
1456 if ( $self->_password_encoding eq 'ldap' ) {
1458 $pw_attrib = 'Password-With-Header';
1459 $password = $self->_password;
1461 } elsif ( $self->_password_encoding eq 'crypt' ) {
1463 $pw_attrib = 'Crypt-Password';
1464 $password = $self->_password;
1466 } elsif ( $self->_password_encoding eq 'plain' ) {
1468 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1469 $password = $self->_password;
1473 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1474 $password = $self->_password;
1478 ($pw_attrib, $password);
1484 This method instructs the object to "snapshot" or freeze RADIUS check and
1485 reply attributes to the current values.
1489 #bah, my english is too broken this morning
1490 #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
1491 #the FS::cust_pkg's replace method to trigger the correct export updates when
1492 #package dates change)
1497 $self->{$_} = { $self->$_() }
1498 foreach qw( radius_reply radius_check );
1502 =item forget_snapshot
1504 This methos instructs the object to forget any previously snapshotted
1505 RADIUS check and reply attributes.
1509 sub forget_snapshot {
1513 foreach qw( radius_reply radius_check );
1517 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1519 Returns the domain associated with this account.
1521 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1528 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1529 my $svc_domain = $self->svc_domain(@_)
1530 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1531 $svc_domain->domain;
1536 Returns the FS::svc_domain record for this account's domain (see
1541 # FS::h_svc_acct has a history-aware svc_domain override
1546 ? $self->{'_domsvc'}
1547 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1552 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1556 #inherited from svc_Common
1558 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1560 Returns an email address associated with the account.
1562 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1569 $self->username. '@'. $self->domain(@_);
1574 Returns an array of FS::acct_snarf records associated with the account.
1575 If the acct_snarf table does not exist or there are no associated records,
1576 an empty list is returned
1582 return () unless dbdef->table('acct_snarf');
1583 eval "use FS::acct_snarf;";
1585 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1588 =item decrement_upbytes OCTETS
1590 Decrements the I<upbytes> field of this record by the given amount. If there
1591 is an error, returns the error, otherwise returns false.
1595 sub decrement_upbytes {
1596 shift->_op_usage('-', 'upbytes', @_);
1599 =item increment_upbytes OCTETS
1601 Increments the I<upbytes> field of this record by the given amount. If there
1602 is an error, returns the error, otherwise returns false.
1606 sub increment_upbytes {
1607 shift->_op_usage('+', 'upbytes', @_);
1610 =item decrement_downbytes OCTETS
1612 Decrements the I<downbytes> field of this record by the given amount. If there
1613 is an error, returns the error, otherwise returns false.
1617 sub decrement_downbytes {
1618 shift->_op_usage('-', 'downbytes', @_);
1621 =item increment_downbytes OCTETS
1623 Increments the I<downbytes> field of this record by the given amount. If there
1624 is an error, returns the error, otherwise returns false.
1628 sub increment_downbytes {
1629 shift->_op_usage('+', 'downbytes', @_);
1632 =item decrement_totalbytes OCTETS
1634 Decrements the I<totalbytes> field of this record by the given amount. If there
1635 is an error, returns the error, otherwise returns false.
1639 sub decrement_totalbytes {
1640 shift->_op_usage('-', 'totalbytes', @_);
1643 =item increment_totalbytes OCTETS
1645 Increments the I<totalbytes> field of this record by the given amount. If there
1646 is an error, returns the error, otherwise returns false.
1650 sub increment_totalbytes {
1651 shift->_op_usage('+', 'totalbytes', @_);
1654 =item decrement_seconds SECONDS
1656 Decrements the I<seconds> field of this record by the given amount. If there
1657 is an error, returns the error, otherwise returns false.
1661 sub decrement_seconds {
1662 shift->_op_usage('-', 'seconds', @_);
1665 =item increment_seconds SECONDS
1667 Increments the I<seconds> field of this record by the given amount. If there
1668 is an error, returns the error, otherwise returns false.
1672 sub increment_seconds {
1673 shift->_op_usage('+', 'seconds', @_);
1681 my %op2condition = (
1682 '-' => sub { my($self, $column, $amount) = @_;
1683 $self->$column - $amount <= 0;
1685 '+' => sub { my($self, $column, $amount) = @_;
1686 $self->$column + $amount > 0;
1689 my %op2warncondition = (
1690 '-' => sub { my($self, $column, $amount) = @_;
1691 my $threshold = $column . '_threshold';
1692 $self->$column - $amount <= $self->$threshold + 0;
1694 '+' => sub { my($self, $column, $amount) = @_;
1695 $self->$column + $amount > 0;
1700 my( $self, $op, $column, $amount ) = @_;
1702 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1703 ' ('. $self->email. "): $op $amount\n"
1706 return '' unless $amount;
1708 local $SIG{HUP} = 'IGNORE';
1709 local $SIG{INT} = 'IGNORE';
1710 local $SIG{QUIT} = 'IGNORE';
1711 local $SIG{TERM} = 'IGNORE';
1712 local $SIG{TSTP} = 'IGNORE';
1713 local $SIG{PIPE} = 'IGNORE';
1715 my $oldAutoCommit = $FS::UID::AutoCommit;
1716 local $FS::UID::AutoCommit = 0;
1719 my $sql = "UPDATE svc_acct SET $column = ".
1720 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1721 " $op ? WHERE svcnum = ?";
1725 my $sth = $dbh->prepare( $sql )
1726 or die "Error preparing $sql: ". $dbh->errstr;
1727 my $rv = $sth->execute($amount, $self->svcnum);
1728 die "Error executing $sql: ". $sth->errstr
1729 unless defined($rv);
1730 die "Can't update $column for svcnum". $self->svcnum
1733 my $action = $op2action{$op};
1735 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1736 ( $action eq 'suspend' && !$self->overlimit
1737 || $action eq 'unsuspend' && $self->overlimit )
1739 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1740 if ($part_export->option('overlimit_groups')) {
1742 my $other = new FS::svc_acct $self->hashref;
1743 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1744 ($self, $part_export->option('overlimit_groups'));
1745 $other->usergroup( $groups );
1746 if ($action eq 'suspend'){
1747 $new = $other; $old = $self;
1749 $new = $self; $old = $other;
1751 my $error = $part_export->export_replace($new, $old);
1752 $error ||= $self->overlimit($action);
1754 $dbh->rollback if $oldAutoCommit;
1755 return "Error replacing radius groups in export, ${op}: $error";
1761 if ( $conf->exists("svc_acct-usage_$action")
1762 && &{$op2condition{$op}}($self, $column, $amount) ) {
1763 #my $error = $self->$action();
1764 my $error = $self->cust_svc->cust_pkg->$action();
1765 # $error ||= $self->overlimit($action);
1767 $dbh->rollback if $oldAutoCommit;
1768 return "Error ${action}ing: $error";
1772 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1773 my $wqueue = new FS::queue {
1774 'svcnum' => $self->svcnum,
1775 'job' => 'FS::svc_acct::reached_threshold',
1780 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1784 my $error = $wqueue->insert(
1785 'svcnum' => $self->svcnum,
1787 'column' => $column,
1791 $dbh->rollback if $oldAutoCommit;
1792 return "Error queuing threshold activity: $error";
1796 warn "$me update successful; committing\n"
1798 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1804 my( $self, $valueref ) = @_;
1806 warn "$me set_usage called for svcnum ". $self->svcnum.
1807 ' ('. $self->email. "): ".
1808 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1811 local $SIG{HUP} = 'IGNORE';
1812 local $SIG{INT} = 'IGNORE';
1813 local $SIG{QUIT} = 'IGNORE';
1814 local $SIG{TERM} = 'IGNORE';
1815 local $SIG{TSTP} = 'IGNORE';
1816 local $SIG{PIPE} = 'IGNORE';
1818 local $FS::svc_Common::noexport_hack = 1;
1819 my $oldAutoCommit = $FS::UID::AutoCommit;
1820 local $FS::UID::AutoCommit = 0;
1825 foreach my $field (keys %$valueref){
1826 $reset = 1 if $valueref->{$field};
1827 $self->setfield($field, $valueref->{$field});
1828 $self->setfield( $field.'_threshold',
1829 int($self->getfield($field)
1830 * ( $conf->exists('svc_acct-usage_threshold')
1831 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1836 $handyhash{$field} = $self->getfield($field);
1837 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1839 #my $error = $self->replace; #NO! we avoid the call to ->check for
1840 #die $error if $error; #services not explicity changed via the UI
1842 my $sql = "UPDATE svc_acct SET " .
1843 join (',', map { "$_ = ?" } (keys %handyhash) ).
1844 " WHERE svcnum = ?";
1849 if (scalar(keys %handyhash)) {
1850 my $sth = $dbh->prepare( $sql )
1851 or die "Error preparing $sql: ". $dbh->errstr;
1852 my $rv = $sth->execute((values %handyhash), $self->svcnum);
1853 die "Error executing $sql: ". $sth->errstr
1854 unless defined($rv);
1855 die "Can't update usage for svcnum ". $self->svcnum
1862 if ($self->overlimit) {
1863 $error = $self->overlimit('unsuspend');
1864 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1865 if ($part_export->option('overlimit_groups')) {
1866 my $old = new FS::svc_acct $self->hashref;
1867 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1868 ($self, $part_export->option('overlimit_groups'));
1869 $old->usergroup( $groups );
1870 $error ||= $part_export->export_replace($self, $old);
1875 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1876 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1879 $dbh->rollback if $oldAutoCommit;
1880 return "Error unsuspending: $error";
1884 warn "$me update successful; committing\n"
1886 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1892 =item recharge HASHREF
1894 Increments usage columns by the amount specified in HASHREF as
1895 column=>amount pairs.
1900 my ($self, $vhash) = @_;
1903 warn "[$me] recharge called on $self: ". Dumper($self).
1904 "\nwith vhash: ". Dumper($vhash);
1907 my $oldAutoCommit = $FS::UID::AutoCommit;
1908 local $FS::UID::AutoCommit = 0;
1912 foreach my $column (keys %$vhash){
1913 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1917 $dbh->rollback if $oldAutoCommit;
1919 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1924 =item is_rechargeable
1926 Returns true if this svc_account can be "recharged" and false otherwise.
1930 sub is_rechargable {
1932 $self->seconds ne ''
1933 || $self->upbytes ne ''
1934 || $self->downbytes ne ''
1935 || $self->totalbytes ne '';
1938 =item seconds_since TIMESTAMP
1940 Returns the number of seconds this account has been online since TIMESTAMP,
1941 according to the session monitor (see L<FS::Session>).
1943 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1944 L<Time::Local> and L<Date::Parse> for conversion functions.
1948 #note: POD here, implementation in FS::cust_svc
1951 $self->cust_svc->seconds_since(@_);
1954 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1956 Returns the numbers of seconds this account has been online between
1957 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1958 external SQL radacct table, specified via sqlradius export. Sessions which
1959 started in the specified range but are still open are counted from session
1960 start to the end of the range (unless they are over 1 day old, in which case
1961 they are presumed missing their stop record and not counted). Also, sessions
1962 which end in the range but started earlier are counted from the start of the
1963 range to session end. Finally, sessions which start before the range but end
1964 after are counted for the entire range.
1966 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1967 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1972 #note: POD here, implementation in FS::cust_svc
1973 sub seconds_since_sqlradacct {
1975 $self->cust_svc->seconds_since_sqlradacct(@_);
1978 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1980 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1981 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1982 TIMESTAMP_END (exclusive).
1984 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1985 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1990 #note: POD here, implementation in FS::cust_svc
1991 sub attribute_since_sqlradacct {
1993 $self->cust_svc->attribute_since_sqlradacct(@_);
1996 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1998 Returns an array of hash references of this customers login history for the
1999 given time range. (document this better)
2003 sub get_session_history {
2005 $self->cust_svc->get_session_history(@_);
2008 =item last_login_text
2010 Returns text describing the time of last login.
2014 sub last_login_text {
2016 $self->last_login ? ctime($self->last_login) : 'unknown';
2019 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2024 my($self, $start, $end, %opt ) = @_;
2026 my $did = $self->username; #yup
2028 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2030 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2032 #SELECT $for_update * FROM cdr
2033 # WHERE calldate >= $start #need a conversion
2034 # AND calldate < $end #ditto
2035 # AND ( charged_party = "$did"
2036 # OR charged_party = "$prefix$did" #if length($prefix);
2037 # OR ( ( charged_party IS NULL OR charged_party = '' )
2039 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2042 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2045 if ( length($prefix) ) {
2047 " AND ( charged_party = '$did'
2048 OR charged_party = '$prefix$did'
2049 OR ( ( charged_party IS NULL OR charged_party = '' )
2051 ( src = '$did' OR src = '$prefix$did' )
2057 " AND ( charged_party = '$did'
2058 OR ( ( charged_party IS NULL OR charged_party = '' )
2068 'select' => "$for_update *",
2071 #( freesidestatus IS NULL OR freesidestatus = '' )
2072 'freesidestatus' => '',
2074 'extra_sql' => $charged_or_src,
2082 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2088 if ( $self->usergroup ) {
2089 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2090 unless ref($self->usergroup) eq 'ARRAY';
2091 #when provisioning records, export callback runs in svc_Common.pm before
2092 #radius_usergroup records can be inserted...
2093 @{$self->usergroup};
2095 map { $_->groupname }
2096 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2100 =item clone_suspended
2102 Constructor used by FS::part_export::_export_suspend fallback. Document
2107 sub clone_suspended {
2109 my %hash = $self->hash;
2110 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2111 new FS::svc_acct \%hash;
2114 =item clone_kludge_unsuspend
2116 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2121 sub clone_kludge_unsuspend {
2123 my %hash = $self->hash;
2124 $hash{_password} = '';
2125 new FS::svc_acct \%hash;
2128 =item check_password
2130 Checks the supplied password against the (possibly encrypted) password in the
2131 database. Returns true for a successful authentication, false for no match.
2133 Currently supported encryptions are: classic DES crypt() and MD5
2137 sub check_password {
2138 my($self, $check_password) = @_;
2140 #remove old-style SUSPENDED kludge, they should be allowed to login to
2141 #self-service and pay up
2142 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2144 if ( $self->_password_encoding eq 'ldap' ) {
2146 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2147 return $auth->match($check_password);
2149 } elsif ( $self->_password_encoding eq 'crypt' ) {
2151 my $auth = from_crypt Authen::Passphrase $self->_password;
2152 return $auth->match($check_password);
2154 } elsif ( $self->_password_encoding eq 'plain' ) {
2156 return $check_password eq $password;
2160 #XXX this could be replaced with Authen::Passphrase stuff
2162 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2164 } elsif ( length($password) < 13 ) { #plaintext
2165 $check_password eq $password;
2166 } elsif ( length($password) == 13 ) { #traditional DES crypt
2167 crypt($check_password, $password) eq $password;
2168 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2169 unix_md5_crypt($check_password, $password) eq $password;
2170 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2171 warn "Can't check password: Blowfish encryption not yet supported, ".
2172 "svcnum ". $self->svcnum. "\n";
2175 warn "Can't check password: Unrecognized encryption for svcnum ".
2176 $self->svcnum. "\n";
2184 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2186 Returns an encrypted password, either by passing through an encrypted password
2187 in the database or by encrypting a plaintext password from the database.
2189 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2190 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2191 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2192 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2193 encryption type is only used if the password is not already encrypted in the
2198 sub crypt_password {
2201 if ( $self->_password_encoding eq 'ldap' ) {
2203 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2206 #XXX this could be replaced with Authen::Passphrase stuff
2208 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2209 if ( $encryption eq 'crypt' ) {
2212 $saltset[int(rand(64))].$saltset[int(rand(64))]
2214 } elsif ( $encryption eq 'md5' ) {
2215 unix_md5_crypt( $self->_password );
2216 } elsif ( $encryption eq 'blowfish' ) {
2217 croak "unknown encryption method $encryption";
2219 croak "unknown encryption method $encryption";
2222 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2226 } elsif ( $self->_password_encoding eq 'crypt' ) {
2228 return $self->_password;
2230 } elsif ( $self->_password_encoding eq 'plain' ) {
2232 #XXX this could be replaced with Authen::Passphrase stuff
2234 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2235 if ( $encryption eq 'crypt' ) {
2238 $saltset[int(rand(64))].$saltset[int(rand(64))]
2240 } elsif ( $encryption eq 'md5' ) {
2241 unix_md5_crypt( $self->_password );
2242 } elsif ( $encryption eq 'blowfish' ) {
2243 croak "unknown encryption method $encryption";
2245 croak "unknown encryption method $encryption";
2250 if ( length($self->_password) == 13
2251 || $self->_password =~ /^\$(1|2a?)\$/
2252 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2258 #XXX this could be replaced with Authen::Passphrase stuff
2260 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2261 if ( $encryption eq 'crypt' ) {
2264 $saltset[int(rand(64))].$saltset[int(rand(64))]
2266 } elsif ( $encryption eq 'md5' ) {
2267 unix_md5_crypt( $self->_password );
2268 } elsif ( $encryption eq 'blowfish' ) {
2269 croak "unknown encryption method $encryption";
2271 croak "unknown encryption method $encryption";
2280 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2282 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2283 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2284 "{MD5}5426824942db4253f87a1009fd5d2d4".
2286 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2287 to work the same as the B</crypt_password> method.
2293 #eventually should check a "password-encoding" field
2295 if ( $self->_password_encoding eq 'ldap' ) {
2297 return $self->_password;
2299 } elsif ( $self->_password_encoding eq 'crypt' ) {
2301 if ( length($self->_password) == 13 ) { #crypt
2302 return '{CRYPT}'. $self->_password;
2303 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2305 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2306 # die "Blowfish encryption not supported in this context, svcnum ".
2307 # $self->svcnum. "\n";
2309 warn "encryption method not (yet?) supported in LDAP context";
2310 return '{CRYPT}*'; #unsupported, should not auth
2313 } elsif ( $self->_password_encoding eq 'plain' ) {
2315 return '{PLAIN}'. $self->_password;
2317 #return '{CLEARTEXT}'. $self->_password; #?
2321 if ( length($self->_password) == 13 ) { #crypt
2322 return '{CRYPT}'. $self->_password;
2323 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2325 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2326 warn "Blowfish encryption not supported in this context, svcnum ".
2327 $self->svcnum. "\n";
2330 #are these two necessary anymore?
2331 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2332 return '{SSHA}'. $1;
2333 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2334 return '{NS-MTA-MD5}'. $1;
2337 return '{PLAIN}'. $self->_password;
2339 #return '{CLEARTEXT}'. $self->_password; #?
2341 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2342 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2343 #if ( $encryption eq 'crypt' ) {
2344 # return '{CRYPT}'. crypt(
2346 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2348 #} elsif ( $encryption eq 'md5' ) {
2349 # unix_md5_crypt( $self->_password );
2350 #} elsif ( $encryption eq 'blowfish' ) {
2351 # croak "unknown encryption method $encryption";
2353 # croak "unknown encryption method $encryption";
2361 =item domain_slash_username
2363 Returns $domain/$username/
2367 sub domain_slash_username {
2369 $self->domain. '/'. $self->username. '/';
2372 =item virtual_maildir
2374 Returns $domain/maildirs/$username/
2378 sub virtual_maildir {
2380 $self->domain. '/maildirs/'. $self->username. '/';
2391 This is the FS::svc_acct job-queue-able version. It still uses
2392 FS::Misc::send_email under-the-hood.
2399 eval "use FS::Misc qw(send_email)";
2402 $opt{mimetype} ||= 'text/plain';
2403 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2405 my $error = send_email(
2406 'from' => $opt{from},
2408 'subject' => $opt{subject},
2409 'content-type' => $opt{mimetype},
2410 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2412 die $error if $error;
2415 =item check_and_rebuild_fuzzyfiles
2419 sub check_and_rebuild_fuzzyfiles {
2420 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2421 -e "$dir/svc_acct.username"
2422 or &rebuild_fuzzyfiles;
2425 =item rebuild_fuzzyfiles
2429 sub rebuild_fuzzyfiles {
2431 use Fcntl qw(:flock);
2433 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2437 open(USERNAMELOCK,">>$dir/svc_acct.username")
2438 or die "can't open $dir/svc_acct.username: $!";
2439 flock(USERNAMELOCK,LOCK_EX)
2440 or die "can't lock $dir/svc_acct.username: $!";
2442 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2444 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2445 or die "can't open $dir/svc_acct.username.tmp: $!";
2446 print USERNAMECACHE join("\n", @all_username), "\n";
2447 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2449 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2459 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2460 open(USERNAMECACHE,"<$dir/svc_acct.username")
2461 or die "can't open $dir/svc_acct.username: $!";
2462 my @array = map { chomp; $_; } <USERNAMECACHE>;
2463 close USERNAMECACHE;
2467 =item append_fuzzyfiles USERNAME
2471 sub append_fuzzyfiles {
2472 my $username = shift;
2474 &check_and_rebuild_fuzzyfiles;
2476 use Fcntl qw(:flock);
2478 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2480 open(USERNAME,">>$dir/svc_acct.username")
2481 or die "can't open $dir/svc_acct.username: $!";
2482 flock(USERNAME,LOCK_EX)
2483 or die "can't lock $dir/svc_acct.username: $!";
2485 print USERNAME "$username\n";
2487 flock(USERNAME,LOCK_UN)
2488 or die "can't unlock $dir/svc_acct.username: $!";
2496 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2500 sub radius_usergroup_selector {
2501 my $sel_groups = shift;
2502 my %sel_groups = map { $_=>1 } @$sel_groups;
2504 my $selectname = shift || 'radius_usergroup';
2507 my $sth = $dbh->prepare(
2508 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2509 ) or die $dbh->errstr;
2510 $sth->execute() or die $sth->errstr;
2511 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2515 function ${selectname}_doadd(object) {
2516 var myvalue = object.${selectname}_add.value;
2517 var optionName = new Option(myvalue,myvalue,false,true);
2518 var length = object.$selectname.length;
2519 object.$selectname.options[length] = optionName;
2520 object.${selectname}_add.value = "";
2523 <SELECT MULTIPLE NAME="$selectname">
2526 foreach my $group ( @all_groups ) {
2527 $html .= qq(<OPTION VALUE="$group");
2528 if ( $sel_groups{$group} ) {
2529 $html .= ' SELECTED';
2530 $sel_groups{$group} = 0;
2532 $html .= ">$group</OPTION>\n";
2534 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2535 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2537 $html .= '</SELECT>';
2539 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2540 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2545 =item reached_threshold
2547 Performs some activities when svc_acct thresholds (such as number of seconds
2548 remaining) are reached.
2552 sub reached_threshold {
2555 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2556 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2558 if ( $opt{'op'} eq '+' ){
2559 $svc_acct->setfield( $opt{'column'}.'_threshold',
2560 int($svc_acct->getfield($opt{'column'})
2561 * ( $conf->exists('svc_acct-usage_threshold')
2562 ? $conf->config('svc_acct-usage_threshold')/100
2567 my $error = $svc_acct->replace;
2568 die $error if $error;
2569 }elsif ( $opt{'op'} eq '-' ){
2571 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2572 return '' if ($threshold eq '' );
2574 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2575 my $error = $svc_acct->replace;
2576 die $error if $error; # email next time, i guess
2578 if ( $warning_template ) {
2579 eval "use FS::Misc qw(send_email)";
2582 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2583 my $cust_main = $cust_pkg->cust_main;
2585 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2586 $cust_main->invoicing_list,
2587 ($opt{'to'} ? $opt{'to'} : ())
2590 my $mimetype = $warning_mimetype;
2591 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2593 my $body = $warning_template->fill_in( HASH => {
2594 'custnum' => $cust_main->custnum,
2595 'username' => $svc_acct->username,
2596 'password' => $svc_acct->_password,
2597 'first' => $cust_main->first,
2598 'last' => $cust_main->getfield('last'),
2599 'pkg' => $cust_pkg->part_pkg->pkg,
2600 'column' => $opt{'column'},
2601 'amount' => $opt{'column'} =~/bytes/
2602 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2603 : $svc_acct->getfield($opt{'column'}),
2604 'threshold' => $opt{'column'} =~/bytes/
2605 ? FS::UI::bytecount::display_bytecount($threshold)
2610 my $error = send_email(
2611 'from' => $warning_from,
2613 'subject' => $warning_subject,
2614 'content-type' => $mimetype,
2615 'body' => [ map "$_\n", split("\n", $body) ],
2617 die $error if $error;
2620 die "unknown op: " . $opt{'op'};
2628 The $recref stuff in sub check should be cleaned up.
2630 The suspend, unsuspend and cancel methods update the database, but not the
2631 current object. This is probably a bug as it's unexpected and
2634 radius_usergroup_selector? putting web ui components in here? they should
2635 probably live somewhere else...
2637 insertion of RADIUS group stuff in insert could be done with child_objects now
2638 (would probably clean up export of them too)
2642 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2643 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2644 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2645 L<freeside-queued>), L<FS::svc_acct_pop>,
2646 schema.html from the base documentation.
2650 =item domain_select_hash %OPTIONS
2652 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2653 may at present purchase.
2655 Currently available options are: I<pkgnum> I<svcpart>
2659 sub domain_select_hash {
2660 my ($self, %options) = @_;
2666 $part_svc = $self->part_svc;
2667 $cust_pkg = $self->cust_svc->cust_pkg
2671 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2672 if $options{'svcpart'};
2674 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2675 if $options{'pkgnum'};
2677 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2678 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2679 %domains = map { $_->svcnum => $_->domain }
2680 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2681 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2682 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2683 %domains = map { $_->svcnum => $_->domain }
2684 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2685 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2686 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2688 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2691 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2692 my $svc_domain = qsearchs('svc_domain',
2693 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2694 if ( $svc_domain ) {
2695 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2697 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2698 $part_svc->part_svc_column('domsvc')->columnvalue;