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 #overlimit_action eq 'cancel' handling
1776 my $cust_pkg = $self->cust_svc->cust_pkg;
1778 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1779 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1783 my $error = $cust_pkg->cancel; #XXX should have a reason
1785 $dbh->rollback if $oldAutoCommit;
1786 return "Error cancelling: $error";
1789 #nothing else is relevant if we're cancelling, so commit & return success
1790 warn "$me update successful; committing\n"
1792 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1797 my $action = $op2action{$op};
1799 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1800 ( $action eq 'suspend' && !$self->overlimit
1801 || $action eq 'unsuspend' && $self->overlimit )
1803 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1804 if ($part_export->option('overlimit_groups')) {
1806 my $other = new FS::svc_acct $self->hashref;
1807 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1808 ($self, $part_export->option('overlimit_groups'));
1809 $other->usergroup( $groups );
1810 if ($action eq 'suspend'){
1811 $new = $other; $old = $self;
1813 $new = $self; $old = $other;
1815 my $error = $part_export->export_replace($new, $old);
1816 $error ||= $self->overlimit($action);
1818 $dbh->rollback if $oldAutoCommit;
1819 return "Error replacing radius groups in export, ${op}: $error";
1825 if ( $conf->exists("svc_acct-usage_$action")
1826 && &{$op2condition{$op}}($self, $column, $amount) ) {
1827 #my $error = $self->$action();
1828 my $error = $self->cust_svc->cust_pkg->$action();
1829 # $error ||= $self->overlimit($action);
1831 $dbh->rollback if $oldAutoCommit;
1832 return "Error ${action}ing: $error";
1836 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1837 my $wqueue = new FS::queue {
1838 'svcnum' => $self->svcnum,
1839 'job' => 'FS::svc_acct::reached_threshold',
1844 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1848 my $error = $wqueue->insert(
1849 'svcnum' => $self->svcnum,
1851 'column' => $column,
1855 $dbh->rollback if $oldAutoCommit;
1856 return "Error queuing threshold activity: $error";
1860 warn "$me update successful; committing\n"
1862 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1868 my( $self, $valueref, %options ) = @_;
1870 warn "$me set_usage called for svcnum ". $self->svcnum.
1871 ' ('. $self->email. "): ".
1872 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1875 local $SIG{HUP} = 'IGNORE';
1876 local $SIG{INT} = 'IGNORE';
1877 local $SIG{QUIT} = 'IGNORE';
1878 local $SIG{TERM} = 'IGNORE';
1879 local $SIG{TSTP} = 'IGNORE';
1880 local $SIG{PIPE} = 'IGNORE';
1882 local $FS::svc_Common::noexport_hack = 1;
1883 my $oldAutoCommit = $FS::UID::AutoCommit;
1884 local $FS::UID::AutoCommit = 0;
1889 if ( $options{null} ) {
1890 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1891 qw( seconds upbytes downbytes totalbytes )
1894 foreach my $field (keys %$valueref){
1895 $reset = 1 if $valueref->{$field};
1896 $self->setfield($field, $valueref->{$field});
1897 $self->setfield( $field.'_threshold',
1898 int($self->getfield($field)
1899 * ( $conf->exists('svc_acct-usage_threshold')
1900 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1905 $handyhash{$field} = $self->getfield($field);
1906 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1908 #my $error = $self->replace; #NO! we avoid the call to ->check for
1909 #die $error if $error; #services not explicity changed via the UI
1911 my $sql = "UPDATE svc_acct SET " .
1912 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
1913 " WHERE svcnum = ". $self->svcnum;
1918 if (scalar(keys %handyhash)) {
1919 my $sth = $dbh->prepare( $sql )
1920 or die "Error preparing $sql: ". $dbh->errstr;
1921 my $rv = $sth->execute();
1922 die "Error executing $sql: ". $sth->errstr
1923 unless defined($rv);
1924 die "Can't update usage for svcnum ". $self->svcnum
1931 if ($self->overlimit) {
1932 $error = $self->overlimit('unsuspend');
1933 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1934 if ($part_export->option('overlimit_groups')) {
1935 my $old = new FS::svc_acct $self->hashref;
1936 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1937 ($self, $part_export->option('overlimit_groups'));
1938 $old->usergroup( $groups );
1939 $error ||= $part_export->export_replace($self, $old);
1944 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1945 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1948 $dbh->rollback if $oldAutoCommit;
1949 return "Error unsuspending: $error";
1953 warn "$me update successful; committing\n"
1955 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1961 =item recharge HASHREF
1963 Increments usage columns by the amount specified in HASHREF as
1964 column=>amount pairs.
1969 my ($self, $vhash) = @_;
1972 warn "[$me] recharge called on $self: ". Dumper($self).
1973 "\nwith vhash: ". Dumper($vhash);
1976 my $oldAutoCommit = $FS::UID::AutoCommit;
1977 local $FS::UID::AutoCommit = 0;
1981 foreach my $column (keys %$vhash){
1982 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1986 $dbh->rollback if $oldAutoCommit;
1988 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1993 =item is_rechargeable
1995 Returns true if this svc_account can be "recharged" and false otherwise.
1999 sub is_rechargable {
2001 $self->seconds ne ''
2002 || $self->upbytes ne ''
2003 || $self->downbytes ne ''
2004 || $self->totalbytes ne '';
2007 =item seconds_since TIMESTAMP
2009 Returns the number of seconds this account has been online since TIMESTAMP,
2010 according to the session monitor (see L<FS::Session>).
2012 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2013 L<Time::Local> and L<Date::Parse> for conversion functions.
2017 #note: POD here, implementation in FS::cust_svc
2020 $self->cust_svc->seconds_since(@_);
2023 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2025 Returns the numbers of seconds this account has been online between
2026 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2027 external SQL radacct table, specified via sqlradius export. Sessions which
2028 started in the specified range but are still open are counted from session
2029 start to the end of the range (unless they are over 1 day old, in which case
2030 they are presumed missing their stop record and not counted). Also, sessions
2031 which end in the range but started earlier are counted from the start of the
2032 range to session end. Finally, sessions which start before the range but end
2033 after are counted for the entire range.
2035 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2036 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2041 #note: POD here, implementation in FS::cust_svc
2042 sub seconds_since_sqlradacct {
2044 $self->cust_svc->seconds_since_sqlradacct(@_);
2047 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2049 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2050 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2051 TIMESTAMP_END (exclusive).
2053 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2054 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2059 #note: POD here, implementation in FS::cust_svc
2060 sub attribute_since_sqlradacct {
2062 $self->cust_svc->attribute_since_sqlradacct(@_);
2065 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2067 Returns an array of hash references of this customers login history for the
2068 given time range. (document this better)
2072 sub get_session_history {
2074 $self->cust_svc->get_session_history(@_);
2077 =item last_login_text
2079 Returns text describing the time of last login.
2083 sub last_login_text {
2085 $self->last_login ? ctime($self->last_login) : 'unknown';
2088 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2093 my($self, $start, $end, %opt ) = @_;
2095 my $did = $self->username; #yup
2097 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2099 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2101 #SELECT $for_update * FROM cdr
2102 # WHERE calldate >= $start #need a conversion
2103 # AND calldate < $end #ditto
2104 # AND ( charged_party = "$did"
2105 # OR charged_party = "$prefix$did" #if length($prefix);
2106 # OR ( ( charged_party IS NULL OR charged_party = '' )
2108 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2111 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2114 if ( length($prefix) ) {
2116 " AND ( charged_party = '$did'
2117 OR charged_party = '$prefix$did'
2118 OR ( ( charged_party IS NULL OR charged_party = '' )
2120 ( src = '$did' OR src = '$prefix$did' )
2126 " AND ( charged_party = '$did'
2127 OR ( ( charged_party IS NULL OR charged_party = '' )
2137 'select' => "$for_update *",
2140 #( freesidestatus IS NULL OR freesidestatus = '' )
2141 'freesidestatus' => '',
2143 'extra_sql' => $charged_or_src,
2151 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2157 if ( $self->usergroup ) {
2158 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2159 unless ref($self->usergroup) eq 'ARRAY';
2160 #when provisioning records, export callback runs in svc_Common.pm before
2161 #radius_usergroup records can be inserted...
2162 @{$self->usergroup};
2164 map { $_->groupname }
2165 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2169 =item clone_suspended
2171 Constructor used by FS::part_export::_export_suspend fallback. Document
2176 sub clone_suspended {
2178 my %hash = $self->hash;
2179 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2180 new FS::svc_acct \%hash;
2183 =item clone_kludge_unsuspend
2185 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2190 sub clone_kludge_unsuspend {
2192 my %hash = $self->hash;
2193 $hash{_password} = '';
2194 new FS::svc_acct \%hash;
2197 =item check_password
2199 Checks the supplied password against the (possibly encrypted) password in the
2200 database. Returns true for a successful authentication, false for no match.
2202 Currently supported encryptions are: classic DES crypt() and MD5
2206 sub check_password {
2207 my($self, $check_password) = @_;
2209 #remove old-style SUSPENDED kludge, they should be allowed to login to
2210 #self-service and pay up
2211 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2213 if ( $self->_password_encoding eq 'ldap' ) {
2215 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2216 return $auth->match($check_password);
2218 } elsif ( $self->_password_encoding eq 'crypt' ) {
2220 my $auth = from_crypt Authen::Passphrase $self->_password;
2221 return $auth->match($check_password);
2223 } elsif ( $self->_password_encoding eq 'plain' ) {
2225 return $check_password eq $password;
2229 #XXX this could be replaced with Authen::Passphrase stuff
2231 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2233 } elsif ( length($password) < 13 ) { #plaintext
2234 $check_password eq $password;
2235 } elsif ( length($password) == 13 ) { #traditional DES crypt
2236 crypt($check_password, $password) eq $password;
2237 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2238 unix_md5_crypt($check_password, $password) eq $password;
2239 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2240 warn "Can't check password: Blowfish encryption not yet supported, ".
2241 "svcnum ". $self->svcnum. "\n";
2244 warn "Can't check password: Unrecognized encryption for svcnum ".
2245 $self->svcnum. "\n";
2253 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2255 Returns an encrypted password, either by passing through an encrypted password
2256 in the database or by encrypting a plaintext password from the database.
2258 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2259 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2260 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2261 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2262 encryption type is only used if the password is not already encrypted in the
2267 sub crypt_password {
2270 if ( $self->_password_encoding eq 'ldap' ) {
2272 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2275 #XXX this could be replaced with Authen::Passphrase stuff
2277 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2278 if ( $encryption eq 'crypt' ) {
2281 $saltset[int(rand(64))].$saltset[int(rand(64))]
2283 } elsif ( $encryption eq 'md5' ) {
2284 unix_md5_crypt( $self->_password );
2285 } elsif ( $encryption eq 'blowfish' ) {
2286 croak "unknown encryption method $encryption";
2288 croak "unknown encryption method $encryption";
2291 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2295 } elsif ( $self->_password_encoding eq 'crypt' ) {
2297 return $self->_password;
2299 } elsif ( $self->_password_encoding eq 'plain' ) {
2301 #XXX this could be replaced with Authen::Passphrase stuff
2303 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2304 if ( $encryption eq 'crypt' ) {
2307 $saltset[int(rand(64))].$saltset[int(rand(64))]
2309 } elsif ( $encryption eq 'md5' ) {
2310 unix_md5_crypt( $self->_password );
2311 } elsif ( $encryption eq 'blowfish' ) {
2312 croak "unknown encryption method $encryption";
2314 croak "unknown encryption method $encryption";
2319 if ( length($self->_password) == 13
2320 || $self->_password =~ /^\$(1|2a?)\$/
2321 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2327 #XXX this could be replaced with Authen::Passphrase stuff
2329 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2330 if ( $encryption eq 'crypt' ) {
2333 $saltset[int(rand(64))].$saltset[int(rand(64))]
2335 } elsif ( $encryption eq 'md5' ) {
2336 unix_md5_crypt( $self->_password );
2337 } elsif ( $encryption eq 'blowfish' ) {
2338 croak "unknown encryption method $encryption";
2340 croak "unknown encryption method $encryption";
2349 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2351 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2352 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2353 "{MD5}5426824942db4253f87a1009fd5d2d4".
2355 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2356 to work the same as the B</crypt_password> method.
2362 #eventually should check a "password-encoding" field
2364 if ( $self->_password_encoding eq 'ldap' ) {
2366 return $self->_password;
2368 } elsif ( $self->_password_encoding eq 'crypt' ) {
2370 if ( length($self->_password) == 13 ) { #crypt
2371 return '{CRYPT}'. $self->_password;
2372 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2374 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2375 # die "Blowfish encryption not supported in this context, svcnum ".
2376 # $self->svcnum. "\n";
2378 warn "encryption method not (yet?) supported in LDAP context";
2379 return '{CRYPT}*'; #unsupported, should not auth
2382 } elsif ( $self->_password_encoding eq 'plain' ) {
2384 return '{PLAIN}'. $self->_password;
2386 #return '{CLEARTEXT}'. $self->_password; #?
2390 if ( length($self->_password) == 13 ) { #crypt
2391 return '{CRYPT}'. $self->_password;
2392 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2394 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2395 warn "Blowfish encryption not supported in this context, svcnum ".
2396 $self->svcnum. "\n";
2399 #are these two necessary anymore?
2400 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2401 return '{SSHA}'. $1;
2402 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2403 return '{NS-MTA-MD5}'. $1;
2406 return '{PLAIN}'. $self->_password;
2408 #return '{CLEARTEXT}'. $self->_password; #?
2410 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2411 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2412 #if ( $encryption eq 'crypt' ) {
2413 # return '{CRYPT}'. crypt(
2415 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2417 #} elsif ( $encryption eq 'md5' ) {
2418 # unix_md5_crypt( $self->_password );
2419 #} elsif ( $encryption eq 'blowfish' ) {
2420 # croak "unknown encryption method $encryption";
2422 # croak "unknown encryption method $encryption";
2430 =item domain_slash_username
2432 Returns $domain/$username/
2436 sub domain_slash_username {
2438 $self->domain. '/'. $self->username. '/';
2441 =item virtual_maildir
2443 Returns $domain/maildirs/$username/
2447 sub virtual_maildir {
2449 $self->domain. '/maildirs/'. $self->username. '/';
2460 This is the FS::svc_acct job-queue-able version. It still uses
2461 FS::Misc::send_email under-the-hood.
2468 eval "use FS::Misc qw(send_email)";
2471 $opt{mimetype} ||= 'text/plain';
2472 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2474 my $error = send_email(
2475 'from' => $opt{from},
2477 'subject' => $opt{subject},
2478 'content-type' => $opt{mimetype},
2479 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2481 die $error if $error;
2484 =item check_and_rebuild_fuzzyfiles
2488 sub check_and_rebuild_fuzzyfiles {
2489 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2490 -e "$dir/svc_acct.username"
2491 or &rebuild_fuzzyfiles;
2494 =item rebuild_fuzzyfiles
2498 sub rebuild_fuzzyfiles {
2500 use Fcntl qw(:flock);
2502 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2506 open(USERNAMELOCK,">>$dir/svc_acct.username")
2507 or die "can't open $dir/svc_acct.username: $!";
2508 flock(USERNAMELOCK,LOCK_EX)
2509 or die "can't lock $dir/svc_acct.username: $!";
2511 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2513 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2514 or die "can't open $dir/svc_acct.username.tmp: $!";
2515 print USERNAMECACHE join("\n", @all_username), "\n";
2516 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2518 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2528 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2529 open(USERNAMECACHE,"<$dir/svc_acct.username")
2530 or die "can't open $dir/svc_acct.username: $!";
2531 my @array = map { chomp; $_; } <USERNAMECACHE>;
2532 close USERNAMECACHE;
2536 =item append_fuzzyfiles USERNAME
2540 sub append_fuzzyfiles {
2541 my $username = shift;
2543 &check_and_rebuild_fuzzyfiles;
2545 use Fcntl qw(:flock);
2547 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2549 open(USERNAME,">>$dir/svc_acct.username")
2550 or die "can't open $dir/svc_acct.username: $!";
2551 flock(USERNAME,LOCK_EX)
2552 or die "can't lock $dir/svc_acct.username: $!";
2554 print USERNAME "$username\n";
2556 flock(USERNAME,LOCK_UN)
2557 or die "can't unlock $dir/svc_acct.username: $!";
2565 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2569 sub radius_usergroup_selector {
2570 my $sel_groups = shift;
2571 my %sel_groups = map { $_=>1 } @$sel_groups;
2573 my $selectname = shift || 'radius_usergroup';
2576 my $sth = $dbh->prepare(
2577 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2578 ) or die $dbh->errstr;
2579 $sth->execute() or die $sth->errstr;
2580 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2584 function ${selectname}_doadd(object) {
2585 var myvalue = object.${selectname}_add.value;
2586 var optionName = new Option(myvalue,myvalue,false,true);
2587 var length = object.$selectname.length;
2588 object.$selectname.options[length] = optionName;
2589 object.${selectname}_add.value = "";
2592 <SELECT MULTIPLE NAME="$selectname">
2595 foreach my $group ( @all_groups ) {
2596 $html .= qq(<OPTION VALUE="$group");
2597 if ( $sel_groups{$group} ) {
2598 $html .= ' SELECTED';
2599 $sel_groups{$group} = 0;
2601 $html .= ">$group</OPTION>\n";
2603 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2604 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2606 $html .= '</SELECT>';
2608 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2609 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2614 =item reached_threshold
2616 Performs some activities when svc_acct thresholds (such as number of seconds
2617 remaining) are reached.
2621 sub reached_threshold {
2624 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2625 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2627 if ( $opt{'op'} eq '+' ){
2628 $svc_acct->setfield( $opt{'column'}.'_threshold',
2629 int($svc_acct->getfield($opt{'column'})
2630 * ( $conf->exists('svc_acct-usage_threshold')
2631 ? $conf->config('svc_acct-usage_threshold')/100
2636 my $error = $svc_acct->replace;
2637 die $error if $error;
2638 }elsif ( $opt{'op'} eq '-' ){
2640 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2641 return '' if ($threshold eq '' );
2643 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2644 my $error = $svc_acct->replace;
2645 die $error if $error; # email next time, i guess
2647 if ( $warning_template ) {
2648 eval "use FS::Misc qw(send_email)";
2651 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2652 my $cust_main = $cust_pkg->cust_main;
2654 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2655 $cust_main->invoicing_list,
2656 ($opt{'to'} ? $opt{'to'} : ())
2659 my $mimetype = $warning_mimetype;
2660 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2662 my $body = $warning_template->fill_in( HASH => {
2663 'custnum' => $cust_main->custnum,
2664 'username' => $svc_acct->username,
2665 'password' => $svc_acct->_password,
2666 'first' => $cust_main->first,
2667 'last' => $cust_main->getfield('last'),
2668 'pkg' => $cust_pkg->part_pkg->pkg,
2669 'column' => $opt{'column'},
2670 'amount' => $opt{'column'} =~/bytes/
2671 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2672 : $svc_acct->getfield($opt{'column'}),
2673 'threshold' => $opt{'column'} =~/bytes/
2674 ? FS::UI::bytecount::display_bytecount($threshold)
2679 my $error = send_email(
2680 'from' => $warning_from,
2682 'subject' => $warning_subject,
2683 'content-type' => $mimetype,
2684 'body' => [ map "$_\n", split("\n", $body) ],
2686 die $error if $error;
2689 die "unknown op: " . $opt{'op'};
2697 The $recref stuff in sub check should be cleaned up.
2699 The suspend, unsuspend and cancel methods update the database, but not the
2700 current object. This is probably a bug as it's unexpected and
2703 radius_usergroup_selector? putting web ui components in here? they should
2704 probably live somewhere else...
2706 insertion of RADIUS group stuff in insert could be done with child_objects now
2707 (would probably clean up export of them too)
2711 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2712 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2713 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2714 L<freeside-queued>), L<FS::svc_acct_pop>,
2715 schema.html from the base documentation.
2719 =item domain_select_hash %OPTIONS
2721 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2722 may at present purchase.
2724 Currently available options are: I<pkgnum> I<svcpart>
2728 sub domain_select_hash {
2729 my ($self, %options) = @_;
2735 $part_svc = $self->part_svc;
2736 $cust_pkg = $self->cust_svc->cust_pkg
2740 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2741 if $options{'svcpart'};
2743 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2744 if $options{'pkgnum'};
2746 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2747 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2748 %domains = map { $_->svcnum => $_->domain }
2749 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2750 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2751 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2752 %domains = map { $_->svcnum => $_->domain }
2753 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2754 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2755 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2757 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2760 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2761 my $svc_domain = qsearchs('svc_domain',
2762 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2763 if ( $svc_domain ) {
2764 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2766 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2767 $part_svc->part_svc_column('domsvc')->columnvalue;