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 );
22 use Crypt::PasswdMD5 1.2;
25 use Authen::Passphrase;
26 use FS::UID qw( datasrc driver_name );
28 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
29 use FS::Msgcat qw(gettext);
30 use FS::UI::bytecount;
36 use FS::cust_main_invoice;
40 use FS::radius_usergroup;
47 @ISA = qw( FS::svc_Common );
50 $me = '[FS::svc_acct]';
52 #ask FS::UID to run this stuff for us later
53 FS::UID->install_callback( sub {
55 $dir_prefix = $conf->config('home');
56 @shells = $conf->config('shells');
57 $usernamemin = $conf->config('usernamemin') || 2;
58 $usernamemax = $conf->config('usernamemax');
59 $passwordmin = $conf->config('passwordmin'); # || 6;
61 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
64 $passwordmax = $conf->config('passwordmax') || 8;
65 $username_letter = $conf->exists('username-letter');
66 $username_letterfirst = $conf->exists('username-letterfirst');
67 $username_noperiod = $conf->exists('username-noperiod');
68 $username_nounderscore = $conf->exists('username-nounderscore');
69 $username_nodash = $conf->exists('username-nodash');
70 $username_uppercase = $conf->exists('username-uppercase');
71 $username_ampersand = $conf->exists('username-ampersand');
72 $username_percent = $conf->exists('username-percent');
73 $username_colon = $conf->exists('username-colon');
74 $password_noampersand = $conf->exists('password-noexclamation');
75 $password_noexclamation = $conf->exists('password-noexclamation');
76 $dirhash = $conf->config('dirhash') || 0;
77 if ( $conf->exists('warning_email') ) {
78 $warning_template = new Text::Template (
80 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
81 ) or warn "can't create warning email template: $Text::Template::ERROR";
82 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
83 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
84 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
85 $warning_cc = $conf->config('warning_email-cc');
87 $warning_template = '';
89 $warning_subject = '';
90 $warning_mimetype = '';
93 $smtpmachine = $conf->config('smtpmachine');
94 $radius_password = $conf->config('radius-password') || 'Password';
95 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
96 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
100 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
101 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
105 my ( $hashref, $cache ) = @_;
106 if ( $hashref->{'svc_acct_svcnum'} ) {
107 $self->{'_domsvc'} = FS::svc_domain->new( {
108 'svcnum' => $hashref->{'domsvc'},
109 'domain' => $hashref->{'svc_acct_domain'},
110 'catchall' => $hashref->{'svc_acct_catchall'},
117 FS::svc_acct - Object methods for svc_acct records
123 $record = new FS::svc_acct \%hash;
124 $record = new FS::svc_acct { 'column' => 'value' };
126 $error = $record->insert;
128 $error = $new_record->replace($old_record);
130 $error = $record->delete;
132 $error = $record->check;
134 $error = $record->suspend;
136 $error = $record->unsuspend;
138 $error = $record->cancel;
140 %hash = $record->radius;
142 %hash = $record->radius_reply;
144 %hash = $record->radius_check;
146 $domain = $record->domain;
148 $svc_domain = $record->svc_domain;
150 $email = $record->email;
152 $seconds_since = $record->seconds_since($timestamp);
156 An FS::svc_acct object represents an account. FS::svc_acct inherits from
157 FS::svc_Common. The following fields are currently supported:
161 =item svcnum - primary key (assigned automatcially for new accounts)
165 =item _password - generated if blank
167 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
169 =item sec_phrase - security phrase
171 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
179 =item dir - set automatically if blank (and uid is not)
183 =item quota - (unimplementd)
185 =item slipip - IP address
195 =item domsvc - svcnum from svc_domain
197 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
199 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
209 Creates a new account. To add the account to the database, see L<"insert">.
216 'longname_plural' => 'Access accounts and mailboxes',
217 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
218 'display_weight' => 10,
219 'cancel_weight' => 50,
221 'dir' => 'Home directory',
224 def_info => 'set to fixed and blank for no UIDs',
227 'slipip' => 'IP address',
228 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
230 label => 'Access number',
232 select_table => 'svc_acct_pop',
233 select_key => 'popnum',
234 select_label => 'city',
240 disable_default => 1,
247 disable_inventory => 1,
250 '_password' => 'Password',
253 def_info => 'when blank, defaults to UID',
258 def_info => 'set to blank for no shell tracking',
260 #select_list => [ $conf->config('shells') ],
261 select_list => [ $conf ? $conf->config('shells') : () ],
262 disable_inventory => 1,
265 'finger' => 'Real name', # (GECOS)',
269 select_table => 'svc_domain',
270 select_key => 'svcnum',
271 select_label => 'domain',
272 disable_inventory => 1,
276 label => 'RADIUS groups',
277 type => 'radius_usergroup_selector',
278 disable_inventory => 1,
281 'seconds' => { label => 'Seconds',
282 label_sort => 'with Time Remaining',
284 disable_inventory => 1,
286 disable_part_svc_column => 1,
288 'upbytes' => { label => 'Upload',
290 disable_inventory => 1,
292 'format' => \&FS::UI::bytecount::display_bytecount,
293 'parse' => \&FS::UI::bytecount::parse_bytecount,
294 disable_part_svc_column => 1,
296 'downbytes' => { label => 'Download',
298 disable_inventory => 1,
300 'format' => \&FS::UI::bytecount::display_bytecount,
301 'parse' => \&FS::UI::bytecount::parse_bytecount,
302 disable_part_svc_column => 1,
304 'totalbytes'=> { label => 'Total up and download',
306 disable_inventory => 1,
308 'format' => \&FS::UI::bytecount::display_bytecount,
309 'parse' => \&FS::UI::bytecount::parse_bytecount,
310 disable_part_svc_column => 1,
312 'seconds_threshold' => { label => 'Seconds threshold',
314 disable_inventory => 1,
316 disable_part_svc_column => 1,
318 'upbytes_threshold' => { label => 'Upload threshold',
320 disable_inventory => 1,
322 'format' => \&FS::UI::bytecount::display_bytecount,
323 'parse' => \&FS::UI::bytecount::parse_bytecount,
324 disable_part_svc_column => 1,
326 'downbytes_threshold' => { label => 'Download threshold',
328 disable_inventory => 1,
330 'format' => \&FS::UI::bytecount::display_bytecount,
331 'parse' => \&FS::UI::bytecount::parse_bytecount,
332 disable_part_svc_column => 1,
334 'totalbytes_threshold'=> { label => 'Total up and download threshold',
336 disable_inventory => 1,
338 'format' => \&FS::UI::bytecount::display_bytecount,
339 'parse' => \&FS::UI::bytecount::parse_bytecount,
340 disable_part_svc_column => 1,
343 label => 'Last login',
347 label => 'Last logout',
354 sub table { 'svc_acct'; }
356 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
360 #false laziness with edit/svc_acct.cgi
362 my( $self, $groups ) = @_;
363 if ( ref($groups) eq 'ARRAY' ) {
365 } elsif ( length($groups) ) {
366 [ split(/\s*,\s*/, $groups) ];
375 shift->_lastlog('in', @_);
379 shift->_lastlog('out', @_);
383 my( $self, $op, $time ) = @_;
385 if ( defined($time) ) {
386 warn "$me last_log$op called on svcnum ". $self->svcnum.
387 ' ('. $self->email. "): $time\n"
392 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
396 my $sth = $dbh->prepare( $sql )
397 or die "Error preparing $sql: ". $dbh->errstr;
398 my $rv = $sth->execute($time, $self->svcnum);
399 die "Error executing $sql: ". $sth->errstr
401 die "Can't update last_log$op for svcnum". $self->svcnum
404 $self->{'Hash'}->{"last_log$op"} = $time;
406 $self->getfield("last_log$op");
410 =item search_sql STRING
412 Class method which returns an SQL fragment to search for the given string.
417 my( $class, $string ) = @_;
418 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
419 my( $username, $domain ) = ( $1, $2 );
420 my $q_username = dbh->quote($username);
421 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
423 "svc_acct.username = $q_username AND ( ".
424 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
429 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
431 $class->search_sql_field('slipip', $string ).
433 $class->search_sql_field('username', $string ).
437 $class->search_sql_field('username', $string).
439 ? 'OR '. $class->search_sql_field('svcnum', $string)
446 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
448 Returns the "username@domain" string for this account.
450 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
460 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
462 Returns a longer string label for this acccount ("Real Name <username@domain>"
463 if available, or "username@domain").
465 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
472 my $label = $self->label(@_);
473 my $finger = $self->finger;
474 return $label unless $finger =~ /\S/;
475 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
476 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
480 =item insert [ , OPTION => VALUE ... ]
482 Adds this account to the database. If there is an error, returns the error,
483 otherwise returns false.
485 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
486 defined. An FS::cust_svc record will be created and inserted.
488 The additional field I<usergroup> can optionally be defined; if so it should
489 contain an arrayref of group names. See L<FS::radius_usergroup>.
491 The additional field I<child_objects> can optionally be defined; if so it
492 should contain an arrayref of FS::tablename objects. They will have their
493 svcnum fields set and will be inserted after this record, but before any
494 exports are run. Each element of the array can also optionally be a
495 two-element array reference containing the child object and the name of an
496 alternate field to be filled in with the newly-inserted svcnum, for example
497 C<[ $svc_forward, 'srcsvc' ]>
499 Currently available options are: I<depend_jobnum>
501 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
502 jobnums), all provisioning jobs will have a dependancy on the supplied
503 jobnum(s) (they will not run until the specific job(s) complete(s)).
505 (TODOC: L<FS::queue> and L<freeside-queued>)
507 (TODOC: new exports!)
516 warn "[$me] insert called on $self: ". Dumper($self).
517 "\nwith options: ". Dumper(%options);
520 local $SIG{HUP} = 'IGNORE';
521 local $SIG{INT} = 'IGNORE';
522 local $SIG{QUIT} = 'IGNORE';
523 local $SIG{TERM} = 'IGNORE';
524 local $SIG{TSTP} = 'IGNORE';
525 local $SIG{PIPE} = 'IGNORE';
527 my $oldAutoCommit = $FS::UID::AutoCommit;
528 local $FS::UID::AutoCommit = 0;
532 my $error = $self->SUPER::insert(
533 'jobnums' => \@jobnums,
534 'child_objects' => $self->child_objects,
538 $dbh->rollback if $oldAutoCommit;
542 if ( $self->usergroup ) {
543 foreach my $groupname ( @{$self->usergroup} ) {
544 my $radius_usergroup = new FS::radius_usergroup ( {
545 svcnum => $self->svcnum,
546 groupname => $groupname,
548 my $error = $radius_usergroup->insert;
550 $dbh->rollback if $oldAutoCommit;
556 unless ( $skip_fuzzyfiles ) {
557 $error = $self->queue_fuzzyfiles_update;
559 $dbh->rollback if $oldAutoCommit;
560 return "updating fuzzy search cache: $error";
564 my $cust_pkg = $self->cust_svc->cust_pkg;
567 my $cust_main = $cust_pkg->cust_main;
568 my $agentnum = $cust_main->agentnum;
570 if ( $conf->exists('emailinvoiceautoalways')
571 || $conf->exists('emailinvoiceauto')
572 && ! $cust_main->invoicing_list_emailonly
574 my @invoicing_list = $cust_main->invoicing_list;
575 push @invoicing_list, $self->email;
576 $cust_main->invoicing_list(\@invoicing_list);
580 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
581 = ('','','','','','');
583 if ( $conf->exists('welcome_email', $agentnum) ) {
584 $welcome_template = new Text::Template (
586 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
587 ) or warn "can't create welcome email template: $Text::Template::ERROR";
588 $welcome_from = $conf->config('welcome_email-from', $agentnum);
589 # || 'your-isp-is-dum'
590 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
592 $welcome_subject_template = new Text::Template (
594 SOURCE => $welcome_subject,
595 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
596 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
599 if ( $welcome_template && $cust_pkg ) {
600 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
604 'custnum' => $self->custnum,
605 'username' => $self->username,
606 'password' => $self->_password,
607 'first' => $cust_main->first,
608 'last' => $cust_main->getfield('last'),
609 'pkg' => $cust_pkg->part_pkg->pkg,
611 my $wqueue = new FS::queue {
612 'svcnum' => $self->svcnum,
613 'job' => 'FS::svc_acct::send_email'
615 my $error = $wqueue->insert(
617 'from' => $welcome_from,
618 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
619 'mimetype' => $welcome_mimetype,
620 'body' => $welcome_template->fill_in( HASH => \%hash, ),
623 $dbh->rollback if $oldAutoCommit;
624 return "error queuing welcome email: $error";
627 if ( $options{'depend_jobnum'} ) {
628 warn "$me depend_jobnum found; adding to welcome email dependancies"
630 if ( ref($options{'depend_jobnum'}) ) {
631 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
632 "to welcome email dependancies"
634 push @jobnums, @{ $options{'depend_jobnum'} };
636 warn "$me adding job $options{'depend_jobnum'} ".
637 "to welcome email dependancies"
639 push @jobnums, $options{'depend_jobnum'};
643 foreach my $jobnum ( @jobnums ) {
644 my $error = $wqueue->depend_insert($jobnum);
646 $dbh->rollback if $oldAutoCommit;
647 return "error queuing welcome email job dependancy: $error";
657 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
661 # set usage fields and thresholds if unset but set in a package def
662 sub preinsert_hook_first {
665 return '' unless $self->pkgnum;
667 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
668 my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
669 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
671 my %values = $part_pkg->usage_valuehash;
672 my $multiplier = $conf->exists('svc_acct-usage_threshold')
673 ? 1 - $conf->config('svc_acct-usage_threshold')/100
674 : 0.20; #doesn't matter
676 foreach ( keys %values ) {
677 next if $self->getfield($_);
678 $self->setfield( $_, $values{$_} );
679 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
680 if $conf->exists('svc_acct-usage_threshold');
688 Deletes this account from the database. If there is an error, returns the
689 error, otherwise returns false.
691 The corresponding FS::cust_svc record will be deleted as well.
693 (TODOC: new exports!)
700 return "can't delete system account" if $self->_check_system;
702 return "Can't delete an account which is a (svc_forward) source!"
703 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
705 return "Can't delete an account which is a (svc_forward) destination!"
706 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
708 return "Can't delete an account with (svc_www) web service!"
709 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
711 # what about records in session ? (they should refer to history table)
713 local $SIG{HUP} = 'IGNORE';
714 local $SIG{INT} = 'IGNORE';
715 local $SIG{QUIT} = 'IGNORE';
716 local $SIG{TERM} = 'IGNORE';
717 local $SIG{TSTP} = 'IGNORE';
718 local $SIG{PIPE} = 'IGNORE';
720 my $oldAutoCommit = $FS::UID::AutoCommit;
721 local $FS::UID::AutoCommit = 0;
724 foreach my $cust_main_invoice (
725 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
727 unless ( defined($cust_main_invoice) ) {
728 warn "WARNING: something's wrong with qsearch";
731 my %hash = $cust_main_invoice->hash;
732 $hash{'dest'} = $self->email;
733 my $new = new FS::cust_main_invoice \%hash;
734 my $error = $new->replace($cust_main_invoice);
736 $dbh->rollback if $oldAutoCommit;
741 foreach my $svc_domain (
742 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
744 my %hash = new FS::svc_domain->hash;
745 $hash{'catchall'} = '';
746 my $new = new FS::svc_domain \%hash;
747 my $error = $new->replace($svc_domain);
749 $dbh->rollback if $oldAutoCommit;
754 my $error = $self->SUPER::delete;
756 $dbh->rollback if $oldAutoCommit;
760 foreach my $radius_usergroup (
761 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
763 my $error = $radius_usergroup->delete;
765 $dbh->rollback if $oldAutoCommit;
770 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
774 =item replace OLD_RECORD
776 Replaces OLD_RECORD with this one in the database. If there is an error,
777 returns the error, otherwise returns false.
779 The additional field I<usergroup> can optionally be defined; if so it should
780 contain an arrayref of group names. See L<FS::radius_usergroup>.
788 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
792 warn "$me replacing $old with $new\n" if $DEBUG;
796 return "can't modify system account" if $old->_check_system;
799 #no warnings 'numeric'; #alas, a 5.006-ism
802 foreach my $xid (qw( uid gid )) {
804 return "Can't change $xid!"
805 if ! $conf->exists("svc_acct-edit_$xid")
806 && $old->$xid() != $new->$xid()
807 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
812 #change homdir when we change username
813 $new->setfield('dir', '') if $old->username ne $new->username;
815 local $SIG{HUP} = 'IGNORE';
816 local $SIG{INT} = 'IGNORE';
817 local $SIG{QUIT} = 'IGNORE';
818 local $SIG{TERM} = 'IGNORE';
819 local $SIG{TSTP} = 'IGNORE';
820 local $SIG{PIPE} = 'IGNORE';
822 my $oldAutoCommit = $FS::UID::AutoCommit;
823 local $FS::UID::AutoCommit = 0;
826 # redundant, but so $new->usergroup gets set
827 $error = $new->check;
828 return $error if $error;
830 $old->usergroup( [ $old->radius_groups ] );
832 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
833 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
835 if ( $new->usergroup ) {
836 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
837 my @newgroups = @{$new->usergroup};
838 foreach my $oldgroup ( @{$old->usergroup} ) {
839 if ( grep { $oldgroup eq $_ } @newgroups ) {
840 @newgroups = grep { $oldgroup ne $_ } @newgroups;
843 my $radius_usergroup = qsearchs('radius_usergroup', {
844 svcnum => $old->svcnum,
845 groupname => $oldgroup,
847 my $error = $radius_usergroup->delete;
849 $dbh->rollback if $oldAutoCommit;
850 return "error deleting radius_usergroup $oldgroup: $error";
854 foreach my $newgroup ( @newgroups ) {
855 my $radius_usergroup = new FS::radius_usergroup ( {
856 svcnum => $new->svcnum,
857 groupname => $newgroup,
859 my $error = $radius_usergroup->insert;
861 $dbh->rollback if $oldAutoCommit;
862 return "error adding radius_usergroup $newgroup: $error";
868 $error = $new->SUPER::replace($old, @_);
870 $dbh->rollback if $oldAutoCommit;
871 return $error if $error;
874 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
875 $error = $new->queue_fuzzyfiles_update;
877 $dbh->rollback if $oldAutoCommit;
878 return "updating fuzzy search cache: $error";
882 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
886 =item queue_fuzzyfiles_update
888 Used by insert & replace to update the fuzzy search cache
892 sub queue_fuzzyfiles_update {
895 local $SIG{HUP} = 'IGNORE';
896 local $SIG{INT} = 'IGNORE';
897 local $SIG{QUIT} = 'IGNORE';
898 local $SIG{TERM} = 'IGNORE';
899 local $SIG{TSTP} = 'IGNORE';
900 local $SIG{PIPE} = 'IGNORE';
902 my $oldAutoCommit = $FS::UID::AutoCommit;
903 local $FS::UID::AutoCommit = 0;
906 my $queue = new FS::queue {
907 'svcnum' => $self->svcnum,
908 'job' => 'FS::svc_acct::append_fuzzyfiles'
910 my $error = $queue->insert($self->username);
912 $dbh->rollback if $oldAutoCommit;
913 return "queueing job (transaction rolled back): $error";
916 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
924 Suspends this account by calling export-specific suspend hooks. If there is
925 an error, returns the error, otherwise returns false.
927 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
933 return "can't suspend system account" if $self->_check_system;
934 $self->SUPER::suspend(@_);
939 Unsuspends this account by by calling export-specific suspend hooks. If there
940 is an error, returns the error, otherwise returns false.
942 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
948 my %hash = $self->hash;
949 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
950 $hash{_password} = $1;
951 my $new = new FS::svc_acct ( \%hash );
952 my $error = $new->replace($self);
953 return $error if $error;
956 $self->SUPER::unsuspend(@_);
961 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
963 If the B<auto_unset_catchall> configuration option is set, this method will
964 automatically remove any references to the canceled service in the catchall
965 field of svc_domain. This allows packages that contain both a svc_domain and
966 its catchall svc_acct to be canceled in one step.
971 # Only one thing to do at this level
973 foreach my $svc_domain (
974 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
975 if($conf->exists('auto_unset_catchall')) {
976 my %hash = $svc_domain->hash;
977 $hash{catchall} = '';
978 my $new = new FS::svc_domain ( \%hash );
979 my $error = $new->replace($svc_domain);
980 return $error if $error;
982 return "cannot unprovision svc_acct #".$self->svcnum.
983 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
987 $self->SUPER::cancel(@_);
993 Checks all fields to make sure this is a valid service. If there is an error,
994 returns the error, otherwise returns false. Called by the insert and replace
997 Sets any fixed values; see L<FS::part_svc>.
1004 my($recref) = $self->hashref;
1006 my $x = $self->setfixed( $self->_fieldhandlers );
1007 return $x unless ref($x);
1010 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1012 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1015 my $error = $self->ut_numbern('svcnum')
1016 #|| $self->ut_number('domsvc')
1017 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1018 || $self->ut_textn('sec_phrase')
1019 || $self->ut_snumbern('seconds')
1020 || $self->ut_snumbern('upbytes')
1021 || $self->ut_snumbern('downbytes')
1022 || $self->ut_snumbern('totalbytes')
1023 || $self->ut_enum( '_password_encoding',
1024 [ '', qw( plain crypt ldap ) ]
1027 return $error if $error;
1030 local $username_letter = $username_letter;
1031 if ($self->svcnum) {
1032 my $cust_svc = $self->cust_svc
1033 or return "no cust_svc record found for svcnum ". $self->svcnum;
1034 my $cust_pkg = $cust_svc->cust_pkg;
1036 if ($self->pkgnum) {
1037 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1041 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1044 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1045 if ( $username_uppercase ) {
1046 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1047 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1048 $recref->{username} = $1;
1050 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1051 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1052 $recref->{username} = $1;
1055 if ( $username_letterfirst ) {
1056 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1057 } elsif ( $username_letter ) {
1058 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1060 if ( $username_noperiod ) {
1061 $recref->{username} =~ /\./ and return gettext('illegal_username');
1063 if ( $username_nounderscore ) {
1064 $recref->{username} =~ /_/ and return gettext('illegal_username');
1066 if ( $username_nodash ) {
1067 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1069 unless ( $username_ampersand ) {
1070 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1072 unless ( $username_percent ) {
1073 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1075 unless ( $username_colon ) {
1076 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1079 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1080 $recref->{popnum} = $1;
1081 return "Unknown popnum" unless
1082 ! $recref->{popnum} ||
1083 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1085 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1087 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1088 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1090 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1091 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1092 #not all systems use gid=uid
1093 #you can set a fixed gid in part_svc
1095 return "Only root can have uid 0"
1096 if $recref->{uid} == 0
1097 && $recref->{username} !~ /^(root|toor|smtp)$/;
1099 unless ( $recref->{username} eq 'sync' ) {
1100 if ( grep $_ eq $recref->{shell}, @shells ) {
1101 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1103 return "Illegal shell \`". $self->shell. "\'; ".
1104 "shells configuration value contains: @shells";
1107 $recref->{shell} = '/bin/sync';
1111 $recref->{gid} ne '' ?
1112 return "Can't have gid without uid" : ( $recref->{gid}='' );
1113 #$recref->{dir} ne '' ?
1114 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1115 $recref->{shell} ne '' ?
1116 return "Can't have shell without uid" : ( $recref->{shell}='' );
1119 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1121 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1122 or return "Illegal directory: ". $recref->{dir};
1123 $recref->{dir} = $1;
1124 return "Illegal directory"
1125 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1126 return "Illegal directory"
1127 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1128 unless ( $recref->{dir} ) {
1129 $recref->{dir} = $dir_prefix . '/';
1130 if ( $dirhash > 0 ) {
1131 for my $h ( 1 .. $dirhash ) {
1132 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1134 } elsif ( $dirhash < 0 ) {
1135 for my $h ( reverse $dirhash .. -1 ) {
1136 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1139 $recref->{dir} .= $recref->{username};
1145 # $error = $self->ut_textn('finger');
1146 # return $error if $error;
1147 if ( $self->getfield('finger') eq '' ) {
1148 my $cust_pkg = $self->svcnum
1149 ? $self->cust_svc->cust_pkg
1150 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1152 my $cust_main = $cust_pkg->cust_main;
1153 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1156 $self->getfield('finger') =~
1157 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1158 or return "Illegal finger: ". $self->getfield('finger');
1159 $self->setfield('finger', $1);
1161 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1162 $recref->{quota} = $1;
1164 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1165 if ( $recref->{slipip} eq '' ) {
1166 $recref->{slipip} = '';
1167 } elsif ( $recref->{slipip} eq '0e0' ) {
1168 $recref->{slipip} = '0e0';
1170 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1171 or return "Illegal slipip: ". $self->slipip;
1172 $recref->{slipip} = $1;
1177 #arbitrary RADIUS stuff; allow ut_textn for now
1178 foreach ( grep /^radius_/, fields('svc_acct') ) {
1179 $self->ut_textn($_);
1182 if ( $recref->{_password_encoding} eq 'ldap' ) {
1184 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1185 $recref->{_password} = uc($1).$2;
1187 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1190 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1192 if ( $recref->{_password} =~
1193 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1194 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1197 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1200 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1203 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1205 #generate a password if it is blank
1206 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1207 unless length( $recref->{_password} );
1209 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1210 $recref->{_password} = $1;
1212 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1213 FS::Msgcat::_gettext('illegal_password_characters').
1214 ": ". $recref->{_password};
1217 if ( $password_noampersand ) {
1218 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1220 if ( $password_noexclamation ) {
1221 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1226 #carp "warning: _password_encoding unspecified\n";
1228 #generate a password if it is blank
1229 unless ( length($recref->{_password}) || ! $passwordmin ) {
1231 $recref->{_password} =
1232 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1233 $recref->{_password_encoding} = 'plain';
1237 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1238 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1239 $recref->{_password} = $1.$3;
1240 $recref->{_password_encoding} = 'plain';
1241 } elsif ( $recref->{_password} =~
1242 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1244 $recref->{_password} = $1.$3;
1245 $recref->{_password_encoding} = 'crypt';
1246 } elsif ( $recref->{_password} eq '*' ) {
1247 $recref->{_password} = '*';
1248 $recref->{_password_encoding} = 'crypt';
1249 } elsif ( $recref->{_password} eq '!' ) {
1250 $recref->{_password_encoding} = 'crypt';
1251 $recref->{_password} = '!';
1252 } elsif ( $recref->{_password} eq '!!' ) {
1253 $recref->{_password} = '!!';
1254 $recref->{_password_encoding} = 'crypt';
1256 #return "Illegal password";
1257 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1258 FS::Msgcat::_gettext('illegal_password_characters').
1259 ": ". $recref->{_password};
1266 $self->SUPER::check;
1272 Internal function to check the username against the list of system usernames
1273 from the I<system_usernames> configuration value. Returns true if the username
1274 is listed on the system username list.
1280 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1281 $conf->config('system_usernames')
1285 =item _check_duplicate
1287 Internal method to check for duplicates usernames, username@domain pairs and
1290 If the I<global_unique-username> configuration value is set to B<username> or
1291 B<username@domain>, enforces global username or username@domain uniqueness.
1293 In all cases, check for duplicate uids and usernames or username@domain pairs
1294 per export and with identical I<svcpart> values.
1298 sub _check_duplicate {
1301 my $global_unique = $conf->config('global_unique-username') || 'none';
1302 return '' if $global_unique eq 'disabled';
1306 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1307 unless ( $part_svc ) {
1308 return 'unknown svcpart '. $self->svcpart;
1311 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1312 qsearch( 'svc_acct', { 'username' => $self->username } );
1313 return gettext('username_in_use')
1314 if $global_unique eq 'username' && @dup_user;
1316 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1317 qsearch( 'svc_acct', { 'username' => $self->username,
1318 'domsvc' => $self->domsvc } );
1319 return gettext('username_in_use')
1320 if $global_unique eq 'username@domain' && @dup_userdomain;
1323 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1324 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1325 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1326 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1331 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1332 my $exports = FS::part_export::export_info('svc_acct');
1333 my %conflict_user_svcpart;
1334 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1336 foreach my $part_export ( $part_svc->part_export ) {
1338 #this will catch to the same exact export
1339 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1341 #this will catch to exports w/same exporthost+type ???
1342 #my @other_part_export = qsearch('part_export', {
1343 # 'machine' => $part_export->machine,
1344 # 'exporttype' => $part_export->exporttype,
1346 #foreach my $other_part_export ( @other_part_export ) {
1347 # push @svcparts, map { $_->svcpart }
1348 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1351 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1352 #silly kludge to avoid uninitialized value errors
1353 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1354 ? $exports->{$part_export->exporttype}{'nodomain'}
1356 if ( $nodomain =~ /^Y/i ) {
1357 $conflict_user_svcpart{$_} = $part_export->exportnum
1360 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1365 foreach my $dup_user ( @dup_user ) {
1366 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1367 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1368 return "duplicate username ". $self->username.
1369 ": conflicts with svcnum ". $dup_user->svcnum.
1370 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1374 foreach my $dup_userdomain ( @dup_userdomain ) {
1375 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1376 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1377 return "duplicate username\@domain ". $self->email.
1378 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1379 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1383 foreach my $dup_uid ( @dup_uid ) {
1384 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1385 if ( exists($conflict_user_svcpart{$dup_svcpart})
1386 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1387 return "duplicate uid ". $self->uid.
1388 ": conflicts with svcnum ". $dup_uid->svcnum.
1390 ( $conflict_user_svcpart{$dup_svcpart}
1391 || $conflict_userdomain_svcpart{$dup_svcpart} );
1403 Depriciated, use radius_reply instead.
1408 carp "FS::svc_acct::radius depriciated, use radius_reply";
1409 $_[0]->radius_reply;
1414 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1415 reply attributes of this record.
1417 Note that this is now the preferred method for reading RADIUS attributes -
1418 accessing the columns directly is discouraged, as the column names are
1419 expected to change in the future.
1426 return %{ $self->{'radius_reply'} }
1427 if exists $self->{'radius_reply'};
1432 my($column, $attrib) = ($1, $2);
1433 #$attrib =~ s/_/\-/g;
1434 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1435 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1437 if ( $self->slipip && $self->slipip ne '0e0' ) {
1438 $reply{$radius_ip} = $self->slipip;
1441 if ( $self->seconds !~ /^$/ ) {
1442 $reply{'Session-Timeout'} = $self->seconds;
1445 if ( $conf->exists('radius-chillispot-max') ) {
1446 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1448 #hmm. just because sqlradius.pm says so?
1455 foreach my $what (qw( input output total )) {
1456 my $is = $whatis{$what}.'bytes';
1457 if ( $self->$is() =~ /\d/ ) {
1458 my $big = new Math::BigInt $self->$is();
1459 $big = new Math::BigInt '0' if $big->is_neg();
1460 my $att = "Chillispot-Max-\u$what";
1461 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1462 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1473 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1474 check attributes of this record.
1476 Note that this is now the preferred method for reading RADIUS attributes -
1477 accessing the columns directly is discouraged, as the column names are
1478 expected to change in the future.
1485 return %{ $self->{'radius_check'} }
1486 if exists $self->{'radius_check'};
1491 my($column, $attrib) = ($1, $2);
1492 #$attrib =~ s/_/\-/g;
1493 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1494 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1497 my($pw_attrib, $password) = $self->radius_password;
1498 $check{$pw_attrib} = $password;
1500 my $cust_svc = $self->cust_svc;
1502 my $cust_pkg = $cust_svc->cust_pkg;
1503 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1504 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1507 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1508 "; can't set Expiration\n"
1516 =item radius_password
1518 Returns a key/value pair containing the RADIUS attribute name and value
1523 sub radius_password {
1526 my($pw_attrib, $password);
1527 if ( $self->_password_encoding eq 'ldap' ) {
1529 $pw_attrib = 'Password-With-Header';
1530 $password = $self->_password;
1532 } elsif ( $self->_password_encoding eq 'crypt' ) {
1534 $pw_attrib = 'Crypt-Password';
1535 $password = $self->_password;
1537 } elsif ( $self->_password_encoding eq 'plain' ) {
1539 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1540 $password = $self->_password;
1544 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1545 $password = $self->_password;
1549 ($pw_attrib, $password);
1555 This method instructs the object to "snapshot" or freeze RADIUS check and
1556 reply attributes to the current values.
1560 #bah, my english is too broken this morning
1561 #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
1562 #the FS::cust_pkg's replace method to trigger the correct export updates when
1563 #package dates change)
1568 $self->{$_} = { $self->$_() }
1569 foreach qw( radius_reply radius_check );
1573 =item forget_snapshot
1575 This methos instructs the object to forget any previously snapshotted
1576 RADIUS check and reply attributes.
1580 sub forget_snapshot {
1584 foreach qw( radius_reply radius_check );
1588 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1590 Returns the domain associated with this account.
1592 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1599 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1600 my $svc_domain = $self->svc_domain(@_)
1601 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1602 $svc_domain->domain;
1607 Returns the FS::svc_domain record for this account's domain (see
1612 # FS::h_svc_acct has a history-aware svc_domain override
1617 ? $self->{'_domsvc'}
1618 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1623 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1627 #inherited from svc_Common
1629 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1631 Returns an email address associated with the account.
1633 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1640 $self->username. '@'. $self->domain(@_);
1645 Returns an array of FS::acct_snarf records associated with the account.
1646 If the acct_snarf table does not exist or there are no associated records,
1647 an empty list is returned
1653 return () unless dbdef->table('acct_snarf');
1654 eval "use FS::acct_snarf;";
1656 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1659 =item decrement_upbytes OCTETS
1661 Decrements the I<upbytes> field of this record by the given amount. If there
1662 is an error, returns the error, otherwise returns false.
1666 sub decrement_upbytes {
1667 shift->_op_usage('-', 'upbytes', @_);
1670 =item increment_upbytes OCTETS
1672 Increments the I<upbytes> field of this record by the given amount. If there
1673 is an error, returns the error, otherwise returns false.
1677 sub increment_upbytes {
1678 shift->_op_usage('+', 'upbytes', @_);
1681 =item decrement_downbytes OCTETS
1683 Decrements the I<downbytes> field of this record by the given amount. If there
1684 is an error, returns the error, otherwise returns false.
1688 sub decrement_downbytes {
1689 shift->_op_usage('-', 'downbytes', @_);
1692 =item increment_downbytes OCTETS
1694 Increments the I<downbytes> field of this record by the given amount. If there
1695 is an error, returns the error, otherwise returns false.
1699 sub increment_downbytes {
1700 shift->_op_usage('+', 'downbytes', @_);
1703 =item decrement_totalbytes OCTETS
1705 Decrements the I<totalbytes> field of this record by the given amount. If there
1706 is an error, returns the error, otherwise returns false.
1710 sub decrement_totalbytes {
1711 shift->_op_usage('-', 'totalbytes', @_);
1714 =item increment_totalbytes OCTETS
1716 Increments the I<totalbytes> field of this record by the given amount. If there
1717 is an error, returns the error, otherwise returns false.
1721 sub increment_totalbytes {
1722 shift->_op_usage('+', 'totalbytes', @_);
1725 =item decrement_seconds SECONDS
1727 Decrements the I<seconds> field of this record by the given amount. If there
1728 is an error, returns the error, otherwise returns false.
1732 sub decrement_seconds {
1733 shift->_op_usage('-', 'seconds', @_);
1736 =item increment_seconds SECONDS
1738 Increments the I<seconds> field of this record by the given amount. If there
1739 is an error, returns the error, otherwise returns false.
1743 sub increment_seconds {
1744 shift->_op_usage('+', 'seconds', @_);
1752 my %op2condition = (
1753 '-' => sub { my($self, $column, $amount) = @_;
1754 $self->$column - $amount <= 0;
1756 '+' => sub { my($self, $column, $amount) = @_;
1757 ($self->$column || 0) + $amount > 0;
1760 my %op2warncondition = (
1761 '-' => sub { my($self, $column, $amount) = @_;
1762 my $threshold = $column . '_threshold';
1763 $self->$column - $amount <= $self->$threshold + 0;
1765 '+' => sub { my($self, $column, $amount) = @_;
1766 ($self->$column || 0) + $amount > 0;
1771 my( $self, $op, $column, $amount ) = @_;
1773 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1774 ' ('. $self->email. "): $op $amount\n"
1777 return '' unless $amount;
1779 local $SIG{HUP} = 'IGNORE';
1780 local $SIG{INT} = 'IGNORE';
1781 local $SIG{QUIT} = 'IGNORE';
1782 local $SIG{TERM} = 'IGNORE';
1783 local $SIG{TSTP} = 'IGNORE';
1784 local $SIG{PIPE} = 'IGNORE';
1786 my $oldAutoCommit = $FS::UID::AutoCommit;
1787 local $FS::UID::AutoCommit = 0;
1790 my $sql = "UPDATE svc_acct SET $column = ".
1791 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1792 " $op ? WHERE svcnum = ?";
1796 my $sth = $dbh->prepare( $sql )
1797 or die "Error preparing $sql: ". $dbh->errstr;
1798 my $rv = $sth->execute($amount, $self->svcnum);
1799 die "Error executing $sql: ". $sth->errstr
1800 unless defined($rv);
1801 die "Can't update $column for svcnum". $self->svcnum
1804 #$self->snapshot; #not necessary, we retain the old values
1805 #create an object with the updated usage values
1806 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1808 my $error = $new->replace($self);
1810 $dbh->rollback if $oldAutoCommit;
1811 return "Error replacing: $error";
1814 #overlimit_action eq 'cancel' handling
1815 my $cust_pkg = $self->cust_svc->cust_pkg;
1817 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1818 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1822 my $error = $cust_pkg->cancel; #XXX should have a reason
1824 $dbh->rollback if $oldAutoCommit;
1825 return "Error cancelling: $error";
1828 #nothing else is relevant if we're cancelling, so commit & return success
1829 warn "$me update successful; committing\n"
1831 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1836 my $action = $op2action{$op};
1838 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1839 ( $action eq 'suspend' && !$self->overlimit
1840 || $action eq 'unsuspend' && $self->overlimit )
1842 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1843 if ($part_export->option('overlimit_groups')) {
1845 my $other = new FS::svc_acct $self->hashref;
1846 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1847 ($self, $part_export->option('overlimit_groups'));
1848 $other->usergroup( $groups );
1849 if ($action eq 'suspend'){
1850 $new = $other; $old = $self;
1852 $new = $self; $old = $other;
1854 my $error = $part_export->export_replace($new, $old);
1855 $error ||= $self->overlimit($action);
1857 $dbh->rollback if $oldAutoCommit;
1858 return "Error replacing radius groups in export, ${op}: $error";
1864 if ( $conf->exists("svc_acct-usage_$action")
1865 && &{$op2condition{$op}}($self, $column, $amount) ) {
1866 #my $error = $self->$action();
1867 my $error = $self->cust_svc->cust_pkg->$action();
1868 # $error ||= $self->overlimit($action);
1870 $dbh->rollback if $oldAutoCommit;
1871 return "Error ${action}ing: $error";
1875 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1876 my $wqueue = new FS::queue {
1877 'svcnum' => $self->svcnum,
1878 'job' => 'FS::svc_acct::reached_threshold',
1883 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1887 my $error = $wqueue->insert(
1888 'svcnum' => $self->svcnum,
1890 'column' => $column,
1894 $dbh->rollback if $oldAutoCommit;
1895 return "Error queuing threshold activity: $error";
1899 warn "$me update successful; committing\n"
1901 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1907 my( $self, $valueref, %options ) = @_;
1909 warn "$me set_usage called for svcnum ". $self->svcnum.
1910 ' ('. $self->email. "): ".
1911 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1914 local $SIG{HUP} = 'IGNORE';
1915 local $SIG{INT} = 'IGNORE';
1916 local $SIG{QUIT} = 'IGNORE';
1917 local $SIG{TERM} = 'IGNORE';
1918 local $SIG{TSTP} = 'IGNORE';
1919 local $SIG{PIPE} = 'IGNORE';
1921 local $FS::svc_Common::noexport_hack = 1;
1922 my $oldAutoCommit = $FS::UID::AutoCommit;
1923 local $FS::UID::AutoCommit = 0;
1928 if ( $options{null} ) {
1929 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1930 qw( seconds upbytes downbytes totalbytes )
1933 foreach my $field (keys %$valueref){
1934 $reset = 1 if $valueref->{$field};
1935 $self->setfield($field, $valueref->{$field});
1936 $self->setfield( $field.'_threshold',
1937 int($self->getfield($field)
1938 * ( $conf->exists('svc_acct-usage_threshold')
1939 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1944 $handyhash{$field} = $self->getfield($field);
1945 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1947 #my $error = $self->replace; #NO! we avoid the call to ->check for
1948 #die $error if $error; #services not explicity changed via the UI
1950 my $sql = "UPDATE svc_acct SET " .
1951 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
1952 " WHERE svcnum = ". $self->svcnum;
1957 if (scalar(keys %handyhash)) {
1958 my $sth = $dbh->prepare( $sql )
1959 or die "Error preparing $sql: ". $dbh->errstr;
1960 my $rv = $sth->execute();
1961 die "Error executing $sql: ". $sth->errstr
1962 unless defined($rv);
1963 die "Can't update usage for svcnum ". $self->svcnum
1967 #$self->snapshot; #not necessary, we retain the old values
1968 #create an object with the updated usage values
1969 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1971 my $error = $new->replace($self);
1973 $dbh->rollback if $oldAutoCommit;
1974 return "Error replacing: $error";
1980 if ($self->overlimit) {
1981 $error = $self->overlimit('unsuspend');
1982 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1983 if ($part_export->option('overlimit_groups')) {
1984 my $old = new FS::svc_acct $self->hashref;
1985 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1986 ($self, $part_export->option('overlimit_groups'));
1987 $old->usergroup( $groups );
1988 $error ||= $part_export->export_replace($self, $old);
1993 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1994 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1997 $dbh->rollback if $oldAutoCommit;
1998 return "Error unsuspending: $error";
2002 warn "$me update successful; committing\n"
2004 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2010 =item recharge HASHREF
2012 Increments usage columns by the amount specified in HASHREF as
2013 column=>amount pairs.
2018 my ($self, $vhash) = @_;
2021 warn "[$me] recharge called on $self: ". Dumper($self).
2022 "\nwith vhash: ". Dumper($vhash);
2025 my $oldAutoCommit = $FS::UID::AutoCommit;
2026 local $FS::UID::AutoCommit = 0;
2030 foreach my $column (keys %$vhash){
2031 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2035 $dbh->rollback if $oldAutoCommit;
2037 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2042 =item is_rechargeable
2044 Returns true if this svc_account can be "recharged" and false otherwise.
2048 sub is_rechargable {
2050 $self->seconds ne ''
2051 || $self->upbytes ne ''
2052 || $self->downbytes ne ''
2053 || $self->totalbytes ne '';
2056 =item seconds_since TIMESTAMP
2058 Returns the number of seconds this account has been online since TIMESTAMP,
2059 according to the session monitor (see L<FS::Session>).
2061 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2062 L<Time::Local> and L<Date::Parse> for conversion functions.
2066 #note: POD here, implementation in FS::cust_svc
2069 $self->cust_svc->seconds_since(@_);
2072 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2074 Returns the numbers of seconds this account has been online between
2075 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2076 external SQL radacct table, specified via sqlradius export. Sessions which
2077 started in the specified range but are still open are counted from session
2078 start to the end of the range (unless they are over 1 day old, in which case
2079 they are presumed missing their stop record and not counted). Also, sessions
2080 which end in the range but started earlier are counted from the start of the
2081 range to session end. Finally, sessions which start before the range but end
2082 after are counted for the entire range.
2084 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2085 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2090 #note: POD here, implementation in FS::cust_svc
2091 sub seconds_since_sqlradacct {
2093 $self->cust_svc->seconds_since_sqlradacct(@_);
2096 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2098 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2099 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2100 TIMESTAMP_END (exclusive).
2102 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2103 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2108 #note: POD here, implementation in FS::cust_svc
2109 sub attribute_since_sqlradacct {
2111 $self->cust_svc->attribute_since_sqlradacct(@_);
2114 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2116 Returns an array of hash references of this customers login history for the
2117 given time range. (document this better)
2121 sub get_session_history {
2123 $self->cust_svc->get_session_history(@_);
2126 =item last_login_text
2128 Returns text describing the time of last login.
2132 sub last_login_text {
2134 $self->last_login ? ctime($self->last_login) : 'unknown';
2137 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2142 my($self, $start, $end, %opt ) = @_;
2144 my $did = $self->username; #yup
2146 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2148 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2150 #SELECT $for_update * FROM cdr
2151 # WHERE calldate >= $start #need a conversion
2152 # AND calldate < $end #ditto
2153 # AND ( charged_party = "$did"
2154 # OR charged_party = "$prefix$did" #if length($prefix);
2155 # OR ( ( charged_party IS NULL OR charged_party = '' )
2157 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2160 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2163 if ( length($prefix) ) {
2165 " AND ( charged_party = '$did'
2166 OR charged_party = '$prefix$did'
2167 OR ( ( charged_party IS NULL OR charged_party = '' )
2169 ( src = '$did' OR src = '$prefix$did' )
2175 " AND ( charged_party = '$did'
2176 OR ( ( charged_party IS NULL OR charged_party = '' )
2186 'select' => "$for_update *",
2189 #( freesidestatus IS NULL OR freesidestatus = '' )
2190 'freesidestatus' => '',
2192 'extra_sql' => $charged_or_src,
2200 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2206 if ( $self->usergroup ) {
2207 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2208 unless ref($self->usergroup) eq 'ARRAY';
2209 #when provisioning records, export callback runs in svc_Common.pm before
2210 #radius_usergroup records can be inserted...
2211 @{$self->usergroup};
2213 map { $_->groupname }
2214 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2218 =item clone_suspended
2220 Constructor used by FS::part_export::_export_suspend fallback. Document
2225 sub clone_suspended {
2227 my %hash = $self->hash;
2228 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2229 new FS::svc_acct \%hash;
2232 =item clone_kludge_unsuspend
2234 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2239 sub clone_kludge_unsuspend {
2241 my %hash = $self->hash;
2242 $hash{_password} = '';
2243 new FS::svc_acct \%hash;
2246 =item check_password
2248 Checks the supplied password against the (possibly encrypted) password in the
2249 database. Returns true for a successful authentication, false for no match.
2251 Currently supported encryptions are: classic DES crypt() and MD5
2255 sub check_password {
2256 my($self, $check_password) = @_;
2258 #remove old-style SUSPENDED kludge, they should be allowed to login to
2259 #self-service and pay up
2260 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2262 if ( $self->_password_encoding eq 'ldap' ) {
2264 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2265 return $auth->match($check_password);
2267 } elsif ( $self->_password_encoding eq 'crypt' ) {
2269 my $auth = from_crypt Authen::Passphrase $self->_password;
2270 return $auth->match($check_password);
2272 } elsif ( $self->_password_encoding eq 'plain' ) {
2274 return $check_password eq $password;
2278 #XXX this could be replaced with Authen::Passphrase stuff
2280 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2282 } elsif ( length($password) < 13 ) { #plaintext
2283 $check_password eq $password;
2284 } elsif ( length($password) == 13 ) { #traditional DES crypt
2285 crypt($check_password, $password) eq $password;
2286 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2287 unix_md5_crypt($check_password, $password) eq $password;
2288 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2289 warn "Can't check password: Blowfish encryption not yet supported, ".
2290 "svcnum ". $self->svcnum. "\n";
2293 warn "Can't check password: Unrecognized encryption for svcnum ".
2294 $self->svcnum. "\n";
2302 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2304 Returns an encrypted password, either by passing through an encrypted password
2305 in the database or by encrypting a plaintext password from the database.
2307 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2308 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2309 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2310 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2311 encryption type is only used if the password is not already encrypted in the
2316 sub crypt_password {
2319 if ( $self->_password_encoding eq 'ldap' ) {
2321 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2324 #XXX this could be replaced with Authen::Passphrase stuff
2326 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2327 if ( $encryption eq 'crypt' ) {
2330 $saltset[int(rand(64))].$saltset[int(rand(64))]
2332 } elsif ( $encryption eq 'md5' ) {
2333 unix_md5_crypt( $self->_password );
2334 } elsif ( $encryption eq 'blowfish' ) {
2335 croak "unknown encryption method $encryption";
2337 croak "unknown encryption method $encryption";
2340 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2344 } elsif ( $self->_password_encoding eq 'crypt' ) {
2346 return $self->_password;
2348 } elsif ( $self->_password_encoding eq 'plain' ) {
2350 #XXX this could be replaced with Authen::Passphrase stuff
2352 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2353 if ( $encryption eq 'crypt' ) {
2356 $saltset[int(rand(64))].$saltset[int(rand(64))]
2358 } elsif ( $encryption eq 'md5' ) {
2359 unix_md5_crypt( $self->_password );
2360 } elsif ( $encryption eq 'blowfish' ) {
2361 croak "unknown encryption method $encryption";
2363 croak "unknown encryption method $encryption";
2368 if ( length($self->_password) == 13
2369 || $self->_password =~ /^\$(1|2a?)\$/
2370 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2376 #XXX this could be replaced with Authen::Passphrase stuff
2378 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2379 if ( $encryption eq 'crypt' ) {
2382 $saltset[int(rand(64))].$saltset[int(rand(64))]
2384 } elsif ( $encryption eq 'md5' ) {
2385 unix_md5_crypt( $self->_password );
2386 } elsif ( $encryption eq 'blowfish' ) {
2387 croak "unknown encryption method $encryption";
2389 croak "unknown encryption method $encryption";
2398 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2400 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2401 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2402 "{MD5}5426824942db4253f87a1009fd5d2d4".
2404 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2405 to work the same as the B</crypt_password> method.
2411 #eventually should check a "password-encoding" field
2413 if ( $self->_password_encoding eq 'ldap' ) {
2415 return $self->_password;
2417 } elsif ( $self->_password_encoding eq 'crypt' ) {
2419 if ( length($self->_password) == 13 ) { #crypt
2420 return '{CRYPT}'. $self->_password;
2421 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2423 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2424 # die "Blowfish encryption not supported in this context, svcnum ".
2425 # $self->svcnum. "\n";
2427 warn "encryption method not (yet?) supported in LDAP context";
2428 return '{CRYPT}*'; #unsupported, should not auth
2431 } elsif ( $self->_password_encoding eq 'plain' ) {
2433 return '{PLAIN}'. $self->_password;
2435 #return '{CLEARTEXT}'. $self->_password; #?
2439 if ( length($self->_password) == 13 ) { #crypt
2440 return '{CRYPT}'. $self->_password;
2441 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2443 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2444 warn "Blowfish encryption not supported in this context, svcnum ".
2445 $self->svcnum. "\n";
2448 #are these two necessary anymore?
2449 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2450 return '{SSHA}'. $1;
2451 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2452 return '{NS-MTA-MD5}'. $1;
2455 return '{PLAIN}'. $self->_password;
2457 #return '{CLEARTEXT}'. $self->_password; #?
2459 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2460 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2461 #if ( $encryption eq 'crypt' ) {
2462 # return '{CRYPT}'. crypt(
2464 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2466 #} elsif ( $encryption eq 'md5' ) {
2467 # unix_md5_crypt( $self->_password );
2468 #} elsif ( $encryption eq 'blowfish' ) {
2469 # croak "unknown encryption method $encryption";
2471 # croak "unknown encryption method $encryption";
2479 =item domain_slash_username
2481 Returns $domain/$username/
2485 sub domain_slash_username {
2487 $self->domain. '/'. $self->username. '/';
2490 =item virtual_maildir
2492 Returns $domain/maildirs/$username/
2496 sub virtual_maildir {
2498 $self->domain. '/maildirs/'. $self->username. '/';
2509 This is the FS::svc_acct job-queue-able version. It still uses
2510 FS::Misc::send_email under-the-hood.
2517 eval "use FS::Misc qw(send_email)";
2520 $opt{mimetype} ||= 'text/plain';
2521 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2523 my $error = send_email(
2524 'from' => $opt{from},
2526 'subject' => $opt{subject},
2527 'content-type' => $opt{mimetype},
2528 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2530 die $error if $error;
2533 =item check_and_rebuild_fuzzyfiles
2537 sub check_and_rebuild_fuzzyfiles {
2538 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2539 -e "$dir/svc_acct.username"
2540 or &rebuild_fuzzyfiles;
2543 =item rebuild_fuzzyfiles
2547 sub rebuild_fuzzyfiles {
2549 use Fcntl qw(:flock);
2551 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2555 open(USERNAMELOCK,">>$dir/svc_acct.username")
2556 or die "can't open $dir/svc_acct.username: $!";
2557 flock(USERNAMELOCK,LOCK_EX)
2558 or die "can't lock $dir/svc_acct.username: $!";
2560 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2562 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2563 or die "can't open $dir/svc_acct.username.tmp: $!";
2564 print USERNAMECACHE join("\n", @all_username), "\n";
2565 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2567 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2577 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2578 open(USERNAMECACHE,"<$dir/svc_acct.username")
2579 or die "can't open $dir/svc_acct.username: $!";
2580 my @array = map { chomp; $_; } <USERNAMECACHE>;
2581 close USERNAMECACHE;
2585 =item append_fuzzyfiles USERNAME
2589 sub append_fuzzyfiles {
2590 my $username = shift;
2592 &check_and_rebuild_fuzzyfiles;
2594 use Fcntl qw(:flock);
2596 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2598 open(USERNAME,">>$dir/svc_acct.username")
2599 or die "can't open $dir/svc_acct.username: $!";
2600 flock(USERNAME,LOCK_EX)
2601 or die "can't lock $dir/svc_acct.username: $!";
2603 print USERNAME "$username\n";
2605 flock(USERNAME,LOCK_UN)
2606 or die "can't unlock $dir/svc_acct.username: $!";
2614 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2618 sub radius_usergroup_selector {
2619 my $sel_groups = shift;
2620 my %sel_groups = map { $_=>1 } @$sel_groups;
2622 my $selectname = shift || 'radius_usergroup';
2625 my $sth = $dbh->prepare(
2626 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2627 ) or die $dbh->errstr;
2628 $sth->execute() or die $sth->errstr;
2629 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2633 function ${selectname}_doadd(object) {
2634 var myvalue = object.${selectname}_add.value;
2635 var optionName = new Option(myvalue,myvalue,false,true);
2636 var length = object.$selectname.length;
2637 object.$selectname.options[length] = optionName;
2638 object.${selectname}_add.value = "";
2641 <SELECT MULTIPLE NAME="$selectname">
2644 foreach my $group ( @all_groups ) {
2645 $html .= qq(<OPTION VALUE="$group");
2646 if ( $sel_groups{$group} ) {
2647 $html .= ' SELECTED';
2648 $sel_groups{$group} = 0;
2650 $html .= ">$group</OPTION>\n";
2652 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2653 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2655 $html .= '</SELECT>';
2657 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2658 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2663 =item reached_threshold
2665 Performs some activities when svc_acct thresholds (such as number of seconds
2666 remaining) are reached.
2670 sub reached_threshold {
2673 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2674 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2676 if ( $opt{'op'} eq '+' ){
2677 $svc_acct->setfield( $opt{'column'}.'_threshold',
2678 int($svc_acct->getfield($opt{'column'})
2679 * ( $conf->exists('svc_acct-usage_threshold')
2680 ? $conf->config('svc_acct-usage_threshold')/100
2685 my $error = $svc_acct->replace;
2686 die $error if $error;
2687 }elsif ( $opt{'op'} eq '-' ){
2689 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2690 return '' if ($threshold eq '' );
2692 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2693 my $error = $svc_acct->replace;
2694 die $error if $error; # email next time, i guess
2696 if ( $warning_template ) {
2697 eval "use FS::Misc qw(send_email)";
2700 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2701 my $cust_main = $cust_pkg->cust_main;
2703 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2704 $cust_main->invoicing_list,
2705 ($opt{'to'} ? $opt{'to'} : ())
2708 my $mimetype = $warning_mimetype;
2709 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2711 my $body = $warning_template->fill_in( HASH => {
2712 'custnum' => $cust_main->custnum,
2713 'username' => $svc_acct->username,
2714 'password' => $svc_acct->_password,
2715 'first' => $cust_main->first,
2716 'last' => $cust_main->getfield('last'),
2717 'pkg' => $cust_pkg->part_pkg->pkg,
2718 'column' => $opt{'column'},
2719 'amount' => $opt{'column'} =~/bytes/
2720 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2721 : $svc_acct->getfield($opt{'column'}),
2722 'threshold' => $opt{'column'} =~/bytes/
2723 ? FS::UI::bytecount::display_bytecount($threshold)
2728 my $error = send_email(
2729 'from' => $warning_from,
2731 'subject' => $warning_subject,
2732 'content-type' => $mimetype,
2733 'body' => [ map "$_\n", split("\n", $body) ],
2735 die $error if $error;
2738 die "unknown op: " . $opt{'op'};
2746 The $recref stuff in sub check should be cleaned up.
2748 The suspend, unsuspend and cancel methods update the database, but not the
2749 current object. This is probably a bug as it's unexpected and
2752 radius_usergroup_selector? putting web ui components in here? they should
2753 probably live somewhere else...
2755 insertion of RADIUS group stuff in insert could be done with child_objects now
2756 (would probably clean up export of them too)
2758 _op_usage and set_usage bypass the history... maybe they shouldn't
2762 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2763 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2764 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2765 L<freeside-queued>), L<FS::svc_acct_pop>,
2766 schema.html from the base documentation.
2770 =item domain_select_hash %OPTIONS
2772 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2773 may at present purchase.
2775 Currently available options are: I<pkgnum> I<svcpart>
2779 sub domain_select_hash {
2780 my ($self, %options) = @_;
2786 $part_svc = $self->part_svc;
2787 $cust_pkg = $self->cust_svc->cust_pkg
2791 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2792 if $options{'svcpart'};
2794 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2795 if $options{'pkgnum'};
2797 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2798 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2799 %domains = map { $_->svcnum => $_->domain }
2800 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2801 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2802 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2803 %domains = map { $_->svcnum => $_->domain }
2804 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2805 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2806 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2808 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2811 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2812 my $svc_domain = qsearchs('svc_domain',
2813 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2814 if ( $svc_domain ) {
2815 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2817 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2818 $part_svc->part_svc_column('domsvc')->columnvalue;