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;
531 my $error = $self->check;
532 return $error if $error;
534 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
535 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
536 unless ( $cust_svc ) {
537 $dbh->rollback if $oldAutoCommit;
538 return "no cust_svc record found for svcnum ". $self->svcnum;
540 $self->pkgnum($cust_svc->pkgnum);
541 $self->svcpart($cust_svc->svcpart);
544 # set usage fields and thresholds if unset but set in a package def
545 if ( $self->pkgnum ) {
546 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
547 my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
548 if ( $part_pkg && $part_pkg->can('usage_valuehash') ) {
550 my %values = $part_pkg->usage_valuehash;
551 my $multiplier = $conf->exists('svc_acct-usage_threshold')
552 ? 1 - $conf->config('svc_acct-usage_threshold')/100
553 : 0.20; #doesn't matter
555 foreach ( keys %values ) {
556 next if $self->getfield($_);
557 $self->setfield( $_, $values{$_} );
558 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
559 if $conf->exists('svc_acct-usage_threshold');
566 $error = $self->SUPER::insert(
567 'jobnums' => \@jobnums,
568 'child_objects' => $self->child_objects,
572 $dbh->rollback if $oldAutoCommit;
576 if ( $self->usergroup ) {
577 foreach my $groupname ( @{$self->usergroup} ) {
578 my $radius_usergroup = new FS::radius_usergroup ( {
579 svcnum => $self->svcnum,
580 groupname => $groupname,
582 my $error = $radius_usergroup->insert;
584 $dbh->rollback if $oldAutoCommit;
590 unless ( $skip_fuzzyfiles ) {
591 $error = $self->queue_fuzzyfiles_update;
593 $dbh->rollback if $oldAutoCommit;
594 return "updating fuzzy search cache: $error";
598 my $cust_pkg = $self->cust_svc->cust_pkg;
601 my $cust_main = $cust_pkg->cust_main;
602 my $agentnum = $cust_main->agentnum;
604 if ( $conf->exists('emailinvoiceautoalways')
605 || $conf->exists('emailinvoiceauto')
606 && ! $cust_main->invoicing_list_emailonly
608 my @invoicing_list = $cust_main->invoicing_list;
609 push @invoicing_list, $self->email;
610 $cust_main->invoicing_list(\@invoicing_list);
614 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
615 = ('','','','','','');
617 if ( $conf->exists('welcome_email', $agentnum) ) {
618 $welcome_template = new Text::Template (
620 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
621 ) or warn "can't create welcome email template: $Text::Template::ERROR";
622 $welcome_from = $conf->config('welcome_email-from', $agentnum);
623 # || 'your-isp-is-dum'
624 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
626 $welcome_subject_template = new Text::Template (
628 SOURCE => $welcome_subject,
629 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
630 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
633 if ( $welcome_template && $cust_pkg ) {
634 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
638 'custnum' => $self->custnum,
639 'username' => $self->username,
640 'password' => $self->_password,
641 'first' => $cust_main->first,
642 'last' => $cust_main->getfield('last'),
643 'pkg' => $cust_pkg->part_pkg->pkg,
645 my $wqueue = new FS::queue {
646 'svcnum' => $self->svcnum,
647 'job' => 'FS::svc_acct::send_email'
649 my $error = $wqueue->insert(
651 'from' => $welcome_from,
652 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
653 'mimetype' => $welcome_mimetype,
654 'body' => $welcome_template->fill_in( HASH => \%hash, ),
657 $dbh->rollback if $oldAutoCommit;
658 return "error queuing welcome email: $error";
661 if ( $options{'depend_jobnum'} ) {
662 warn "$me depend_jobnum found; adding to welcome email dependancies"
664 if ( ref($options{'depend_jobnum'}) ) {
665 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
666 "to welcome email dependancies"
668 push @jobnums, @{ $options{'depend_jobnum'} };
670 warn "$me adding job $options{'depend_jobnum'} ".
671 "to welcome email dependancies"
673 push @jobnums, $options{'depend_jobnum'};
677 foreach my $jobnum ( @jobnums ) {
678 my $error = $wqueue->depend_insert($jobnum);
680 $dbh->rollback if $oldAutoCommit;
681 return "error queuing welcome email job dependancy: $error";
691 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
697 Deletes this account from the database. If there is an error, returns the
698 error, otherwise returns false.
700 The corresponding FS::cust_svc record will be deleted as well.
702 (TODOC: new exports!)
709 return "can't delete system account" if $self->_check_system;
711 return "Can't delete an account which is a (svc_forward) source!"
712 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
714 return "Can't delete an account which is a (svc_forward) destination!"
715 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
717 return "Can't delete an account with (svc_www) web service!"
718 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
720 # what about records in session ? (they should refer to history table)
722 local $SIG{HUP} = 'IGNORE';
723 local $SIG{INT} = 'IGNORE';
724 local $SIG{QUIT} = 'IGNORE';
725 local $SIG{TERM} = 'IGNORE';
726 local $SIG{TSTP} = 'IGNORE';
727 local $SIG{PIPE} = 'IGNORE';
729 my $oldAutoCommit = $FS::UID::AutoCommit;
730 local $FS::UID::AutoCommit = 0;
733 foreach my $cust_main_invoice (
734 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
736 unless ( defined($cust_main_invoice) ) {
737 warn "WARNING: something's wrong with qsearch";
740 my %hash = $cust_main_invoice->hash;
741 $hash{'dest'} = $self->email;
742 my $new = new FS::cust_main_invoice \%hash;
743 my $error = $new->replace($cust_main_invoice);
745 $dbh->rollback if $oldAutoCommit;
750 foreach my $svc_domain (
751 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
753 my %hash = new FS::svc_domain->hash;
754 $hash{'catchall'} = '';
755 my $new = new FS::svc_domain \%hash;
756 my $error = $new->replace($svc_domain);
758 $dbh->rollback if $oldAutoCommit;
763 my $error = $self->SUPER::delete;
765 $dbh->rollback if $oldAutoCommit;
769 foreach my $radius_usergroup (
770 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
772 my $error = $radius_usergroup->delete;
774 $dbh->rollback if $oldAutoCommit;
779 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
783 =item replace OLD_RECORD
785 Replaces OLD_RECORD with this one in the database. If there is an error,
786 returns the error, otherwise returns false.
788 The additional field I<usergroup> can optionally be defined; if so it should
789 contain an arrayref of group names. See L<FS::radius_usergroup>.
797 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
801 warn "$me replacing $old with $new\n" if $DEBUG;
805 return "can't modify system account" if $old->_check_system;
808 #no warnings 'numeric'; #alas, a 5.006-ism
811 foreach my $xid (qw( uid gid )) {
813 return "Can't change $xid!"
814 if ! $conf->exists("svc_acct-edit_$xid")
815 && $old->$xid() != $new->$xid()
816 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
821 #change homdir when we change username
822 $new->setfield('dir', '') if $old->username ne $new->username;
824 local $SIG{HUP} = 'IGNORE';
825 local $SIG{INT} = 'IGNORE';
826 local $SIG{QUIT} = 'IGNORE';
827 local $SIG{TERM} = 'IGNORE';
828 local $SIG{TSTP} = 'IGNORE';
829 local $SIG{PIPE} = 'IGNORE';
831 my $oldAutoCommit = $FS::UID::AutoCommit;
832 local $FS::UID::AutoCommit = 0;
835 # redundant, but so $new->usergroup gets set
836 $error = $new->check;
837 return $error if $error;
839 $old->usergroup( [ $old->radius_groups ] );
841 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
842 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
844 if ( $new->usergroup ) {
845 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
846 my @newgroups = @{$new->usergroup};
847 foreach my $oldgroup ( @{$old->usergroup} ) {
848 if ( grep { $oldgroup eq $_ } @newgroups ) {
849 @newgroups = grep { $oldgroup ne $_ } @newgroups;
852 my $radius_usergroup = qsearchs('radius_usergroup', {
853 svcnum => $old->svcnum,
854 groupname => $oldgroup,
856 my $error = $radius_usergroup->delete;
858 $dbh->rollback if $oldAutoCommit;
859 return "error deleting radius_usergroup $oldgroup: $error";
863 foreach my $newgroup ( @newgroups ) {
864 my $radius_usergroup = new FS::radius_usergroup ( {
865 svcnum => $new->svcnum,
866 groupname => $newgroup,
868 my $error = $radius_usergroup->insert;
870 $dbh->rollback if $oldAutoCommit;
871 return "error adding radius_usergroup $newgroup: $error";
877 $error = $new->SUPER::replace($old, @_);
879 $dbh->rollback if $oldAutoCommit;
880 return $error if $error;
883 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
884 $error = $new->queue_fuzzyfiles_update;
886 $dbh->rollback if $oldAutoCommit;
887 return "updating fuzzy search cache: $error";
891 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
895 =item queue_fuzzyfiles_update
897 Used by insert & replace to update the fuzzy search cache
901 sub queue_fuzzyfiles_update {
904 local $SIG{HUP} = 'IGNORE';
905 local $SIG{INT} = 'IGNORE';
906 local $SIG{QUIT} = 'IGNORE';
907 local $SIG{TERM} = 'IGNORE';
908 local $SIG{TSTP} = 'IGNORE';
909 local $SIG{PIPE} = 'IGNORE';
911 my $oldAutoCommit = $FS::UID::AutoCommit;
912 local $FS::UID::AutoCommit = 0;
915 my $queue = new FS::queue {
916 'svcnum' => $self->svcnum,
917 'job' => 'FS::svc_acct::append_fuzzyfiles'
919 my $error = $queue->insert($self->username);
921 $dbh->rollback if $oldAutoCommit;
922 return "queueing job (transaction rolled back): $error";
925 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
933 Suspends this account by calling export-specific suspend hooks. If there is
934 an error, returns the error, otherwise returns false.
936 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
942 return "can't suspend system account" if $self->_check_system;
943 $self->SUPER::suspend(@_);
948 Unsuspends this account by by calling export-specific suspend hooks. If there
949 is an error, returns the error, otherwise returns false.
951 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
957 my %hash = $self->hash;
958 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
959 $hash{_password} = $1;
960 my $new = new FS::svc_acct ( \%hash );
961 my $error = $new->replace($self);
962 return $error if $error;
965 $self->SUPER::unsuspend(@_);
970 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
972 If the B<auto_unset_catchall> configuration option is set, this method will
973 automatically remove any references to the canceled service in the catchall
974 field of svc_domain. This allows packages that contain both a svc_domain and
975 its catchall svc_acct to be canceled in one step.
980 # Only one thing to do at this level
982 foreach my $svc_domain (
983 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
984 if($conf->exists('auto_unset_catchall')) {
985 my %hash = $svc_domain->hash;
986 $hash{catchall} = '';
987 my $new = new FS::svc_domain ( \%hash );
988 my $error = $new->replace($svc_domain);
989 return $error if $error;
991 return "cannot unprovision svc_acct #".$self->svcnum.
992 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
996 $self->SUPER::cancel(@_);
1002 Checks all fields to make sure this is a valid service. If there is an error,
1003 returns the error, otherwise returns false. Called by the insert and replace
1006 Sets any fixed values; see L<FS::part_svc>.
1013 my($recref) = $self->hashref;
1015 my $x = $self->setfixed( $self->_fieldhandlers );
1016 return $x unless ref($x);
1019 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1021 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1024 my $error = $self->ut_numbern('svcnum')
1025 #|| $self->ut_number('domsvc')
1026 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1027 || $self->ut_textn('sec_phrase')
1028 || $self->ut_snumbern('seconds')
1029 || $self->ut_snumbern('upbytes')
1030 || $self->ut_snumbern('downbytes')
1031 || $self->ut_snumbern('totalbytes')
1032 || $self->ut_enum( '_password_encoding',
1033 [ '', qw( plain crypt ldap ) ]
1036 return $error if $error;
1039 local $username_letter = $username_letter;
1040 if ($self->svcnum) {
1041 my $cust_svc = $self->cust_svc
1042 or return "no cust_svc record found for svcnum ". $self->svcnum;
1043 my $cust_pkg = $cust_svc->cust_pkg;
1045 if ($self->pkgnum) {
1046 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1050 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1053 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1054 if ( $username_uppercase ) {
1055 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1056 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1057 $recref->{username} = $1;
1059 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1060 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1061 $recref->{username} = $1;
1064 if ( $username_letterfirst ) {
1065 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1066 } elsif ( $username_letter ) {
1067 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1069 if ( $username_noperiod ) {
1070 $recref->{username} =~ /\./ and return gettext('illegal_username');
1072 if ( $username_nounderscore ) {
1073 $recref->{username} =~ /_/ and return gettext('illegal_username');
1075 if ( $username_nodash ) {
1076 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1078 unless ( $username_ampersand ) {
1079 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1081 unless ( $username_percent ) {
1082 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1084 unless ( $username_colon ) {
1085 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1088 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1089 $recref->{popnum} = $1;
1090 return "Unknown popnum" unless
1091 ! $recref->{popnum} ||
1092 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1094 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1096 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1097 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1099 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1100 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1101 #not all systems use gid=uid
1102 #you can set a fixed gid in part_svc
1104 return "Only root can have uid 0"
1105 if $recref->{uid} == 0
1106 && $recref->{username} !~ /^(root|toor|smtp)$/;
1108 unless ( $recref->{username} eq 'sync' ) {
1109 if ( grep $_ eq $recref->{shell}, @shells ) {
1110 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1112 return "Illegal shell \`". $self->shell. "\'; ".
1113 "shells configuration value contains: @shells";
1116 $recref->{shell} = '/bin/sync';
1120 $recref->{gid} ne '' ?
1121 return "Can't have gid without uid" : ( $recref->{gid}='' );
1122 #$recref->{dir} ne '' ?
1123 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1124 $recref->{shell} ne '' ?
1125 return "Can't have shell without uid" : ( $recref->{shell}='' );
1128 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1130 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1131 or return "Illegal directory: ". $recref->{dir};
1132 $recref->{dir} = $1;
1133 return "Illegal directory"
1134 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1135 return "Illegal directory"
1136 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1137 unless ( $recref->{dir} ) {
1138 $recref->{dir} = $dir_prefix . '/';
1139 if ( $dirhash > 0 ) {
1140 for my $h ( 1 .. $dirhash ) {
1141 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1143 } elsif ( $dirhash < 0 ) {
1144 for my $h ( reverse $dirhash .. -1 ) {
1145 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1148 $recref->{dir} .= $recref->{username};
1154 # $error = $self->ut_textn('finger');
1155 # return $error if $error;
1156 if ( $self->getfield('finger') eq '' ) {
1157 my $cust_pkg = $self->svcnum
1158 ? $self->cust_svc->cust_pkg
1159 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1161 my $cust_main = $cust_pkg->cust_main;
1162 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1165 $self->getfield('finger') =~
1166 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1167 or return "Illegal finger: ". $self->getfield('finger');
1168 $self->setfield('finger', $1);
1170 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1171 $recref->{quota} = $1;
1173 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1174 if ( $recref->{slipip} eq '' ) {
1175 $recref->{slipip} = '';
1176 } elsif ( $recref->{slipip} eq '0e0' ) {
1177 $recref->{slipip} = '0e0';
1179 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1180 or return "Illegal slipip: ". $self->slipip;
1181 $recref->{slipip} = $1;
1186 #arbitrary RADIUS stuff; allow ut_textn for now
1187 foreach ( grep /^radius_/, fields('svc_acct') ) {
1188 $self->ut_textn($_);
1191 if ( $recref->{_password_encoding} eq 'ldap' ) {
1193 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1194 $recref->{_password} = uc($1).$2;
1196 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1199 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1201 if ( $recref->{_password} =~
1202 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1203 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1206 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1209 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1212 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1214 #generate a password if it is blank
1215 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1216 unless length( $recref->{_password} );
1218 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1219 $recref->{_password} = $1;
1221 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1222 FS::Msgcat::_gettext('illegal_password_characters').
1223 ": ". $recref->{_password};
1226 if ( $password_noampersand ) {
1227 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1229 if ( $password_noexclamation ) {
1230 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1235 #carp "warning: _password_encoding unspecified\n";
1237 #generate a password if it is blank
1238 unless ( length($recref->{_password}) || ! $passwordmin ) {
1240 $recref->{_password} =
1241 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1242 $recref->{_password_encoding} = 'plain';
1246 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1247 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1248 $recref->{_password} = $1.$3;
1249 $recref->{_password_encoding} = 'plain';
1250 } elsif ( $recref->{_password} =~
1251 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1253 $recref->{_password} = $1.$3;
1254 $recref->{_password_encoding} = 'crypt';
1255 } elsif ( $recref->{_password} eq '*' ) {
1256 $recref->{_password} = '*';
1257 $recref->{_password_encoding} = 'crypt';
1258 } elsif ( $recref->{_password} eq '!' ) {
1259 $recref->{_password_encoding} = 'crypt';
1260 $recref->{_password} = '!';
1261 } elsif ( $recref->{_password} eq '!!' ) {
1262 $recref->{_password} = '!!';
1263 $recref->{_password_encoding} = 'crypt';
1265 #return "Illegal password";
1266 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1267 FS::Msgcat::_gettext('illegal_password_characters').
1268 ": ". $recref->{_password};
1275 $self->SUPER::check;
1281 Internal function to check the username against the list of system usernames
1282 from the I<system_usernames> configuration value. Returns true if the username
1283 is listed on the system username list.
1289 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1290 $conf->config('system_usernames')
1294 =item _check_duplicate
1296 Internal method to check for duplicates usernames, username@domain pairs and
1299 If the I<global_unique-username> configuration value is set to B<username> or
1300 B<username@domain>, enforces global username or username@domain uniqueness.
1302 In all cases, check for duplicate uids and usernames or username@domain pairs
1303 per export and with identical I<svcpart> values.
1307 sub _check_duplicate {
1310 my $global_unique = $conf->config('global_unique-username') || 'none';
1311 return '' if $global_unique eq 'disabled';
1315 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1316 unless ( $part_svc ) {
1317 return 'unknown svcpart '. $self->svcpart;
1320 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1321 qsearch( 'svc_acct', { 'username' => $self->username } );
1322 return gettext('username_in_use')
1323 if $global_unique eq 'username' && @dup_user;
1325 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1326 qsearch( 'svc_acct', { 'username' => $self->username,
1327 'domsvc' => $self->domsvc } );
1328 return gettext('username_in_use')
1329 if $global_unique eq 'username@domain' && @dup_userdomain;
1332 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1333 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1334 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1335 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1340 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1341 my $exports = FS::part_export::export_info('svc_acct');
1342 my %conflict_user_svcpart;
1343 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1345 foreach my $part_export ( $part_svc->part_export ) {
1347 #this will catch to the same exact export
1348 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1350 #this will catch to exports w/same exporthost+type ???
1351 #my @other_part_export = qsearch('part_export', {
1352 # 'machine' => $part_export->machine,
1353 # 'exporttype' => $part_export->exporttype,
1355 #foreach my $other_part_export ( @other_part_export ) {
1356 # push @svcparts, map { $_->svcpart }
1357 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1360 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1361 #silly kludge to avoid uninitialized value errors
1362 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1363 ? $exports->{$part_export->exporttype}{'nodomain'}
1365 if ( $nodomain =~ /^Y/i ) {
1366 $conflict_user_svcpart{$_} = $part_export->exportnum
1369 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1374 foreach my $dup_user ( @dup_user ) {
1375 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1376 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1377 return "duplicate username ". $self->username.
1378 ": conflicts with svcnum ". $dup_user->svcnum.
1379 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1383 foreach my $dup_userdomain ( @dup_userdomain ) {
1384 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1385 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1386 return "duplicate username\@domain ". $self->email.
1387 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1388 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1392 foreach my $dup_uid ( @dup_uid ) {
1393 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1394 if ( exists($conflict_user_svcpart{$dup_svcpart})
1395 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1396 return "duplicate uid ". $self->uid.
1397 ": conflicts with svcnum ". $dup_uid->svcnum.
1399 ( $conflict_user_svcpart{$dup_svcpart}
1400 || $conflict_userdomain_svcpart{$dup_svcpart} );
1412 Depriciated, use radius_reply instead.
1417 carp "FS::svc_acct::radius depriciated, use radius_reply";
1418 $_[0]->radius_reply;
1423 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1424 reply attributes of this record.
1426 Note that this is now the preferred method for reading RADIUS attributes -
1427 accessing the columns directly is discouraged, as the column names are
1428 expected to change in the future.
1435 return %{ $self->{'radius_reply'} }
1436 if exists $self->{'radius_reply'};
1441 my($column, $attrib) = ($1, $2);
1442 #$attrib =~ s/_/\-/g;
1443 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1444 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1446 if ( $self->slipip && $self->slipip ne '0e0' ) {
1447 $reply{$radius_ip} = $self->slipip;
1450 if ( $self->seconds !~ /^$/ ) {
1451 $reply{'Session-Timeout'} = $self->seconds;
1454 if ( $conf->exists('radius-chillispot-max') ) {
1455 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1457 #hmm. just because sqlradius.pm says so?
1464 foreach my $what (qw( input output total )) {
1465 my $is = $whatis{$what}.'bytes';
1466 if ( $self->$is() =~ /\d/ ) {
1467 my $big = new Math::BigInt $self->$is();
1468 $big = new Math::BigInt '0' if $big->is_neg();
1469 my $att = "Chillispot-Max-\u$what";
1470 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1471 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1482 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1483 check attributes of this record.
1485 Note that this is now the preferred method for reading RADIUS attributes -
1486 accessing the columns directly is discouraged, as the column names are
1487 expected to change in the future.
1494 return %{ $self->{'radius_check'} }
1495 if exists $self->{'radius_check'};
1500 my($column, $attrib) = ($1, $2);
1501 #$attrib =~ s/_/\-/g;
1502 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1503 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1506 my($pw_attrib, $password) = $self->radius_password;
1507 $check{$pw_attrib} = $password;
1509 my $cust_svc = $self->cust_svc;
1511 my $cust_pkg = $cust_svc->cust_pkg;
1512 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1513 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1516 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1517 "; can't set Expiration\n"
1525 =item radius_password
1527 Returns a key/value pair containing the RADIUS attribute name and value
1532 sub radius_password {
1535 my($pw_attrib, $password);
1536 if ( $self->_password_encoding eq 'ldap' ) {
1538 $pw_attrib = 'Password-With-Header';
1539 $password = $self->_password;
1541 } elsif ( $self->_password_encoding eq 'crypt' ) {
1543 $pw_attrib = 'Crypt-Password';
1544 $password = $self->_password;
1546 } elsif ( $self->_password_encoding eq 'plain' ) {
1548 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1549 $password = $self->_password;
1553 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1554 $password = $self->_password;
1558 ($pw_attrib, $password);
1564 This method instructs the object to "snapshot" or freeze RADIUS check and
1565 reply attributes to the current values.
1569 #bah, my english is too broken this morning
1570 #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
1571 #the FS::cust_pkg's replace method to trigger the correct export updates when
1572 #package dates change)
1577 $self->{$_} = { $self->$_() }
1578 foreach qw( radius_reply radius_check );
1582 =item forget_snapshot
1584 This methos instructs the object to forget any previously snapshotted
1585 RADIUS check and reply attributes.
1589 sub forget_snapshot {
1593 foreach qw( radius_reply radius_check );
1597 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1599 Returns the domain associated with this account.
1601 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1608 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1609 my $svc_domain = $self->svc_domain(@_)
1610 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1611 $svc_domain->domain;
1616 Returns the FS::svc_domain record for this account's domain (see
1621 # FS::h_svc_acct has a history-aware svc_domain override
1626 ? $self->{'_domsvc'}
1627 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1632 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1636 #inherited from svc_Common
1638 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1640 Returns an email address associated with the account.
1642 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1649 $self->username. '@'. $self->domain(@_);
1654 Returns an array of FS::acct_snarf records associated with the account.
1655 If the acct_snarf table does not exist or there are no associated records,
1656 an empty list is returned
1662 return () unless dbdef->table('acct_snarf');
1663 eval "use FS::acct_snarf;";
1665 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1668 =item decrement_upbytes OCTETS
1670 Decrements the I<upbytes> field of this record by the given amount. If there
1671 is an error, returns the error, otherwise returns false.
1675 sub decrement_upbytes {
1676 shift->_op_usage('-', 'upbytes', @_);
1679 =item increment_upbytes OCTETS
1681 Increments the I<upbytes> field of this record by the given amount. If there
1682 is an error, returns the error, otherwise returns false.
1686 sub increment_upbytes {
1687 shift->_op_usage('+', 'upbytes', @_);
1690 =item decrement_downbytes OCTETS
1692 Decrements the I<downbytes> field of this record by the given amount. If there
1693 is an error, returns the error, otherwise returns false.
1697 sub decrement_downbytes {
1698 shift->_op_usage('-', 'downbytes', @_);
1701 =item increment_downbytes OCTETS
1703 Increments the I<downbytes> field of this record by the given amount. If there
1704 is an error, returns the error, otherwise returns false.
1708 sub increment_downbytes {
1709 shift->_op_usage('+', 'downbytes', @_);
1712 =item decrement_totalbytes OCTETS
1714 Decrements the I<totalbytes> field of this record by the given amount. If there
1715 is an error, returns the error, otherwise returns false.
1719 sub decrement_totalbytes {
1720 shift->_op_usage('-', 'totalbytes', @_);
1723 =item increment_totalbytes OCTETS
1725 Increments the I<totalbytes> field of this record by the given amount. If there
1726 is an error, returns the error, otherwise returns false.
1730 sub increment_totalbytes {
1731 shift->_op_usage('+', 'totalbytes', @_);
1734 =item decrement_seconds SECONDS
1736 Decrements the I<seconds> field of this record by the given amount. If there
1737 is an error, returns the error, otherwise returns false.
1741 sub decrement_seconds {
1742 shift->_op_usage('-', 'seconds', @_);
1745 =item increment_seconds SECONDS
1747 Increments the I<seconds> field of this record by the given amount. If there
1748 is an error, returns the error, otherwise returns false.
1752 sub increment_seconds {
1753 shift->_op_usage('+', 'seconds', @_);
1761 my %op2condition = (
1762 '-' => sub { my($self, $column, $amount) = @_;
1763 $self->$column - $amount <= 0;
1765 '+' => sub { my($self, $column, $amount) = @_;
1766 ($self->$column || 0) + $amount > 0;
1769 my %op2warncondition = (
1770 '-' => sub { my($self, $column, $amount) = @_;
1771 my $threshold = $column . '_threshold';
1772 $self->$column - $amount <= $self->$threshold + 0;
1774 '+' => sub { my($self, $column, $amount) = @_;
1775 ($self->$column || 0) + $amount > 0;
1780 my( $self, $op, $column, $amount ) = @_;
1782 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1783 ' ('. $self->email. "): $op $amount\n"
1786 return '' unless $amount;
1788 local $SIG{HUP} = 'IGNORE';
1789 local $SIG{INT} = 'IGNORE';
1790 local $SIG{QUIT} = 'IGNORE';
1791 local $SIG{TERM} = 'IGNORE';
1792 local $SIG{TSTP} = 'IGNORE';
1793 local $SIG{PIPE} = 'IGNORE';
1795 my $oldAutoCommit = $FS::UID::AutoCommit;
1796 local $FS::UID::AutoCommit = 0;
1799 my $sql = "UPDATE svc_acct SET $column = ".
1800 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1801 " $op ? WHERE svcnum = ?";
1805 my $sth = $dbh->prepare( $sql )
1806 or die "Error preparing $sql: ". $dbh->errstr;
1807 my $rv = $sth->execute($amount, $self->svcnum);
1808 die "Error executing $sql: ". $sth->errstr
1809 unless defined($rv);
1810 die "Can't update $column for svcnum". $self->svcnum
1813 #$self->snapshot; #not necessary, we retain the old values
1814 #create an object with the updated usage values
1815 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1817 my $error = $new->replace($self);
1819 $dbh->rollback if $oldAutoCommit;
1820 return "Error replacing: $error";
1823 #overlimit_action eq 'cancel' handling
1824 my $cust_pkg = $self->cust_svc->cust_pkg;
1826 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1827 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1831 my $error = $cust_pkg->cancel; #XXX should have a reason
1833 $dbh->rollback if $oldAutoCommit;
1834 return "Error cancelling: $error";
1837 #nothing else is relevant if we're cancelling, so commit & return success
1838 warn "$me update successful; committing\n"
1840 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1845 my $action = $op2action{$op};
1847 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1848 ( $action eq 'suspend' && !$self->overlimit
1849 || $action eq 'unsuspend' && $self->overlimit )
1851 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1852 if ($part_export->option('overlimit_groups')) {
1854 my $other = new FS::svc_acct $self->hashref;
1855 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1856 ($self, $part_export->option('overlimit_groups'));
1857 $other->usergroup( $groups );
1858 if ($action eq 'suspend'){
1859 $new = $other; $old = $self;
1861 $new = $self; $old = $other;
1863 my $error = $part_export->export_replace($new, $old);
1864 $error ||= $self->overlimit($action);
1866 $dbh->rollback if $oldAutoCommit;
1867 return "Error replacing radius groups in export, ${op}: $error";
1873 if ( $conf->exists("svc_acct-usage_$action")
1874 && &{$op2condition{$op}}($self, $column, $amount) ) {
1875 #my $error = $self->$action();
1876 my $error = $self->cust_svc->cust_pkg->$action();
1877 # $error ||= $self->overlimit($action);
1879 $dbh->rollback if $oldAutoCommit;
1880 return "Error ${action}ing: $error";
1884 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1885 my $wqueue = new FS::queue {
1886 'svcnum' => $self->svcnum,
1887 'job' => 'FS::svc_acct::reached_threshold',
1892 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1896 my $error = $wqueue->insert(
1897 'svcnum' => $self->svcnum,
1899 'column' => $column,
1903 $dbh->rollback if $oldAutoCommit;
1904 return "Error queuing threshold activity: $error";
1908 warn "$me update successful; committing\n"
1910 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1916 my( $self, $valueref, %options ) = @_;
1918 warn "$me set_usage called for svcnum ". $self->svcnum.
1919 ' ('. $self->email. "): ".
1920 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1923 local $SIG{HUP} = 'IGNORE';
1924 local $SIG{INT} = 'IGNORE';
1925 local $SIG{QUIT} = 'IGNORE';
1926 local $SIG{TERM} = 'IGNORE';
1927 local $SIG{TSTP} = 'IGNORE';
1928 local $SIG{PIPE} = 'IGNORE';
1930 local $FS::svc_Common::noexport_hack = 1;
1931 my $oldAutoCommit = $FS::UID::AutoCommit;
1932 local $FS::UID::AutoCommit = 0;
1937 if ( $options{null} ) {
1938 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1939 qw( seconds upbytes downbytes totalbytes )
1942 foreach my $field (keys %$valueref){
1943 $reset = 1 if $valueref->{$field};
1944 $self->setfield($field, $valueref->{$field});
1945 $self->setfield( $field.'_threshold',
1946 int($self->getfield($field)
1947 * ( $conf->exists('svc_acct-usage_threshold')
1948 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1953 $handyhash{$field} = $self->getfield($field);
1954 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1956 #my $error = $self->replace; #NO! we avoid the call to ->check for
1957 #die $error if $error; #services not explicity changed via the UI
1959 my $sql = "UPDATE svc_acct SET " .
1960 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
1961 " WHERE svcnum = ". $self->svcnum;
1966 if (scalar(keys %handyhash)) {
1967 my $sth = $dbh->prepare( $sql )
1968 or die "Error preparing $sql: ". $dbh->errstr;
1969 my $rv = $sth->execute();
1970 die "Error executing $sql: ". $sth->errstr
1971 unless defined($rv);
1972 die "Can't update usage for svcnum ". $self->svcnum
1976 #$self->snapshot; #not necessary, we retain the old values
1977 #create an object with the updated usage values
1978 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1980 my $error = $new->replace($self);
1982 $dbh->rollback if $oldAutoCommit;
1983 return "Error replacing: $error";
1989 if ($self->overlimit) {
1990 $error = $self->overlimit('unsuspend');
1991 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1992 if ($part_export->option('overlimit_groups')) {
1993 my $old = new FS::svc_acct $self->hashref;
1994 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1995 ($self, $part_export->option('overlimit_groups'));
1996 $old->usergroup( $groups );
1997 $error ||= $part_export->export_replace($self, $old);
2002 if ( $conf->exists("svc_acct-usage_unsuspend")) {
2003 $error ||= $self->cust_svc->cust_pkg->unsuspend;
2006 $dbh->rollback if $oldAutoCommit;
2007 return "Error unsuspending: $error";
2011 warn "$me update successful; committing\n"
2013 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2019 =item recharge HASHREF
2021 Increments usage columns by the amount specified in HASHREF as
2022 column=>amount pairs.
2027 my ($self, $vhash) = @_;
2030 warn "[$me] recharge called on $self: ". Dumper($self).
2031 "\nwith vhash: ". Dumper($vhash);
2034 my $oldAutoCommit = $FS::UID::AutoCommit;
2035 local $FS::UID::AutoCommit = 0;
2039 foreach my $column (keys %$vhash){
2040 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2044 $dbh->rollback if $oldAutoCommit;
2046 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2051 =item is_rechargeable
2053 Returns true if this svc_account can be "recharged" and false otherwise.
2057 sub is_rechargable {
2059 $self->seconds ne ''
2060 || $self->upbytes ne ''
2061 || $self->downbytes ne ''
2062 || $self->totalbytes ne '';
2065 =item seconds_since TIMESTAMP
2067 Returns the number of seconds this account has been online since TIMESTAMP,
2068 according to the session monitor (see L<FS::Session>).
2070 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2071 L<Time::Local> and L<Date::Parse> for conversion functions.
2075 #note: POD here, implementation in FS::cust_svc
2078 $self->cust_svc->seconds_since(@_);
2081 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2083 Returns the numbers of seconds this account has been online between
2084 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2085 external SQL radacct table, specified via sqlradius export. Sessions which
2086 started in the specified range but are still open are counted from session
2087 start to the end of the range (unless they are over 1 day old, in which case
2088 they are presumed missing their stop record and not counted). Also, sessions
2089 which end in the range but started earlier are counted from the start of the
2090 range to session end. Finally, sessions which start before the range but end
2091 after are counted for the entire range.
2093 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2094 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2099 #note: POD here, implementation in FS::cust_svc
2100 sub seconds_since_sqlradacct {
2102 $self->cust_svc->seconds_since_sqlradacct(@_);
2105 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2107 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2108 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2109 TIMESTAMP_END (exclusive).
2111 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2112 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2117 #note: POD here, implementation in FS::cust_svc
2118 sub attribute_since_sqlradacct {
2120 $self->cust_svc->attribute_since_sqlradacct(@_);
2123 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2125 Returns an array of hash references of this customers login history for the
2126 given time range. (document this better)
2130 sub get_session_history {
2132 $self->cust_svc->get_session_history(@_);
2135 =item last_login_text
2137 Returns text describing the time of last login.
2141 sub last_login_text {
2143 $self->last_login ? ctime($self->last_login) : 'unknown';
2146 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2151 my($self, $start, $end, %opt ) = @_;
2153 my $did = $self->username; #yup
2155 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2157 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2159 #SELECT $for_update * FROM cdr
2160 # WHERE calldate >= $start #need a conversion
2161 # AND calldate < $end #ditto
2162 # AND ( charged_party = "$did"
2163 # OR charged_party = "$prefix$did" #if length($prefix);
2164 # OR ( ( charged_party IS NULL OR charged_party = '' )
2166 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2169 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2172 if ( length($prefix) ) {
2174 " AND ( charged_party = '$did'
2175 OR charged_party = '$prefix$did'
2176 OR ( ( charged_party IS NULL OR charged_party = '' )
2178 ( src = '$did' OR src = '$prefix$did' )
2184 " AND ( charged_party = '$did'
2185 OR ( ( charged_party IS NULL OR charged_party = '' )
2195 'select' => "$for_update *",
2198 #( freesidestatus IS NULL OR freesidestatus = '' )
2199 'freesidestatus' => '',
2201 'extra_sql' => $charged_or_src,
2209 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2215 if ( $self->usergroup ) {
2216 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2217 unless ref($self->usergroup) eq 'ARRAY';
2218 #when provisioning records, export callback runs in svc_Common.pm before
2219 #radius_usergroup records can be inserted...
2220 @{$self->usergroup};
2222 map { $_->groupname }
2223 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2227 =item clone_suspended
2229 Constructor used by FS::part_export::_export_suspend fallback. Document
2234 sub clone_suspended {
2236 my %hash = $self->hash;
2237 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2238 new FS::svc_acct \%hash;
2241 =item clone_kludge_unsuspend
2243 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2248 sub clone_kludge_unsuspend {
2250 my %hash = $self->hash;
2251 $hash{_password} = '';
2252 new FS::svc_acct \%hash;
2255 =item check_password
2257 Checks the supplied password against the (possibly encrypted) password in the
2258 database. Returns true for a successful authentication, false for no match.
2260 Currently supported encryptions are: classic DES crypt() and MD5
2264 sub check_password {
2265 my($self, $check_password) = @_;
2267 #remove old-style SUSPENDED kludge, they should be allowed to login to
2268 #self-service and pay up
2269 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2271 if ( $self->_password_encoding eq 'ldap' ) {
2273 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2274 return $auth->match($check_password);
2276 } elsif ( $self->_password_encoding eq 'crypt' ) {
2278 my $auth = from_crypt Authen::Passphrase $self->_password;
2279 return $auth->match($check_password);
2281 } elsif ( $self->_password_encoding eq 'plain' ) {
2283 return $check_password eq $password;
2287 #XXX this could be replaced with Authen::Passphrase stuff
2289 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2291 } elsif ( length($password) < 13 ) { #plaintext
2292 $check_password eq $password;
2293 } elsif ( length($password) == 13 ) { #traditional DES crypt
2294 crypt($check_password, $password) eq $password;
2295 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2296 unix_md5_crypt($check_password, $password) eq $password;
2297 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2298 warn "Can't check password: Blowfish encryption not yet supported, ".
2299 "svcnum ". $self->svcnum. "\n";
2302 warn "Can't check password: Unrecognized encryption for svcnum ".
2303 $self->svcnum. "\n";
2311 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2313 Returns an encrypted password, either by passing through an encrypted password
2314 in the database or by encrypting a plaintext password from the database.
2316 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2317 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2318 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2319 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2320 encryption type is only used if the password is not already encrypted in the
2325 sub crypt_password {
2328 if ( $self->_password_encoding eq 'ldap' ) {
2330 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2333 #XXX this could be replaced with Authen::Passphrase stuff
2335 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2336 if ( $encryption eq 'crypt' ) {
2339 $saltset[int(rand(64))].$saltset[int(rand(64))]
2341 } elsif ( $encryption eq 'md5' ) {
2342 unix_md5_crypt( $self->_password );
2343 } elsif ( $encryption eq 'blowfish' ) {
2344 croak "unknown encryption method $encryption";
2346 croak "unknown encryption method $encryption";
2349 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2353 } elsif ( $self->_password_encoding eq 'crypt' ) {
2355 return $self->_password;
2357 } elsif ( $self->_password_encoding eq 'plain' ) {
2359 #XXX this could be replaced with Authen::Passphrase stuff
2361 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2362 if ( $encryption eq 'crypt' ) {
2365 $saltset[int(rand(64))].$saltset[int(rand(64))]
2367 } elsif ( $encryption eq 'md5' ) {
2368 unix_md5_crypt( $self->_password );
2369 } elsif ( $encryption eq 'blowfish' ) {
2370 croak "unknown encryption method $encryption";
2372 croak "unknown encryption method $encryption";
2377 if ( length($self->_password) == 13
2378 || $self->_password =~ /^\$(1|2a?)\$/
2379 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2385 #XXX this could be replaced with Authen::Passphrase stuff
2387 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2388 if ( $encryption eq 'crypt' ) {
2391 $saltset[int(rand(64))].$saltset[int(rand(64))]
2393 } elsif ( $encryption eq 'md5' ) {
2394 unix_md5_crypt( $self->_password );
2395 } elsif ( $encryption eq 'blowfish' ) {
2396 croak "unknown encryption method $encryption";
2398 croak "unknown encryption method $encryption";
2407 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2409 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2410 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2411 "{MD5}5426824942db4253f87a1009fd5d2d4".
2413 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2414 to work the same as the B</crypt_password> method.
2420 #eventually should check a "password-encoding" field
2422 if ( $self->_password_encoding eq 'ldap' ) {
2424 return $self->_password;
2426 } elsif ( $self->_password_encoding eq 'crypt' ) {
2428 if ( length($self->_password) == 13 ) { #crypt
2429 return '{CRYPT}'. $self->_password;
2430 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2432 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2433 # die "Blowfish encryption not supported in this context, svcnum ".
2434 # $self->svcnum. "\n";
2436 warn "encryption method not (yet?) supported in LDAP context";
2437 return '{CRYPT}*'; #unsupported, should not auth
2440 } elsif ( $self->_password_encoding eq 'plain' ) {
2442 return '{PLAIN}'. $self->_password;
2444 #return '{CLEARTEXT}'. $self->_password; #?
2448 if ( length($self->_password) == 13 ) { #crypt
2449 return '{CRYPT}'. $self->_password;
2450 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2452 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2453 warn "Blowfish encryption not supported in this context, svcnum ".
2454 $self->svcnum. "\n";
2457 #are these two necessary anymore?
2458 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2459 return '{SSHA}'. $1;
2460 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2461 return '{NS-MTA-MD5}'. $1;
2464 return '{PLAIN}'. $self->_password;
2466 #return '{CLEARTEXT}'. $self->_password; #?
2468 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2469 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2470 #if ( $encryption eq 'crypt' ) {
2471 # return '{CRYPT}'. crypt(
2473 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2475 #} elsif ( $encryption eq 'md5' ) {
2476 # unix_md5_crypt( $self->_password );
2477 #} elsif ( $encryption eq 'blowfish' ) {
2478 # croak "unknown encryption method $encryption";
2480 # croak "unknown encryption method $encryption";
2488 =item domain_slash_username
2490 Returns $domain/$username/
2494 sub domain_slash_username {
2496 $self->domain. '/'. $self->username. '/';
2499 =item virtual_maildir
2501 Returns $domain/maildirs/$username/
2505 sub virtual_maildir {
2507 $self->domain. '/maildirs/'. $self->username. '/';
2518 This is the FS::svc_acct job-queue-able version. It still uses
2519 FS::Misc::send_email under-the-hood.
2526 eval "use FS::Misc qw(send_email)";
2529 $opt{mimetype} ||= 'text/plain';
2530 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2532 my $error = send_email(
2533 'from' => $opt{from},
2535 'subject' => $opt{subject},
2536 'content-type' => $opt{mimetype},
2537 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2539 die $error if $error;
2542 =item check_and_rebuild_fuzzyfiles
2546 sub check_and_rebuild_fuzzyfiles {
2547 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2548 -e "$dir/svc_acct.username"
2549 or &rebuild_fuzzyfiles;
2552 =item rebuild_fuzzyfiles
2556 sub rebuild_fuzzyfiles {
2558 use Fcntl qw(:flock);
2560 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2564 open(USERNAMELOCK,">>$dir/svc_acct.username")
2565 or die "can't open $dir/svc_acct.username: $!";
2566 flock(USERNAMELOCK,LOCK_EX)
2567 or die "can't lock $dir/svc_acct.username: $!";
2569 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2571 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2572 or die "can't open $dir/svc_acct.username.tmp: $!";
2573 print USERNAMECACHE join("\n", @all_username), "\n";
2574 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2576 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2586 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2587 open(USERNAMECACHE,"<$dir/svc_acct.username")
2588 or die "can't open $dir/svc_acct.username: $!";
2589 my @array = map { chomp; $_; } <USERNAMECACHE>;
2590 close USERNAMECACHE;
2594 =item append_fuzzyfiles USERNAME
2598 sub append_fuzzyfiles {
2599 my $username = shift;
2601 &check_and_rebuild_fuzzyfiles;
2603 use Fcntl qw(:flock);
2605 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2607 open(USERNAME,">>$dir/svc_acct.username")
2608 or die "can't open $dir/svc_acct.username: $!";
2609 flock(USERNAME,LOCK_EX)
2610 or die "can't lock $dir/svc_acct.username: $!";
2612 print USERNAME "$username\n";
2614 flock(USERNAME,LOCK_UN)
2615 or die "can't unlock $dir/svc_acct.username: $!";
2623 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2627 sub radius_usergroup_selector {
2628 my $sel_groups = shift;
2629 my %sel_groups = map { $_=>1 } @$sel_groups;
2631 my $selectname = shift || 'radius_usergroup';
2634 my $sth = $dbh->prepare(
2635 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2636 ) or die $dbh->errstr;
2637 $sth->execute() or die $sth->errstr;
2638 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2642 function ${selectname}_doadd(object) {
2643 var myvalue = object.${selectname}_add.value;
2644 var optionName = new Option(myvalue,myvalue,false,true);
2645 var length = object.$selectname.length;
2646 object.$selectname.options[length] = optionName;
2647 object.${selectname}_add.value = "";
2650 <SELECT MULTIPLE NAME="$selectname">
2653 foreach my $group ( @all_groups ) {
2654 $html .= qq(<OPTION VALUE="$group");
2655 if ( $sel_groups{$group} ) {
2656 $html .= ' SELECTED';
2657 $sel_groups{$group} = 0;
2659 $html .= ">$group</OPTION>\n";
2661 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2662 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2664 $html .= '</SELECT>';
2666 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2667 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2672 =item reached_threshold
2674 Performs some activities when svc_acct thresholds (such as number of seconds
2675 remaining) are reached.
2679 sub reached_threshold {
2682 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2683 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2685 if ( $opt{'op'} eq '+' ){
2686 $svc_acct->setfield( $opt{'column'}.'_threshold',
2687 int($svc_acct->getfield($opt{'column'})
2688 * ( $conf->exists('svc_acct-usage_threshold')
2689 ? $conf->config('svc_acct-usage_threshold')/100
2694 my $error = $svc_acct->replace;
2695 die $error if $error;
2696 }elsif ( $opt{'op'} eq '-' ){
2698 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2699 return '' if ($threshold eq '' );
2701 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2702 my $error = $svc_acct->replace;
2703 die $error if $error; # email next time, i guess
2705 if ( $warning_template ) {
2706 eval "use FS::Misc qw(send_email)";
2709 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2710 my $cust_main = $cust_pkg->cust_main;
2712 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2713 $cust_main->invoicing_list,
2714 ($opt{'to'} ? $opt{'to'} : ())
2717 my $mimetype = $warning_mimetype;
2718 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2720 my $body = $warning_template->fill_in( HASH => {
2721 'custnum' => $cust_main->custnum,
2722 'username' => $svc_acct->username,
2723 'password' => $svc_acct->_password,
2724 'first' => $cust_main->first,
2725 'last' => $cust_main->getfield('last'),
2726 'pkg' => $cust_pkg->part_pkg->pkg,
2727 'column' => $opt{'column'},
2728 'amount' => $opt{'column'} =~/bytes/
2729 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2730 : $svc_acct->getfield($opt{'column'}),
2731 'threshold' => $opt{'column'} =~/bytes/
2732 ? FS::UI::bytecount::display_bytecount($threshold)
2737 my $error = send_email(
2738 'from' => $warning_from,
2740 'subject' => $warning_subject,
2741 'content-type' => $mimetype,
2742 'body' => [ map "$_\n", split("\n", $body) ],
2744 die $error if $error;
2747 die "unknown op: " . $opt{'op'};
2755 The $recref stuff in sub check should be cleaned up.
2757 The suspend, unsuspend and cancel methods update the database, but not the
2758 current object. This is probably a bug as it's unexpected and
2761 radius_usergroup_selector? putting web ui components in here? they should
2762 probably live somewhere else...
2764 insertion of RADIUS group stuff in insert could be done with child_objects now
2765 (would probably clean up export of them too)
2767 _op_usage and set_usage bypass the history... maybe they shouldn't
2771 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2772 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2773 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2774 L<freeside-queued>), L<FS::svc_acct_pop>,
2775 schema.html from the base documentation.
2779 =item domain_select_hash %OPTIONS
2781 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2782 may at present purchase.
2784 Currently available options are: I<pkgnum> I<svcpart>
2788 sub domain_select_hash {
2789 my ($self, %options) = @_;
2795 $part_svc = $self->part_svc;
2796 $cust_pkg = $self->cust_svc->cust_pkg
2800 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2801 if $options{'svcpart'};
2803 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2804 if $options{'pkgnum'};
2806 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2807 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2808 %domains = map { $_->svcnum => $_->domain }
2809 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2810 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2811 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2812 %domains = map { $_->svcnum => $_->domain }
2813 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2814 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2815 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2817 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2820 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2821 my $svc_domain = qsearchs('svc_domain',
2822 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2823 if ( $svc_domain ) {
2824 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2826 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2827 $part_svc->part_svc_column('domsvc')->columnvalue;