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 $username_colon
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;
24 use Authen::Passphrase;
25 use FS::UID qw( datasrc driver_name );
27 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
28 use FS::Msgcat qw(gettext);
29 use FS::UI::bytecount;
35 use FS::cust_main_invoice;
39 use FS::radius_usergroup;
46 @ISA = qw( FS::svc_Common );
49 $me = '[FS::svc_acct]';
51 #ask FS::UID to run this stuff for us later
52 FS::UID->install_callback( sub {
54 $dir_prefix = $conf->config('home');
55 @shells = $conf->config('shells');
56 $usernamemin = $conf->config('usernamemin') || 2;
57 $usernamemax = $conf->config('usernamemax');
58 $passwordmin = $conf->config('passwordmin') || 6;
59 $passwordmax = $conf->config('passwordmax') || 8;
60 $username_letter = $conf->exists('username-letter');
61 $username_letterfirst = $conf->exists('username-letterfirst');
62 $username_noperiod = $conf->exists('username-noperiod');
63 $username_nounderscore = $conf->exists('username-nounderscore');
64 $username_nodash = $conf->exists('username-nodash');
65 $username_uppercase = $conf->exists('username-uppercase');
66 $username_ampersand = $conf->exists('username-ampersand');
67 $username_percent = $conf->exists('username-percent');
68 $username_colon = $conf->exists('username-colon');
69 $password_noampersand = $conf->exists('password-noexclamation');
70 $password_noexclamation = $conf->exists('password-noexclamation');
71 $dirhash = $conf->config('dirhash') || 0;
72 if ( $conf->exists('warning_email') ) {
73 $warning_template = new Text::Template (
75 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
76 ) or warn "can't create warning email template: $Text::Template::ERROR";
77 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
78 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
79 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
80 $warning_cc = $conf->config('warning_email-cc');
82 $warning_template = '';
84 $warning_subject = '';
85 $warning_mimetype = '';
88 $smtpmachine = $conf->config('smtpmachine');
89 $radius_password = $conf->config('radius-password') || 'Password';
90 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
91 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
95 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
96 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
100 my ( $hashref, $cache ) = @_;
101 if ( $hashref->{'svc_acct_svcnum'} ) {
102 $self->{'_domsvc'} = FS::svc_domain->new( {
103 'svcnum' => $hashref->{'domsvc'},
104 'domain' => $hashref->{'svc_acct_domain'},
105 'catchall' => $hashref->{'svc_acct_catchall'},
112 FS::svc_acct - Object methods for svc_acct records
118 $record = new FS::svc_acct \%hash;
119 $record = new FS::svc_acct { 'column' => 'value' };
121 $error = $record->insert;
123 $error = $new_record->replace($old_record);
125 $error = $record->delete;
127 $error = $record->check;
129 $error = $record->suspend;
131 $error = $record->unsuspend;
133 $error = $record->cancel;
135 %hash = $record->radius;
137 %hash = $record->radius_reply;
139 %hash = $record->radius_check;
141 $domain = $record->domain;
143 $svc_domain = $record->svc_domain;
145 $email = $record->email;
147 $seconds_since = $record->seconds_since($timestamp);
151 An FS::svc_acct object represents an account. FS::svc_acct inherits from
152 FS::svc_Common. The following fields are currently supported:
156 =item svcnum - primary key (assigned automatcially for new accounts)
160 =item _password - generated if blank
162 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
164 =item sec_phrase - security phrase
166 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
174 =item dir - set automatically if blank (and uid is not)
178 =item quota - (unimplementd)
180 =item slipip - IP address
190 =item domsvc - svcnum from svc_domain
192 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
194 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
204 Creates a new account. To add the account to the database, see L<"insert">.
211 'longname_plural' => 'Access accounts and mailboxes',
212 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
213 'display_weight' => 10,
214 'cancel_weight' => 50,
216 'dir' => 'Home directory',
219 def_info => 'set to fixed and blank for no UIDs',
222 'slipip' => 'IP address',
223 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
225 label => 'Access number',
227 select_table => 'svc_acct_pop',
228 select_key => 'popnum',
229 select_label => 'city',
235 disable_default => 1,
242 disable_inventory => 1,
245 '_password' => 'Password',
248 def_info => 'when blank, defaults to UID',
253 def_info => 'set to blank for no shell tracking',
255 #select_list => [ $conf->config('shells') ],
256 select_list => [ $conf ? $conf->config('shells') : () ],
257 disable_inventory => 1,
260 'finger' => 'Real name', # (GECOS)',
264 select_table => 'svc_domain',
265 select_key => 'svcnum',
266 select_label => 'domain',
267 disable_inventory => 1,
271 label => 'RADIUS groups',
272 type => 'radius_usergroup_selector',
273 disable_inventory => 1,
276 'seconds' => { label => 'Seconds',
277 label_sort => 'with Time Remaining',
279 disable_inventory => 1,
281 disable_part_svc_column => 1,
283 'upbytes' => { label => 'Upload',
285 disable_inventory => 1,
287 'format' => \&FS::UI::bytecount::display_bytecount,
288 'parse' => \&FS::UI::bytecount::parse_bytecount,
289 disable_part_svc_column => 1,
291 'downbytes' => { label => 'Download',
293 disable_inventory => 1,
295 'format' => \&FS::UI::bytecount::display_bytecount,
296 'parse' => \&FS::UI::bytecount::parse_bytecount,
297 disable_part_svc_column => 1,
299 'totalbytes'=> { label => 'Total up and download',
301 disable_inventory => 1,
303 'format' => \&FS::UI::bytecount::display_bytecount,
304 'parse' => \&FS::UI::bytecount::parse_bytecount,
305 disable_part_svc_column => 1,
307 'seconds_threshold' => { label => 'Seconds threshold',
309 disable_inventory => 1,
311 disable_part_svc_column => 1,
313 'upbytes_threshold' => { label => 'Upload threshold',
315 disable_inventory => 1,
317 'format' => \&FS::UI::bytecount::display_bytecount,
318 'parse' => \&FS::UI::bytecount::parse_bytecount,
319 disable_part_svc_column => 1,
321 'downbytes_threshold' => { label => 'Download threshold',
323 disable_inventory => 1,
325 'format' => \&FS::UI::bytecount::display_bytecount,
326 'parse' => \&FS::UI::bytecount::parse_bytecount,
327 disable_part_svc_column => 1,
329 'totalbytes_threshold'=> { label => 'Total up and download threshold',
331 disable_inventory => 1,
333 'format' => \&FS::UI::bytecount::display_bytecount,
334 'parse' => \&FS::UI::bytecount::parse_bytecount,
335 disable_part_svc_column => 1,
338 label => 'Last login',
342 label => 'Last logout',
349 sub table { 'svc_acct'; }
351 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
355 #false laziness with edit/svc_acct.cgi
357 my( $self, $groups ) = @_;
358 if ( ref($groups) eq 'ARRAY' ) {
360 } elsif ( length($groups) ) {
361 [ split(/\s*,\s*/, $groups) ];
370 shift->_lastlog('in', @_);
374 shift->_lastlog('out', @_);
378 my( $self, $op, $time ) = @_;
380 if ( defined($time) ) {
381 warn "$me last_log$op called on svcnum ". $self->svcnum.
382 ' ('. $self->email. "): $time\n"
387 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
391 my $sth = $dbh->prepare( $sql )
392 or die "Error preparing $sql: ". $dbh->errstr;
393 my $rv = $sth->execute($time, $self->svcnum);
394 die "Error executing $sql: ". $sth->errstr
396 die "Can't update last_log$op for svcnum". $self->svcnum
399 $self->{'Hash'}->{"last_log$op"} = $time;
401 $self->getfield("last_log$op");
405 =item search_sql STRING
407 Class method which returns an SQL fragment to search for the given string.
412 my( $class, $string ) = @_;
413 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
414 my( $username, $domain ) = ( $1, $2 );
415 my $q_username = dbh->quote($username);
416 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
418 "svc_acct.username = $q_username AND ( ".
419 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
424 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
426 $class->search_sql_field('slipip', $string ).
428 $class->search_sql_field('username', $string ).
431 $class->search_sql_field('username', $string);
435 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
437 Returns the "username@domain" string for this account.
439 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
449 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
451 Returns a longer string label for this acccount ("Real Name <username@domain>"
452 if available, or "username@domain").
454 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
461 my $label = $self->label(@_);
462 my $finger = $self->finger;
463 return $label unless $finger =~ /\S/;
464 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
465 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
469 =item insert [ , OPTION => VALUE ... ]
471 Adds this account to the database. If there is an error, returns the error,
472 otherwise returns false.
474 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
475 defined. An FS::cust_svc record will be created and inserted.
477 The additional field I<usergroup> can optionally be defined; if so it should
478 contain an arrayref of group names. See L<FS::radius_usergroup>.
480 The additional field I<child_objects> can optionally be defined; if so it
481 should contain an arrayref of FS::tablename objects. They will have their
482 svcnum fields set and will be inserted after this record, but before any
483 exports are run. Each element of the array can also optionally be a
484 two-element array reference containing the child object and the name of an
485 alternate field to be filled in with the newly-inserted svcnum, for example
486 C<[ $svc_forward, 'srcsvc' ]>
488 Currently available options are: I<depend_jobnum>
490 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
491 jobnums), all provisioning jobs will have a dependancy on the supplied
492 jobnum(s) (they will not run until the specific job(s) complete(s)).
494 (TODOC: L<FS::queue> and L<freeside-queued>)
496 (TODOC: new exports!)
505 warn "[$me] insert called on $self: ". Dumper($self).
506 "\nwith options: ". Dumper(%options);
509 local $SIG{HUP} = 'IGNORE';
510 local $SIG{INT} = 'IGNORE';
511 local $SIG{QUIT} = 'IGNORE';
512 local $SIG{TERM} = 'IGNORE';
513 local $SIG{TSTP} = 'IGNORE';
514 local $SIG{PIPE} = 'IGNORE';
516 my $oldAutoCommit = $FS::UID::AutoCommit;
517 local $FS::UID::AutoCommit = 0;
520 my $error = $self->check;
521 return $error if $error;
523 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
524 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
525 unless ( $cust_svc ) {
526 $dbh->rollback if $oldAutoCommit;
527 return "no cust_svc record found for svcnum ". $self->svcnum;
529 $self->pkgnum($cust_svc->pkgnum);
530 $self->svcpart($cust_svc->svcpart);
533 # set usage fields and thresholds if unset but set in a package def
534 if ( $self->pkgnum ) {
535 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
536 my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
537 if ( $part_pkg && $part_pkg->can('usage_valuehash') ) {
539 my %values = $part_pkg->usage_valuehash;
540 my $multiplier = $conf->exists('svc_acct-usage_threshold')
541 ? 1 - $conf->config('svc_acct-usage_threshold')/100
542 : 0.20; #doesn't matter
544 foreach ( keys %values ) {
545 next if $self->getfield($_);
546 $self->setfield( $_, $values{$_} );
547 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
548 if $conf->exists('svc_acct-usage_threshold');
555 $error = $self->SUPER::insert(
556 'jobnums' => \@jobnums,
557 'child_objects' => $self->child_objects,
561 $dbh->rollback if $oldAutoCommit;
565 if ( $self->usergroup ) {
566 foreach my $groupname ( @{$self->usergroup} ) {
567 my $radius_usergroup = new FS::radius_usergroup ( {
568 svcnum => $self->svcnum,
569 groupname => $groupname,
571 my $error = $radius_usergroup->insert;
573 $dbh->rollback if $oldAutoCommit;
579 unless ( $skip_fuzzyfiles ) {
580 $error = $self->queue_fuzzyfiles_update;
582 $dbh->rollback if $oldAutoCommit;
583 return "updating fuzzy search cache: $error";
587 my $cust_pkg = $self->cust_svc->cust_pkg;
590 my $cust_main = $cust_pkg->cust_main;
591 my $agentnum = $cust_main->agentnum;
593 if ( $conf->exists('emailinvoiceautoalways')
594 || $conf->exists('emailinvoiceauto')
595 && ! $cust_main->invoicing_list_emailonly
597 my @invoicing_list = $cust_main->invoicing_list;
598 push @invoicing_list, $self->email;
599 $cust_main->invoicing_list(\@invoicing_list);
603 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
604 = ('','','','','','');
606 if ( $conf->exists('welcome_email', $agentnum) ) {
607 $welcome_template = new Text::Template (
609 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
610 ) or warn "can't create welcome email template: $Text::Template::ERROR";
611 $welcome_from = $conf->config('welcome_email-from', $agentnum);
612 # || 'your-isp-is-dum'
613 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
615 $welcome_subject_template = new Text::Template (
617 SOURCE => $welcome_subject,
618 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
619 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
622 if ( $welcome_template && $cust_pkg ) {
623 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
627 'custnum' => $self->custnum,
628 'username' => $self->username,
629 'password' => $self->_password,
630 'first' => $cust_main->first,
631 'last' => $cust_main->getfield('last'),
632 'pkg' => $cust_pkg->part_pkg->pkg,
634 my $wqueue = new FS::queue {
635 'svcnum' => $self->svcnum,
636 'job' => 'FS::svc_acct::send_email'
638 my $error = $wqueue->insert(
640 'from' => $welcome_from,
641 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
642 'mimetype' => $welcome_mimetype,
643 'body' => $welcome_template->fill_in( HASH => \%hash, ),
646 $dbh->rollback if $oldAutoCommit;
647 return "error queuing welcome email: $error";
650 if ( $options{'depend_jobnum'} ) {
651 warn "$me depend_jobnum found; adding to welcome email dependancies"
653 if ( ref($options{'depend_jobnum'}) ) {
654 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
655 "to welcome email dependancies"
657 push @jobnums, @{ $options{'depend_jobnum'} };
659 warn "$me adding job $options{'depend_jobnum'} ".
660 "to welcome email dependancies"
662 push @jobnums, $options{'depend_jobnum'};
666 foreach my $jobnum ( @jobnums ) {
667 my $error = $wqueue->depend_insert($jobnum);
669 $dbh->rollback if $oldAutoCommit;
670 return "error queuing welcome email job dependancy: $error";
680 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
686 Deletes this account from the database. If there is an error, returns the
687 error, otherwise returns false.
689 The corresponding FS::cust_svc record will be deleted as well.
691 (TODOC: new exports!)
698 return "can't delete system account" if $self->_check_system;
700 return "Can't delete an account which is a (svc_forward) source!"
701 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
703 return "Can't delete an account which is a (svc_forward) destination!"
704 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
706 return "Can't delete an account with (svc_www) web service!"
707 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
709 # what about records in session ? (they should refer to history table)
711 local $SIG{HUP} = 'IGNORE';
712 local $SIG{INT} = 'IGNORE';
713 local $SIG{QUIT} = 'IGNORE';
714 local $SIG{TERM} = 'IGNORE';
715 local $SIG{TSTP} = 'IGNORE';
716 local $SIG{PIPE} = 'IGNORE';
718 my $oldAutoCommit = $FS::UID::AutoCommit;
719 local $FS::UID::AutoCommit = 0;
722 foreach my $cust_main_invoice (
723 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
725 unless ( defined($cust_main_invoice) ) {
726 warn "WARNING: something's wrong with qsearch";
729 my %hash = $cust_main_invoice->hash;
730 $hash{'dest'} = $self->email;
731 my $new = new FS::cust_main_invoice \%hash;
732 my $error = $new->replace($cust_main_invoice);
734 $dbh->rollback if $oldAutoCommit;
739 foreach my $svc_domain (
740 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
742 my %hash = new FS::svc_domain->hash;
743 $hash{'catchall'} = '';
744 my $new = new FS::svc_domain \%hash;
745 my $error = $new->replace($svc_domain);
747 $dbh->rollback if $oldAutoCommit;
752 my $error = $self->SUPER::delete;
754 $dbh->rollback if $oldAutoCommit;
758 foreach my $radius_usergroup (
759 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
761 my $error = $radius_usergroup->delete;
763 $dbh->rollback if $oldAutoCommit;
768 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
772 =item replace OLD_RECORD
774 Replaces OLD_RECORD with this one in the database. If there is an error,
775 returns the error, otherwise returns false.
777 The additional field I<usergroup> can optionally be defined; if so it should
778 contain an arrayref of group names. See L<FS::radius_usergroup>.
786 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
790 warn "$me replacing $old with $new\n" if $DEBUG;
794 return "can't modify system account" if $old->_check_system;
797 #no warnings 'numeric'; #alas, a 5.006-ism
800 foreach my $xid (qw( uid gid )) {
802 return "Can't change $xid!"
803 if ! $conf->exists("svc_acct-edit_$xid")
804 && $old->$xid() != $new->$xid()
805 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
810 #change homdir when we change username
811 $new->setfield('dir', '') if $old->username ne $new->username;
813 local $SIG{HUP} = 'IGNORE';
814 local $SIG{INT} = 'IGNORE';
815 local $SIG{QUIT} = 'IGNORE';
816 local $SIG{TERM} = 'IGNORE';
817 local $SIG{TSTP} = 'IGNORE';
818 local $SIG{PIPE} = 'IGNORE';
820 my $oldAutoCommit = $FS::UID::AutoCommit;
821 local $FS::UID::AutoCommit = 0;
824 # redundant, but so $new->usergroup gets set
825 $error = $new->check;
826 return $error if $error;
828 $old->usergroup( [ $old->radius_groups ] );
830 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
831 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
833 if ( $new->usergroup ) {
834 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
835 my @newgroups = @{$new->usergroup};
836 foreach my $oldgroup ( @{$old->usergroup} ) {
837 if ( grep { $oldgroup eq $_ } @newgroups ) {
838 @newgroups = grep { $oldgroup ne $_ } @newgroups;
841 my $radius_usergroup = qsearchs('radius_usergroup', {
842 svcnum => $old->svcnum,
843 groupname => $oldgroup,
845 my $error = $radius_usergroup->delete;
847 $dbh->rollback if $oldAutoCommit;
848 return "error deleting radius_usergroup $oldgroup: $error";
852 foreach my $newgroup ( @newgroups ) {
853 my $radius_usergroup = new FS::radius_usergroup ( {
854 svcnum => $new->svcnum,
855 groupname => $newgroup,
857 my $error = $radius_usergroup->insert;
859 $dbh->rollback if $oldAutoCommit;
860 return "error adding radius_usergroup $newgroup: $error";
866 $error = $new->SUPER::replace($old, @_);
868 $dbh->rollback if $oldAutoCommit;
869 return $error if $error;
872 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
873 $error = $new->queue_fuzzyfiles_update;
875 $dbh->rollback if $oldAutoCommit;
876 return "updating fuzzy search cache: $error";
880 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
884 =item queue_fuzzyfiles_update
886 Used by insert & replace to update the fuzzy search cache
890 sub queue_fuzzyfiles_update {
893 local $SIG{HUP} = 'IGNORE';
894 local $SIG{INT} = 'IGNORE';
895 local $SIG{QUIT} = 'IGNORE';
896 local $SIG{TERM} = 'IGNORE';
897 local $SIG{TSTP} = 'IGNORE';
898 local $SIG{PIPE} = 'IGNORE';
900 my $oldAutoCommit = $FS::UID::AutoCommit;
901 local $FS::UID::AutoCommit = 0;
904 my $queue = new FS::queue {
905 'svcnum' => $self->svcnum,
906 'job' => 'FS::svc_acct::append_fuzzyfiles'
908 my $error = $queue->insert($self->username);
910 $dbh->rollback if $oldAutoCommit;
911 return "queueing job (transaction rolled back): $error";
914 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
922 Suspends this account by calling export-specific suspend hooks. If there is
923 an error, returns the error, otherwise returns false.
925 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
931 return "can't suspend system account" if $self->_check_system;
932 $self->SUPER::suspend(@_);
937 Unsuspends this account by by calling export-specific suspend hooks. If there
938 is an error, returns the error, otherwise returns false.
940 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
946 my %hash = $self->hash;
947 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
948 $hash{_password} = $1;
949 my $new = new FS::svc_acct ( \%hash );
950 my $error = $new->replace($self);
951 return $error if $error;
954 $self->SUPER::unsuspend(@_);
959 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
961 If the B<auto_unset_catchall> configuration option is set, this method will
962 automatically remove any references to the canceled service in the catchall
963 field of svc_domain. This allows packages that contain both a svc_domain and
964 its catchall svc_acct to be canceled in one step.
969 # Only one thing to do at this level
971 foreach my $svc_domain (
972 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
973 if($conf->exists('auto_unset_catchall')) {
974 my %hash = $svc_domain->hash;
975 $hash{catchall} = '';
976 my $new = new FS::svc_domain ( \%hash );
977 my $error = $new->replace($svc_domain);
978 return $error if $error;
980 return "cannot unprovision svc_acct #".$self->svcnum.
981 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
985 $self->SUPER::cancel(@_);
991 Checks all fields to make sure this is a valid service. If there is an error,
992 returns the error, otherwise returns false. Called by the insert and replace
995 Sets any fixed values; see L<FS::part_svc>.
1002 my($recref) = $self->hashref;
1004 my $x = $self->setfixed( $self->_fieldhandlers );
1005 return $x unless ref($x);
1008 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1010 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1013 my $error = $self->ut_numbern('svcnum')
1014 #|| $self->ut_number('domsvc')
1015 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1016 || $self->ut_textn('sec_phrase')
1017 || $self->ut_snumbern('seconds')
1018 || $self->ut_snumbern('upbytes')
1019 || $self->ut_snumbern('downbytes')
1020 || $self->ut_snumbern('totalbytes')
1021 || $self->ut_enum( '_password_encoding',
1022 [ '', qw( plain crypt ldap ) ]
1025 return $error if $error;
1028 local $username_letter = $username_letter;
1029 if ($self->svcnum) {
1030 my $cust_svc = $self->cust_svc
1031 or return "no cust_svc record found for svcnum ". $self->svcnum;
1032 my $cust_pkg = $cust_svc->cust_pkg;
1034 if ($self->pkgnum) {
1035 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1039 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1042 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1043 if ( $username_uppercase ) {
1044 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1045 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1046 $recref->{username} = $1;
1048 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1049 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1050 $recref->{username} = $1;
1053 if ( $username_letterfirst ) {
1054 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1055 } elsif ( $username_letter ) {
1056 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1058 if ( $username_noperiod ) {
1059 $recref->{username} =~ /\./ and return gettext('illegal_username');
1061 if ( $username_nounderscore ) {
1062 $recref->{username} =~ /_/ and return gettext('illegal_username');
1064 if ( $username_nodash ) {
1065 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1067 unless ( $username_ampersand ) {
1068 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1070 unless ( $username_percent ) {
1071 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1073 unless ( $username_colon ) {
1074 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1077 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1078 $recref->{popnum} = $1;
1079 return "Unknown popnum" unless
1080 ! $recref->{popnum} ||
1081 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1083 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1085 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1086 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1088 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1089 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1090 #not all systems use gid=uid
1091 #you can set a fixed gid in part_svc
1093 return "Only root can have uid 0"
1094 if $recref->{uid} == 0
1095 && $recref->{username} !~ /^(root|toor|smtp)$/;
1097 unless ( $recref->{username} eq 'sync' ) {
1098 if ( grep $_ eq $recref->{shell}, @shells ) {
1099 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1101 return "Illegal shell \`". $self->shell. "\'; ".
1102 "shells configuration value contains: @shells";
1105 $recref->{shell} = '/bin/sync';
1109 $recref->{gid} ne '' ?
1110 return "Can't have gid without uid" : ( $recref->{gid}='' );
1111 #$recref->{dir} ne '' ?
1112 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1113 $recref->{shell} ne '' ?
1114 return "Can't have shell without uid" : ( $recref->{shell}='' );
1117 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1119 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1120 or return "Illegal directory: ". $recref->{dir};
1121 $recref->{dir} = $1;
1122 return "Illegal directory"
1123 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1124 return "Illegal directory"
1125 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1126 unless ( $recref->{dir} ) {
1127 $recref->{dir} = $dir_prefix . '/';
1128 if ( $dirhash > 0 ) {
1129 for my $h ( 1 .. $dirhash ) {
1130 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1132 } elsif ( $dirhash < 0 ) {
1133 for my $h ( reverse $dirhash .. -1 ) {
1134 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1137 $recref->{dir} .= $recref->{username};
1143 # $error = $self->ut_textn('finger');
1144 # return $error if $error;
1145 if ( $self->getfield('finger') eq '' ) {
1146 my $cust_pkg = $self->svcnum
1147 ? $self->cust_svc->cust_pkg
1148 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1150 my $cust_main = $cust_pkg->cust_main;
1151 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1154 $self->getfield('finger') =~
1155 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1156 or return "Illegal finger: ". $self->getfield('finger');
1157 $self->setfield('finger', $1);
1159 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1160 $recref->{quota} = $1;
1162 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1163 if ( $recref->{slipip} eq '' ) {
1164 $recref->{slipip} = '';
1165 } elsif ( $recref->{slipip} eq '0e0' ) {
1166 $recref->{slipip} = '0e0';
1168 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1169 or return "Illegal slipip: ". $self->slipip;
1170 $recref->{slipip} = $1;
1175 #arbitrary RADIUS stuff; allow ut_textn for now
1176 foreach ( grep /^radius_/, fields('svc_acct') ) {
1177 $self->ut_textn($_);
1180 if ( $recref->{_password_encoding} eq 'ldap' ) {
1182 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1183 $recref->{_password} = uc($1).$2;
1185 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1188 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1190 if ( $recref->{_password} =~
1191 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1192 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1195 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1198 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1201 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1203 #generate a password if it is blank
1204 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1205 unless length( $recref->{_password} );
1207 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1208 $recref->{_password} = $1;
1210 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1211 FS::Msgcat::_gettext('illegal_password_characters').
1212 ": ". $recref->{_password};
1215 if ( $password_noampersand ) {
1216 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1218 if ( $password_noexclamation ) {
1219 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1224 #carp "warning: _password_encoding unspecified\n";
1226 #generate a password if it is blank
1227 unless ( length( $recref->{_password} ) ) {
1229 $recref->{_password} =
1230 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1231 $recref->{_password_encoding} = 'plain';
1235 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1236 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1237 $recref->{_password} = $1.$3;
1238 $recref->{_password_encoding} = 'plain';
1239 } elsif ( $recref->{_password} =~
1240 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1242 $recref->{_password} = $1.$3;
1243 $recref->{_password_encoding} = 'crypt';
1244 } elsif ( $recref->{_password} eq '*' ) {
1245 $recref->{_password} = '*';
1246 $recref->{_password_encoding} = 'crypt';
1247 } elsif ( $recref->{_password} eq '!' ) {
1248 $recref->{_password_encoding} = 'crypt';
1249 $recref->{_password} = '!';
1250 } elsif ( $recref->{_password} eq '!!' ) {
1251 $recref->{_password} = '!!';
1252 $recref->{_password_encoding} = 'crypt';
1254 #return "Illegal password";
1255 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1256 FS::Msgcat::_gettext('illegal_password_characters').
1257 ": ". $recref->{_password};
1264 $self->SUPER::check;
1270 Internal function to check the username against the list of system usernames
1271 from the I<system_usernames> configuration value. Returns true if the username
1272 is listed on the system username list.
1278 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1279 $conf->config('system_usernames')
1283 =item _check_duplicate
1285 Internal method to check for duplicates usernames, username@domain pairs and
1288 If the I<global_unique-username> configuration value is set to B<username> or
1289 B<username@domain>, enforces global username or username@domain uniqueness.
1291 In all cases, check for duplicate uids and usernames or username@domain pairs
1292 per export and with identical I<svcpart> values.
1296 sub _check_duplicate {
1299 my $global_unique = $conf->config('global_unique-username') || 'none';
1300 return '' if $global_unique eq 'disabled';
1304 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1305 unless ( $part_svc ) {
1306 return 'unknown svcpart '. $self->svcpart;
1309 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1310 qsearch( 'svc_acct', { 'username' => $self->username } );
1311 return gettext('username_in_use')
1312 if $global_unique eq 'username' && @dup_user;
1314 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1315 qsearch( 'svc_acct', { 'username' => $self->username,
1316 'domsvc' => $self->domsvc } );
1317 return gettext('username_in_use')
1318 if $global_unique eq 'username@domain' && @dup_userdomain;
1321 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1322 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1323 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1324 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1329 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1330 my $exports = FS::part_export::export_info('svc_acct');
1331 my %conflict_user_svcpart;
1332 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1334 foreach my $part_export ( $part_svc->part_export ) {
1336 #this will catch to the same exact export
1337 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1339 #this will catch to exports w/same exporthost+type ???
1340 #my @other_part_export = qsearch('part_export', {
1341 # 'machine' => $part_export->machine,
1342 # 'exporttype' => $part_export->exporttype,
1344 #foreach my $other_part_export ( @other_part_export ) {
1345 # push @svcparts, map { $_->svcpart }
1346 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1349 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1350 #silly kludge to avoid uninitialized value errors
1351 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1352 ? $exports->{$part_export->exporttype}{'nodomain'}
1354 if ( $nodomain =~ /^Y/i ) {
1355 $conflict_user_svcpart{$_} = $part_export->exportnum
1358 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1363 foreach my $dup_user ( @dup_user ) {
1364 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1365 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1366 return "duplicate username ". $self->username.
1367 ": conflicts with svcnum ". $dup_user->svcnum.
1368 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1372 foreach my $dup_userdomain ( @dup_userdomain ) {
1373 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1374 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1375 return "duplicate username\@domain ". $self->email.
1376 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1377 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1381 foreach my $dup_uid ( @dup_uid ) {
1382 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1383 if ( exists($conflict_user_svcpart{$dup_svcpart})
1384 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1385 return "duplicate uid ". $self->uid.
1386 ": conflicts with svcnum ". $dup_uid->svcnum.
1388 ( $conflict_user_svcpart{$dup_svcpart}
1389 || $conflict_userdomain_svcpart{$dup_svcpart} );
1401 Depriciated, use radius_reply instead.
1406 carp "FS::svc_acct::radius depriciated, use radius_reply";
1407 $_[0]->radius_reply;
1412 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1413 reply attributes of this record.
1415 Note that this is now the preferred method for reading RADIUS attributes -
1416 accessing the columns directly is discouraged, as the column names are
1417 expected to change in the future.
1424 return %{ $self->{'radius_reply'} }
1425 if exists $self->{'radius_reply'};
1430 my($column, $attrib) = ($1, $2);
1431 #$attrib =~ s/_/\-/g;
1432 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1433 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1435 if ( $self->slipip && $self->slipip ne '0e0' ) {
1436 $reply{$radius_ip} = $self->slipip;
1439 if ( $self->seconds !~ /^$/ ) {
1440 $reply{'Session-Timeout'} = $self->seconds;
1448 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1449 check attributes of this record.
1451 Note that this is now the preferred method for reading RADIUS attributes -
1452 accessing the columns directly is discouraged, as the column names are
1453 expected to change in the future.
1460 return %{ $self->{'radius_check'} }
1461 if exists $self->{'radius_check'};
1466 my($column, $attrib) = ($1, $2);
1467 #$attrib =~ s/_/\-/g;
1468 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1469 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1472 my($pw_attrib, $password) = $self->radius_password;
1473 $check{$pw_attrib} = $password;
1475 my $cust_svc = $self->cust_svc;
1476 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1478 my $cust_pkg = $cust_svc->cust_pkg;
1479 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1480 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1487 =item radius_password
1489 Returns a key/value pair containing the RADIUS attribute name and value
1494 sub radius_password {
1497 my($pw_attrib, $password);
1498 if ( $self->_password_encoding eq 'ldap' ) {
1500 $pw_attrib = 'Password-With-Header';
1501 $password = $self->_password;
1503 } elsif ( $self->_password_encoding eq 'crypt' ) {
1505 $pw_attrib = 'Crypt-Password';
1506 $password = $self->_password;
1508 } elsif ( $self->_password_encoding eq 'plain' ) {
1510 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1511 $password = $self->_password;
1515 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1516 $password = $self->_password;
1520 ($pw_attrib, $password);
1526 This method instructs the object to "snapshot" or freeze RADIUS check and
1527 reply attributes to the current values.
1531 #bah, my english is too broken this morning
1532 #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
1533 #the FS::cust_pkg's replace method to trigger the correct export updates when
1534 #package dates change)
1539 $self->{$_} = { $self->$_() }
1540 foreach qw( radius_reply radius_check );
1544 =item forget_snapshot
1546 This methos instructs the object to forget any previously snapshotted
1547 RADIUS check and reply attributes.
1551 sub forget_snapshot {
1555 foreach qw( radius_reply radius_check );
1559 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1561 Returns the domain associated with this account.
1563 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1570 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1571 my $svc_domain = $self->svc_domain(@_)
1572 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1573 $svc_domain->domain;
1578 Returns the FS::svc_domain record for this account's domain (see
1583 # FS::h_svc_acct has a history-aware svc_domain override
1588 ? $self->{'_domsvc'}
1589 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1594 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1598 #inherited from svc_Common
1600 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1602 Returns an email address associated with the account.
1604 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1611 $self->username. '@'. $self->domain(@_);
1616 Returns an array of FS::acct_snarf records associated with the account.
1617 If the acct_snarf table does not exist or there are no associated records,
1618 an empty list is returned
1624 return () unless dbdef->table('acct_snarf');
1625 eval "use FS::acct_snarf;";
1627 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1630 =item decrement_upbytes OCTETS
1632 Decrements the I<upbytes> field of this record by the given amount. If there
1633 is an error, returns the error, otherwise returns false.
1637 sub decrement_upbytes {
1638 shift->_op_usage('-', 'upbytes', @_);
1641 =item increment_upbytes OCTETS
1643 Increments the I<upbytes> field of this record by the given amount. If there
1644 is an error, returns the error, otherwise returns false.
1648 sub increment_upbytes {
1649 shift->_op_usage('+', 'upbytes', @_);
1652 =item decrement_downbytes OCTETS
1654 Decrements the I<downbytes> field of this record by the given amount. If there
1655 is an error, returns the error, otherwise returns false.
1659 sub decrement_downbytes {
1660 shift->_op_usage('-', 'downbytes', @_);
1663 =item increment_downbytes OCTETS
1665 Increments the I<downbytes> field of this record by the given amount. If there
1666 is an error, returns the error, otherwise returns false.
1670 sub increment_downbytes {
1671 shift->_op_usage('+', 'downbytes', @_);
1674 =item decrement_totalbytes OCTETS
1676 Decrements the I<totalbytes> field of this record by the given amount. If there
1677 is an error, returns the error, otherwise returns false.
1681 sub decrement_totalbytes {
1682 shift->_op_usage('-', 'totalbytes', @_);
1685 =item increment_totalbytes OCTETS
1687 Increments the I<totalbytes> field of this record by the given amount. If there
1688 is an error, returns the error, otherwise returns false.
1692 sub increment_totalbytes {
1693 shift->_op_usage('+', 'totalbytes', @_);
1696 =item decrement_seconds SECONDS
1698 Decrements the I<seconds> field of this record by the given amount. If there
1699 is an error, returns the error, otherwise returns false.
1703 sub decrement_seconds {
1704 shift->_op_usage('-', 'seconds', @_);
1707 =item increment_seconds SECONDS
1709 Increments the I<seconds> field of this record by the given amount. If there
1710 is an error, returns the error, otherwise returns false.
1714 sub increment_seconds {
1715 shift->_op_usage('+', 'seconds', @_);
1723 my %op2condition = (
1724 '-' => sub { my($self, $column, $amount) = @_;
1725 $self->$column - $amount <= 0;
1727 '+' => sub { my($self, $column, $amount) = @_;
1728 ($self->$column || 0) + $amount > 0;
1731 my %op2warncondition = (
1732 '-' => sub { my($self, $column, $amount) = @_;
1733 my $threshold = $column . '_threshold';
1734 $self->$column - $amount <= $self->$threshold + 0;
1736 '+' => sub { my($self, $column, $amount) = @_;
1737 ($self->$column || 0) + $amount > 0;
1742 my( $self, $op, $column, $amount ) = @_;
1744 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1745 ' ('. $self->email. "): $op $amount\n"
1748 return '' unless $amount;
1750 local $SIG{HUP} = 'IGNORE';
1751 local $SIG{INT} = 'IGNORE';
1752 local $SIG{QUIT} = 'IGNORE';
1753 local $SIG{TERM} = 'IGNORE';
1754 local $SIG{TSTP} = 'IGNORE';
1755 local $SIG{PIPE} = 'IGNORE';
1757 my $oldAutoCommit = $FS::UID::AutoCommit;
1758 local $FS::UID::AutoCommit = 0;
1761 my $sql = "UPDATE svc_acct SET $column = ".
1762 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1763 " $op ? WHERE svcnum = ?";
1767 my $sth = $dbh->prepare( $sql )
1768 or die "Error preparing $sql: ". $dbh->errstr;
1769 my $rv = $sth->execute($amount, $self->svcnum);
1770 die "Error executing $sql: ". $sth->errstr
1771 unless defined($rv);
1772 die "Can't update $column for svcnum". $self->svcnum
1775 my $action = $op2action{$op};
1777 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1778 ( $action eq 'suspend' && !$self->overlimit
1779 || $action eq 'unsuspend' && $self->overlimit )
1781 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1782 if ($part_export->option('overlimit_groups')) {
1784 my $other = new FS::svc_acct $self->hashref;
1785 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1786 ($self, $part_export->option('overlimit_groups'));
1787 $other->usergroup( $groups );
1788 if ($action eq 'suspend'){
1789 $new = $other; $old = $self;
1791 $new = $self; $old = $other;
1793 my $error = $part_export->export_replace($new, $old);
1794 $error ||= $self->overlimit($action);
1796 $dbh->rollback if $oldAutoCommit;
1797 return "Error replacing radius groups in export, ${op}: $error";
1803 if ( $conf->exists("svc_acct-usage_$action")
1804 && &{$op2condition{$op}}($self, $column, $amount) ) {
1805 #my $error = $self->$action();
1806 my $error = $self->cust_svc->cust_pkg->$action();
1807 # $error ||= $self->overlimit($action);
1809 $dbh->rollback if $oldAutoCommit;
1810 return "Error ${action}ing: $error";
1814 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1815 my $wqueue = new FS::queue {
1816 'svcnum' => $self->svcnum,
1817 'job' => 'FS::svc_acct::reached_threshold',
1822 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1826 my $error = $wqueue->insert(
1827 'svcnum' => $self->svcnum,
1829 'column' => $column,
1833 $dbh->rollback if $oldAutoCommit;
1834 return "Error queuing threshold activity: $error";
1838 warn "$me update successful; committing\n"
1840 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1846 my( $self, $valueref, %options ) = @_;
1848 warn "$me set_usage called for svcnum ". $self->svcnum.
1849 ' ('. $self->email. "): ".
1850 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1853 local $SIG{HUP} = 'IGNORE';
1854 local $SIG{INT} = 'IGNORE';
1855 local $SIG{QUIT} = 'IGNORE';
1856 local $SIG{TERM} = 'IGNORE';
1857 local $SIG{TSTP} = 'IGNORE';
1858 local $SIG{PIPE} = 'IGNORE';
1860 local $FS::svc_Common::noexport_hack = 1;
1861 my $oldAutoCommit = $FS::UID::AutoCommit;
1862 local $FS::UID::AutoCommit = 0;
1867 if ( $options{null} ) {
1868 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1869 qw( seconds upbytes downbytes totalbytes )
1872 foreach my $field (keys %$valueref){
1873 $reset = 1 if $valueref->{$field};
1874 $self->setfield($field, $valueref->{$field});
1875 $self->setfield( $field.'_threshold',
1876 int($self->getfield($field)
1877 * ( $conf->exists('svc_acct-usage_threshold')
1878 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1883 $handyhash{$field} = $self->getfield($field);
1884 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1886 #my $error = $self->replace; #NO! we avoid the call to ->check for
1887 #die $error if $error; #services not explicity changed via the UI
1889 my $sql = "UPDATE svc_acct SET " .
1890 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
1891 " WHERE svcnum = ". $self->svcnum;
1896 if (scalar(keys %handyhash)) {
1897 my $sth = $dbh->prepare( $sql )
1898 or die "Error preparing $sql: ". $dbh->errstr;
1899 my $rv = $sth->execute();
1900 die "Error executing $sql: ". $sth->errstr
1901 unless defined($rv);
1902 die "Can't update usage for svcnum ". $self->svcnum
1909 if ($self->overlimit) {
1910 $error = $self->overlimit('unsuspend');
1911 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1912 if ($part_export->option('overlimit_groups')) {
1913 my $old = new FS::svc_acct $self->hashref;
1914 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1915 ($self, $part_export->option('overlimit_groups'));
1916 $old->usergroup( $groups );
1917 $error ||= $part_export->export_replace($self, $old);
1922 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1923 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1926 $dbh->rollback if $oldAutoCommit;
1927 return "Error unsuspending: $error";
1931 warn "$me update successful; committing\n"
1933 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1939 =item recharge HASHREF
1941 Increments usage columns by the amount specified in HASHREF as
1942 column=>amount pairs.
1947 my ($self, $vhash) = @_;
1950 warn "[$me] recharge called on $self: ". Dumper($self).
1951 "\nwith vhash: ". Dumper($vhash);
1954 my $oldAutoCommit = $FS::UID::AutoCommit;
1955 local $FS::UID::AutoCommit = 0;
1959 foreach my $column (keys %$vhash){
1960 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1964 $dbh->rollback if $oldAutoCommit;
1966 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1971 =item is_rechargeable
1973 Returns true if this svc_account can be "recharged" and false otherwise.
1977 sub is_rechargable {
1979 $self->seconds ne ''
1980 || $self->upbytes ne ''
1981 || $self->downbytes ne ''
1982 || $self->totalbytes ne '';
1985 =item seconds_since TIMESTAMP
1987 Returns the number of seconds this account has been online since TIMESTAMP,
1988 according to the session monitor (see L<FS::Session>).
1990 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1991 L<Time::Local> and L<Date::Parse> for conversion functions.
1995 #note: POD here, implementation in FS::cust_svc
1998 $self->cust_svc->seconds_since(@_);
2001 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2003 Returns the numbers of seconds this account has been online between
2004 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2005 external SQL radacct table, specified via sqlradius export. Sessions which
2006 started in the specified range but are still open are counted from session
2007 start to the end of the range (unless they are over 1 day old, in which case
2008 they are presumed missing their stop record and not counted). Also, sessions
2009 which end in the range but started earlier are counted from the start of the
2010 range to session end. Finally, sessions which start before the range but end
2011 after are counted for the entire range.
2013 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2014 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2019 #note: POD here, implementation in FS::cust_svc
2020 sub seconds_since_sqlradacct {
2022 $self->cust_svc->seconds_since_sqlradacct(@_);
2025 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2027 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2028 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2029 TIMESTAMP_END (exclusive).
2031 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2032 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2037 #note: POD here, implementation in FS::cust_svc
2038 sub attribute_since_sqlradacct {
2040 $self->cust_svc->attribute_since_sqlradacct(@_);
2043 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2045 Returns an array of hash references of this customers login history for the
2046 given time range. (document this better)
2050 sub get_session_history {
2052 $self->cust_svc->get_session_history(@_);
2055 =item last_login_text
2057 Returns text describing the time of last login.
2061 sub last_login_text {
2063 $self->last_login ? ctime($self->last_login) : 'unknown';
2066 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2071 my($self, $start, $end, %opt ) = @_;
2073 my $did = $self->username; #yup
2075 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2077 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2079 #SELECT $for_update * FROM cdr
2080 # WHERE calldate >= $start #need a conversion
2081 # AND calldate < $end #ditto
2082 # AND ( charged_party = "$did"
2083 # OR charged_party = "$prefix$did" #if length($prefix);
2084 # OR ( ( charged_party IS NULL OR charged_party = '' )
2086 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2089 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2092 if ( length($prefix) ) {
2094 " AND ( charged_party = '$did'
2095 OR charged_party = '$prefix$did'
2096 OR ( ( charged_party IS NULL OR charged_party = '' )
2098 ( src = '$did' OR src = '$prefix$did' )
2104 " AND ( charged_party = '$did'
2105 OR ( ( charged_party IS NULL OR charged_party = '' )
2115 'select' => "$for_update *",
2118 #( freesidestatus IS NULL OR freesidestatus = '' )
2119 'freesidestatus' => '',
2121 'extra_sql' => $charged_or_src,
2129 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2135 if ( $self->usergroup ) {
2136 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2137 unless ref($self->usergroup) eq 'ARRAY';
2138 #when provisioning records, export callback runs in svc_Common.pm before
2139 #radius_usergroup records can be inserted...
2140 @{$self->usergroup};
2142 map { $_->groupname }
2143 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2147 =item clone_suspended
2149 Constructor used by FS::part_export::_export_suspend fallback. Document
2154 sub clone_suspended {
2156 my %hash = $self->hash;
2157 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2158 new FS::svc_acct \%hash;
2161 =item clone_kludge_unsuspend
2163 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2168 sub clone_kludge_unsuspend {
2170 my %hash = $self->hash;
2171 $hash{_password} = '';
2172 new FS::svc_acct \%hash;
2175 =item check_password
2177 Checks the supplied password against the (possibly encrypted) password in the
2178 database. Returns true for a successful authentication, false for no match.
2180 Currently supported encryptions are: classic DES crypt() and MD5
2184 sub check_password {
2185 my($self, $check_password) = @_;
2187 #remove old-style SUSPENDED kludge, they should be allowed to login to
2188 #self-service and pay up
2189 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2191 if ( $self->_password_encoding eq 'ldap' ) {
2193 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2194 return $auth->match($check_password);
2196 } elsif ( $self->_password_encoding eq 'crypt' ) {
2198 my $auth = from_crypt Authen::Passphrase $self->_password;
2199 return $auth->match($check_password);
2201 } elsif ( $self->_password_encoding eq 'plain' ) {
2203 return $check_password eq $password;
2207 #XXX this could be replaced with Authen::Passphrase stuff
2209 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2211 } elsif ( length($password) < 13 ) { #plaintext
2212 $check_password eq $password;
2213 } elsif ( length($password) == 13 ) { #traditional DES crypt
2214 crypt($check_password, $password) eq $password;
2215 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2216 unix_md5_crypt($check_password, $password) eq $password;
2217 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2218 warn "Can't check password: Blowfish encryption not yet supported, ".
2219 "svcnum ". $self->svcnum. "\n";
2222 warn "Can't check password: Unrecognized encryption for svcnum ".
2223 $self->svcnum. "\n";
2231 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2233 Returns an encrypted password, either by passing through an encrypted password
2234 in the database or by encrypting a plaintext password from the database.
2236 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2237 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2238 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2239 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2240 encryption type is only used if the password is not already encrypted in the
2245 sub crypt_password {
2248 if ( $self->_password_encoding eq 'ldap' ) {
2250 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2253 #XXX this could be replaced with Authen::Passphrase stuff
2255 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2256 if ( $encryption eq 'crypt' ) {
2259 $saltset[int(rand(64))].$saltset[int(rand(64))]
2261 } elsif ( $encryption eq 'md5' ) {
2262 unix_md5_crypt( $self->_password );
2263 } elsif ( $encryption eq 'blowfish' ) {
2264 croak "unknown encryption method $encryption";
2266 croak "unknown encryption method $encryption";
2269 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2273 } elsif ( $self->_password_encoding eq 'crypt' ) {
2275 return $self->_password;
2277 } elsif ( $self->_password_encoding eq 'plain' ) {
2279 #XXX this could be replaced with Authen::Passphrase stuff
2281 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2282 if ( $encryption eq 'crypt' ) {
2285 $saltset[int(rand(64))].$saltset[int(rand(64))]
2287 } elsif ( $encryption eq 'md5' ) {
2288 unix_md5_crypt( $self->_password );
2289 } elsif ( $encryption eq 'blowfish' ) {
2290 croak "unknown encryption method $encryption";
2292 croak "unknown encryption method $encryption";
2297 if ( length($self->_password) == 13
2298 || $self->_password =~ /^\$(1|2a?)\$/
2299 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2305 #XXX this could be replaced with Authen::Passphrase stuff
2307 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2308 if ( $encryption eq 'crypt' ) {
2311 $saltset[int(rand(64))].$saltset[int(rand(64))]
2313 } elsif ( $encryption eq 'md5' ) {
2314 unix_md5_crypt( $self->_password );
2315 } elsif ( $encryption eq 'blowfish' ) {
2316 croak "unknown encryption method $encryption";
2318 croak "unknown encryption method $encryption";
2327 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2329 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2330 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2331 "{MD5}5426824942db4253f87a1009fd5d2d4".
2333 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2334 to work the same as the B</crypt_password> method.
2340 #eventually should check a "password-encoding" field
2342 if ( $self->_password_encoding eq 'ldap' ) {
2344 return $self->_password;
2346 } elsif ( $self->_password_encoding eq 'crypt' ) {
2348 if ( length($self->_password) == 13 ) { #crypt
2349 return '{CRYPT}'. $self->_password;
2350 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2352 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2353 # die "Blowfish encryption not supported in this context, svcnum ".
2354 # $self->svcnum. "\n";
2356 warn "encryption method not (yet?) supported in LDAP context";
2357 return '{CRYPT}*'; #unsupported, should not auth
2360 } elsif ( $self->_password_encoding eq 'plain' ) {
2362 return '{PLAIN}'. $self->_password;
2364 #return '{CLEARTEXT}'. $self->_password; #?
2368 if ( length($self->_password) == 13 ) { #crypt
2369 return '{CRYPT}'. $self->_password;
2370 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2372 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2373 warn "Blowfish encryption not supported in this context, svcnum ".
2374 $self->svcnum. "\n";
2377 #are these two necessary anymore?
2378 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2379 return '{SSHA}'. $1;
2380 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2381 return '{NS-MTA-MD5}'. $1;
2384 return '{PLAIN}'. $self->_password;
2386 #return '{CLEARTEXT}'. $self->_password; #?
2388 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2389 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2390 #if ( $encryption eq 'crypt' ) {
2391 # return '{CRYPT}'. crypt(
2393 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2395 #} elsif ( $encryption eq 'md5' ) {
2396 # unix_md5_crypt( $self->_password );
2397 #} elsif ( $encryption eq 'blowfish' ) {
2398 # croak "unknown encryption method $encryption";
2400 # croak "unknown encryption method $encryption";
2408 =item domain_slash_username
2410 Returns $domain/$username/
2414 sub domain_slash_username {
2416 $self->domain. '/'. $self->username. '/';
2419 =item virtual_maildir
2421 Returns $domain/maildirs/$username/
2425 sub virtual_maildir {
2427 $self->domain. '/maildirs/'. $self->username. '/';
2438 This is the FS::svc_acct job-queue-able version. It still uses
2439 FS::Misc::send_email under-the-hood.
2446 eval "use FS::Misc qw(send_email)";
2449 $opt{mimetype} ||= 'text/plain';
2450 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2452 my $error = send_email(
2453 'from' => $opt{from},
2455 'subject' => $opt{subject},
2456 'content-type' => $opt{mimetype},
2457 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2459 die $error if $error;
2462 =item check_and_rebuild_fuzzyfiles
2466 sub check_and_rebuild_fuzzyfiles {
2467 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2468 -e "$dir/svc_acct.username"
2469 or &rebuild_fuzzyfiles;
2472 =item rebuild_fuzzyfiles
2476 sub rebuild_fuzzyfiles {
2478 use Fcntl qw(:flock);
2480 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2484 open(USERNAMELOCK,">>$dir/svc_acct.username")
2485 or die "can't open $dir/svc_acct.username: $!";
2486 flock(USERNAMELOCK,LOCK_EX)
2487 or die "can't lock $dir/svc_acct.username: $!";
2489 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2491 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2492 or die "can't open $dir/svc_acct.username.tmp: $!";
2493 print USERNAMECACHE join("\n", @all_username), "\n";
2494 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2496 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2506 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2507 open(USERNAMECACHE,"<$dir/svc_acct.username")
2508 or die "can't open $dir/svc_acct.username: $!";
2509 my @array = map { chomp; $_; } <USERNAMECACHE>;
2510 close USERNAMECACHE;
2514 =item append_fuzzyfiles USERNAME
2518 sub append_fuzzyfiles {
2519 my $username = shift;
2521 &check_and_rebuild_fuzzyfiles;
2523 use Fcntl qw(:flock);
2525 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2527 open(USERNAME,">>$dir/svc_acct.username")
2528 or die "can't open $dir/svc_acct.username: $!";
2529 flock(USERNAME,LOCK_EX)
2530 or die "can't lock $dir/svc_acct.username: $!";
2532 print USERNAME "$username\n";
2534 flock(USERNAME,LOCK_UN)
2535 or die "can't unlock $dir/svc_acct.username: $!";
2543 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2547 sub radius_usergroup_selector {
2548 my $sel_groups = shift;
2549 my %sel_groups = map { $_=>1 } @$sel_groups;
2551 my $selectname = shift || 'radius_usergroup';
2554 my $sth = $dbh->prepare(
2555 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2556 ) or die $dbh->errstr;
2557 $sth->execute() or die $sth->errstr;
2558 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2562 function ${selectname}_doadd(object) {
2563 var myvalue = object.${selectname}_add.value;
2564 var optionName = new Option(myvalue,myvalue,false,true);
2565 var length = object.$selectname.length;
2566 object.$selectname.options[length] = optionName;
2567 object.${selectname}_add.value = "";
2570 <SELECT MULTIPLE NAME="$selectname">
2573 foreach my $group ( @all_groups ) {
2574 $html .= qq(<OPTION VALUE="$group");
2575 if ( $sel_groups{$group} ) {
2576 $html .= ' SELECTED';
2577 $sel_groups{$group} = 0;
2579 $html .= ">$group</OPTION>\n";
2581 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2582 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2584 $html .= '</SELECT>';
2586 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2587 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2592 =item reached_threshold
2594 Performs some activities when svc_acct thresholds (such as number of seconds
2595 remaining) are reached.
2599 sub reached_threshold {
2602 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2603 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2605 if ( $opt{'op'} eq '+' ){
2606 $svc_acct->setfield( $opt{'column'}.'_threshold',
2607 int($svc_acct->getfield($opt{'column'})
2608 * ( $conf->exists('svc_acct-usage_threshold')
2609 ? $conf->config('svc_acct-usage_threshold')/100
2614 my $error = $svc_acct->replace;
2615 die $error if $error;
2616 }elsif ( $opt{'op'} eq '-' ){
2618 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2619 return '' if ($threshold eq '' );
2621 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2622 my $error = $svc_acct->replace;
2623 die $error if $error; # email next time, i guess
2625 if ( $warning_template ) {
2626 eval "use FS::Misc qw(send_email)";
2629 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2630 my $cust_main = $cust_pkg->cust_main;
2632 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2633 $cust_main->invoicing_list,
2634 ($opt{'to'} ? $opt{'to'} : ())
2637 my $mimetype = $warning_mimetype;
2638 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2640 my $body = $warning_template->fill_in( HASH => {
2641 'custnum' => $cust_main->custnum,
2642 'username' => $svc_acct->username,
2643 'password' => $svc_acct->_password,
2644 'first' => $cust_main->first,
2645 'last' => $cust_main->getfield('last'),
2646 'pkg' => $cust_pkg->part_pkg->pkg,
2647 'column' => $opt{'column'},
2648 'amount' => $opt{'column'} =~/bytes/
2649 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2650 : $svc_acct->getfield($opt{'column'}),
2651 'threshold' => $opt{'column'} =~/bytes/
2652 ? FS::UI::bytecount::display_bytecount($threshold)
2657 my $error = send_email(
2658 'from' => $warning_from,
2660 'subject' => $warning_subject,
2661 'content-type' => $mimetype,
2662 'body' => [ map "$_\n", split("\n", $body) ],
2664 die $error if $error;
2667 die "unknown op: " . $opt{'op'};
2675 The $recref stuff in sub check should be cleaned up.
2677 The suspend, unsuspend and cancel methods update the database, but not the
2678 current object. This is probably a bug as it's unexpected and
2681 radius_usergroup_selector? putting web ui components in here? they should
2682 probably live somewhere else...
2684 insertion of RADIUS group stuff in insert could be done with child_objects now
2685 (would probably clean up export of them too)
2689 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2690 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2691 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2692 L<freeside-queued>), L<FS::svc_acct_pop>,
2693 schema.html from the base documentation.
2697 =item domain_select_hash %OPTIONS
2699 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2700 may at present purchase.
2702 Currently available options are: I<pkgnum> I<svcpart>
2706 sub domain_select_hash {
2707 my ($self, %options) = @_;
2713 $part_svc = $self->part_svc;
2714 $cust_pkg = $self->cust_svc->cust_pkg
2718 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2719 if $options{'svcpart'};
2721 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2722 if $options{'pkgnum'};
2724 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2725 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2726 %domains = map { $_->svcnum => $_->domain }
2727 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2728 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2729 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2730 %domains = map { $_->svcnum => $_->domain }
2731 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2732 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2733 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2735 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2738 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2739 my $svc_domain = qsearchs('svc_domain',
2740 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2741 if ( $svc_domain ) {
2742 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2744 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2745 $part_svc->part_svc_column('domsvc')->columnvalue;