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;
60 $passwordmax = $conf->config('passwordmax') || 8;
61 $username_letter = $conf->exists('username-letter');
62 $username_letterfirst = $conf->exists('username-letterfirst');
63 $username_noperiod = $conf->exists('username-noperiod');
64 $username_nounderscore = $conf->exists('username-nounderscore');
65 $username_nodash = $conf->exists('username-nodash');
66 $username_uppercase = $conf->exists('username-uppercase');
67 $username_ampersand = $conf->exists('username-ampersand');
68 $username_percent = $conf->exists('username-percent');
69 $username_colon = $conf->exists('username-colon');
70 $password_noampersand = $conf->exists('password-noexclamation');
71 $password_noexclamation = $conf->exists('password-noexclamation');
72 $dirhash = $conf->config('dirhash') || 0;
73 if ( $conf->exists('warning_email') ) {
74 $warning_template = new Text::Template (
76 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
77 ) or warn "can't create warning email template: $Text::Template::ERROR";
78 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
79 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
80 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
81 $warning_cc = $conf->config('warning_email-cc');
83 $warning_template = '';
85 $warning_subject = '';
86 $warning_mimetype = '';
89 $smtpmachine = $conf->config('smtpmachine');
90 $radius_password = $conf->config('radius-password') || 'Password';
91 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
92 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
96 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
97 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
101 my ( $hashref, $cache ) = @_;
102 if ( $hashref->{'svc_acct_svcnum'} ) {
103 $self->{'_domsvc'} = FS::svc_domain->new( {
104 'svcnum' => $hashref->{'domsvc'},
105 'domain' => $hashref->{'svc_acct_domain'},
106 'catchall' => $hashref->{'svc_acct_catchall'},
113 FS::svc_acct - Object methods for svc_acct records
119 $record = new FS::svc_acct \%hash;
120 $record = new FS::svc_acct { 'column' => 'value' };
122 $error = $record->insert;
124 $error = $new_record->replace($old_record);
126 $error = $record->delete;
128 $error = $record->check;
130 $error = $record->suspend;
132 $error = $record->unsuspend;
134 $error = $record->cancel;
136 %hash = $record->radius;
138 %hash = $record->radius_reply;
140 %hash = $record->radius_check;
142 $domain = $record->domain;
144 $svc_domain = $record->svc_domain;
146 $email = $record->email;
148 $seconds_since = $record->seconds_since($timestamp);
152 An FS::svc_acct object represents an account. FS::svc_acct inherits from
153 FS::svc_Common. The following fields are currently supported:
157 =item svcnum - primary key (assigned automatcially for new accounts)
161 =item _password - generated if blank
163 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
165 =item sec_phrase - security phrase
167 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
175 =item dir - set automatically if blank (and uid is not)
179 =item quota - (unimplementd)
181 =item slipip - IP address
191 =item domsvc - svcnum from svc_domain
193 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
195 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
205 Creates a new account. To add the account to the database, see L<"insert">.
212 'longname_plural' => 'Access accounts and mailboxes',
213 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
214 'display_weight' => 10,
215 'cancel_weight' => 50,
217 'dir' => 'Home directory',
220 def_info => 'set to fixed and blank for no UIDs',
223 'slipip' => 'IP address',
224 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
226 label => 'Access number',
228 select_table => 'svc_acct_pop',
229 select_key => 'popnum',
230 select_label => 'city',
236 disable_default => 1,
243 disable_inventory => 1,
246 '_password' => 'Password',
249 def_info => 'when blank, defaults to UID',
254 def_info => 'set to blank for no shell tracking',
256 #select_list => [ $conf->config('shells') ],
257 select_list => [ $conf ? $conf->config('shells') : () ],
258 disable_inventory => 1,
261 'finger' => 'Real name', # (GECOS)',
265 select_table => 'svc_domain',
266 select_key => 'svcnum',
267 select_label => 'domain',
268 disable_inventory => 1,
272 label => 'RADIUS groups',
273 type => 'radius_usergroup_selector',
274 disable_inventory => 1,
277 'seconds' => { label => 'Seconds',
278 label_sort => 'with Time Remaining',
280 disable_inventory => 1,
282 disable_part_svc_column => 1,
284 'upbytes' => { label => 'Upload',
286 disable_inventory => 1,
288 'format' => \&FS::UI::bytecount::display_bytecount,
289 'parse' => \&FS::UI::bytecount::parse_bytecount,
290 disable_part_svc_column => 1,
292 'downbytes' => { label => 'Download',
294 disable_inventory => 1,
296 'format' => \&FS::UI::bytecount::display_bytecount,
297 'parse' => \&FS::UI::bytecount::parse_bytecount,
298 disable_part_svc_column => 1,
300 'totalbytes'=> { label => 'Total up and download',
302 disable_inventory => 1,
304 'format' => \&FS::UI::bytecount::display_bytecount,
305 'parse' => \&FS::UI::bytecount::parse_bytecount,
306 disable_part_svc_column => 1,
308 'seconds_threshold' => { label => 'Seconds threshold',
310 disable_inventory => 1,
312 disable_part_svc_column => 1,
314 'upbytes_threshold' => { label => 'Upload threshold',
316 disable_inventory => 1,
318 'format' => \&FS::UI::bytecount::display_bytecount,
319 'parse' => \&FS::UI::bytecount::parse_bytecount,
320 disable_part_svc_column => 1,
322 'downbytes_threshold' => { label => 'Download threshold',
324 disable_inventory => 1,
326 'format' => \&FS::UI::bytecount::display_bytecount,
327 'parse' => \&FS::UI::bytecount::parse_bytecount,
328 disable_part_svc_column => 1,
330 'totalbytes_threshold'=> { label => 'Total up and download threshold',
332 disable_inventory => 1,
334 'format' => \&FS::UI::bytecount::display_bytecount,
335 'parse' => \&FS::UI::bytecount::parse_bytecount,
336 disable_part_svc_column => 1,
339 label => 'Last login',
343 label => 'Last logout',
350 sub table { 'svc_acct'; }
352 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
356 #false laziness with edit/svc_acct.cgi
358 my( $self, $groups ) = @_;
359 if ( ref($groups) eq 'ARRAY' ) {
361 } elsif ( length($groups) ) {
362 [ split(/\s*,\s*/, $groups) ];
371 shift->_lastlog('in', @_);
375 shift->_lastlog('out', @_);
379 my( $self, $op, $time ) = @_;
381 if ( defined($time) ) {
382 warn "$me last_log$op called on svcnum ". $self->svcnum.
383 ' ('. $self->email. "): $time\n"
388 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
392 my $sth = $dbh->prepare( $sql )
393 or die "Error preparing $sql: ". $dbh->errstr;
394 my $rv = $sth->execute($time, $self->svcnum);
395 die "Error executing $sql: ". $sth->errstr
397 die "Can't update last_log$op for svcnum". $self->svcnum
400 $self->{'Hash'}->{"last_log$op"} = $time;
402 $self->getfield("last_log$op");
406 =item search_sql STRING
408 Class method which returns an SQL fragment to search for the given string.
413 my( $class, $string ) = @_;
414 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
415 my( $username, $domain ) = ( $1, $2 );
416 my $q_username = dbh->quote($username);
417 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
419 "svc_acct.username = $q_username AND ( ".
420 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
425 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
427 $class->search_sql_field('slipip', $string ).
429 $class->search_sql_field('username', $string ).
433 $class->search_sql_field('username', $string).
435 ? 'OR '. $class->search_sql_field('svcnum', $string)
442 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
444 Returns the "username@domain" string for this account.
446 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
456 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
458 Returns a longer string label for this acccount ("Real Name <username@domain>"
459 if available, or "username@domain").
461 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
468 my $label = $self->label(@_);
469 my $finger = $self->finger;
470 return $label unless $finger =~ /\S/;
471 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
472 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
476 =item insert [ , OPTION => VALUE ... ]
478 Adds this account to the database. If there is an error, returns the error,
479 otherwise returns false.
481 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
482 defined. An FS::cust_svc record will be created and inserted.
484 The additional field I<usergroup> can optionally be defined; if so it should
485 contain an arrayref of group names. See L<FS::radius_usergroup>.
487 The additional field I<child_objects> can optionally be defined; if so it
488 should contain an arrayref of FS::tablename objects. They will have their
489 svcnum fields set and will be inserted after this record, but before any
490 exports are run. Each element of the array can also optionally be a
491 two-element array reference containing the child object and the name of an
492 alternate field to be filled in with the newly-inserted svcnum, for example
493 C<[ $svc_forward, 'srcsvc' ]>
495 Currently available options are: I<depend_jobnum>
497 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
498 jobnums), all provisioning jobs will have a dependancy on the supplied
499 jobnum(s) (they will not run until the specific job(s) complete(s)).
501 (TODOC: L<FS::queue> and L<freeside-queued>)
503 (TODOC: new exports!)
512 warn "[$me] insert called on $self: ". Dumper($self).
513 "\nwith options: ". Dumper(%options);
516 local $SIG{HUP} = 'IGNORE';
517 local $SIG{INT} = 'IGNORE';
518 local $SIG{QUIT} = 'IGNORE';
519 local $SIG{TERM} = 'IGNORE';
520 local $SIG{TSTP} = 'IGNORE';
521 local $SIG{PIPE} = 'IGNORE';
523 my $oldAutoCommit = $FS::UID::AutoCommit;
524 local $FS::UID::AutoCommit = 0;
527 my $error = $self->check;
528 return $error if $error;
530 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
531 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
532 unless ( $cust_svc ) {
533 $dbh->rollback if $oldAutoCommit;
534 return "no cust_svc record found for svcnum ". $self->svcnum;
536 $self->pkgnum($cust_svc->pkgnum);
537 $self->svcpart($cust_svc->svcpart);
540 # set usage fields and thresholds if unset but set in a package def
541 if ( $self->pkgnum ) {
542 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
543 my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
544 if ( $part_pkg && $part_pkg->can('usage_valuehash') ) {
546 my %values = $part_pkg->usage_valuehash;
547 my $multiplier = $conf->exists('svc_acct-usage_threshold')
548 ? 1 - $conf->config('svc_acct-usage_threshold')/100
549 : 0.20; #doesn't matter
551 foreach ( keys %values ) {
552 next if $self->getfield($_);
553 $self->setfield( $_, $values{$_} );
554 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
555 if $conf->exists('svc_acct-usage_threshold');
562 $error = $self->SUPER::insert(
563 'jobnums' => \@jobnums,
564 'child_objects' => $self->child_objects,
568 $dbh->rollback if $oldAutoCommit;
572 if ( $self->usergroup ) {
573 foreach my $groupname ( @{$self->usergroup} ) {
574 my $radius_usergroup = new FS::radius_usergroup ( {
575 svcnum => $self->svcnum,
576 groupname => $groupname,
578 my $error = $radius_usergroup->insert;
580 $dbh->rollback if $oldAutoCommit;
586 unless ( $skip_fuzzyfiles ) {
587 $error = $self->queue_fuzzyfiles_update;
589 $dbh->rollback if $oldAutoCommit;
590 return "updating fuzzy search cache: $error";
594 my $cust_pkg = $self->cust_svc->cust_pkg;
597 my $cust_main = $cust_pkg->cust_main;
598 my $agentnum = $cust_main->agentnum;
600 if ( $conf->exists('emailinvoiceautoalways')
601 || $conf->exists('emailinvoiceauto')
602 && ! $cust_main->invoicing_list_emailonly
604 my @invoicing_list = $cust_main->invoicing_list;
605 push @invoicing_list, $self->email;
606 $cust_main->invoicing_list(\@invoicing_list);
610 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
611 = ('','','','','','');
613 if ( $conf->exists('welcome_email', $agentnum) ) {
614 $welcome_template = new Text::Template (
616 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
617 ) or warn "can't create welcome email template: $Text::Template::ERROR";
618 $welcome_from = $conf->config('welcome_email-from', $agentnum);
619 # || 'your-isp-is-dum'
620 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
622 $welcome_subject_template = new Text::Template (
624 SOURCE => $welcome_subject,
625 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
626 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
629 if ( $welcome_template && $cust_pkg ) {
630 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
634 'custnum' => $self->custnum,
635 'username' => $self->username,
636 'password' => $self->_password,
637 'first' => $cust_main->first,
638 'last' => $cust_main->getfield('last'),
639 'pkg' => $cust_pkg->part_pkg->pkg,
641 my $wqueue = new FS::queue {
642 'svcnum' => $self->svcnum,
643 'job' => 'FS::svc_acct::send_email'
645 my $error = $wqueue->insert(
647 'from' => $welcome_from,
648 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
649 'mimetype' => $welcome_mimetype,
650 'body' => $welcome_template->fill_in( HASH => \%hash, ),
653 $dbh->rollback if $oldAutoCommit;
654 return "error queuing welcome email: $error";
657 if ( $options{'depend_jobnum'} ) {
658 warn "$me depend_jobnum found; adding to welcome email dependancies"
660 if ( ref($options{'depend_jobnum'}) ) {
661 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
662 "to welcome email dependancies"
664 push @jobnums, @{ $options{'depend_jobnum'} };
666 warn "$me adding job $options{'depend_jobnum'} ".
667 "to welcome email dependancies"
669 push @jobnums, $options{'depend_jobnum'};
673 foreach my $jobnum ( @jobnums ) {
674 my $error = $wqueue->depend_insert($jobnum);
676 $dbh->rollback if $oldAutoCommit;
677 return "error queuing welcome email job dependancy: $error";
687 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
693 Deletes this account from the database. If there is an error, returns the
694 error, otherwise returns false.
696 The corresponding FS::cust_svc record will be deleted as well.
698 (TODOC: new exports!)
705 return "can't delete system account" if $self->_check_system;
707 return "Can't delete an account which is a (svc_forward) source!"
708 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
710 return "Can't delete an account which is a (svc_forward) destination!"
711 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
713 return "Can't delete an account with (svc_www) web service!"
714 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
716 # what about records in session ? (they should refer to history table)
718 local $SIG{HUP} = 'IGNORE';
719 local $SIG{INT} = 'IGNORE';
720 local $SIG{QUIT} = 'IGNORE';
721 local $SIG{TERM} = 'IGNORE';
722 local $SIG{TSTP} = 'IGNORE';
723 local $SIG{PIPE} = 'IGNORE';
725 my $oldAutoCommit = $FS::UID::AutoCommit;
726 local $FS::UID::AutoCommit = 0;
729 foreach my $cust_main_invoice (
730 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
732 unless ( defined($cust_main_invoice) ) {
733 warn "WARNING: something's wrong with qsearch";
736 my %hash = $cust_main_invoice->hash;
737 $hash{'dest'} = $self->email;
738 my $new = new FS::cust_main_invoice \%hash;
739 my $error = $new->replace($cust_main_invoice);
741 $dbh->rollback if $oldAutoCommit;
746 foreach my $svc_domain (
747 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
749 my %hash = new FS::svc_domain->hash;
750 $hash{'catchall'} = '';
751 my $new = new FS::svc_domain \%hash;
752 my $error = $new->replace($svc_domain);
754 $dbh->rollback if $oldAutoCommit;
759 my $error = $self->SUPER::delete;
761 $dbh->rollback if $oldAutoCommit;
765 foreach my $radius_usergroup (
766 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
768 my $error = $radius_usergroup->delete;
770 $dbh->rollback if $oldAutoCommit;
775 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
779 =item replace OLD_RECORD
781 Replaces OLD_RECORD with this one in the database. If there is an error,
782 returns the error, otherwise returns false.
784 The additional field I<usergroup> can optionally be defined; if so it should
785 contain an arrayref of group names. See L<FS::radius_usergroup>.
793 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
797 warn "$me replacing $old with $new\n" if $DEBUG;
801 return "can't modify system account" if $old->_check_system;
804 #no warnings 'numeric'; #alas, a 5.006-ism
807 foreach my $xid (qw( uid gid )) {
809 return "Can't change $xid!"
810 if ! $conf->exists("svc_acct-edit_$xid")
811 && $old->$xid() != $new->$xid()
812 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
817 #change homdir when we change username
818 $new->setfield('dir', '') if $old->username ne $new->username;
820 local $SIG{HUP} = 'IGNORE';
821 local $SIG{INT} = 'IGNORE';
822 local $SIG{QUIT} = 'IGNORE';
823 local $SIG{TERM} = 'IGNORE';
824 local $SIG{TSTP} = 'IGNORE';
825 local $SIG{PIPE} = 'IGNORE';
827 my $oldAutoCommit = $FS::UID::AutoCommit;
828 local $FS::UID::AutoCommit = 0;
831 # redundant, but so $new->usergroup gets set
832 $error = $new->check;
833 return $error if $error;
835 $old->usergroup( [ $old->radius_groups ] );
837 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
838 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
840 if ( $new->usergroup ) {
841 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
842 my @newgroups = @{$new->usergroup};
843 foreach my $oldgroup ( @{$old->usergroup} ) {
844 if ( grep { $oldgroup eq $_ } @newgroups ) {
845 @newgroups = grep { $oldgroup ne $_ } @newgroups;
848 my $radius_usergroup = qsearchs('radius_usergroup', {
849 svcnum => $old->svcnum,
850 groupname => $oldgroup,
852 my $error = $radius_usergroup->delete;
854 $dbh->rollback if $oldAutoCommit;
855 return "error deleting radius_usergroup $oldgroup: $error";
859 foreach my $newgroup ( @newgroups ) {
860 my $radius_usergroup = new FS::radius_usergroup ( {
861 svcnum => $new->svcnum,
862 groupname => $newgroup,
864 my $error = $radius_usergroup->insert;
866 $dbh->rollback if $oldAutoCommit;
867 return "error adding radius_usergroup $newgroup: $error";
873 $error = $new->SUPER::replace($old, @_);
875 $dbh->rollback if $oldAutoCommit;
876 return $error if $error;
879 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
880 $error = $new->queue_fuzzyfiles_update;
882 $dbh->rollback if $oldAutoCommit;
883 return "updating fuzzy search cache: $error";
887 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
891 =item queue_fuzzyfiles_update
893 Used by insert & replace to update the fuzzy search cache
897 sub queue_fuzzyfiles_update {
900 local $SIG{HUP} = 'IGNORE';
901 local $SIG{INT} = 'IGNORE';
902 local $SIG{QUIT} = 'IGNORE';
903 local $SIG{TERM} = 'IGNORE';
904 local $SIG{TSTP} = 'IGNORE';
905 local $SIG{PIPE} = 'IGNORE';
907 my $oldAutoCommit = $FS::UID::AutoCommit;
908 local $FS::UID::AutoCommit = 0;
911 my $queue = new FS::queue {
912 'svcnum' => $self->svcnum,
913 'job' => 'FS::svc_acct::append_fuzzyfiles'
915 my $error = $queue->insert($self->username);
917 $dbh->rollback if $oldAutoCommit;
918 return "queueing job (transaction rolled back): $error";
921 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
929 Suspends this account by calling export-specific suspend hooks. If there is
930 an error, returns the error, otherwise returns false.
932 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
938 return "can't suspend system account" if $self->_check_system;
939 $self->SUPER::suspend(@_);
944 Unsuspends this account by by calling export-specific suspend hooks. If there
945 is an error, returns the error, otherwise returns false.
947 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
953 my %hash = $self->hash;
954 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
955 $hash{_password} = $1;
956 my $new = new FS::svc_acct ( \%hash );
957 my $error = $new->replace($self);
958 return $error if $error;
961 $self->SUPER::unsuspend(@_);
966 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
968 If the B<auto_unset_catchall> configuration option is set, this method will
969 automatically remove any references to the canceled service in the catchall
970 field of svc_domain. This allows packages that contain both a svc_domain and
971 its catchall svc_acct to be canceled in one step.
976 # Only one thing to do at this level
978 foreach my $svc_domain (
979 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
980 if($conf->exists('auto_unset_catchall')) {
981 my %hash = $svc_domain->hash;
982 $hash{catchall} = '';
983 my $new = new FS::svc_domain ( \%hash );
984 my $error = $new->replace($svc_domain);
985 return $error if $error;
987 return "cannot unprovision svc_acct #".$self->svcnum.
988 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
992 $self->SUPER::cancel(@_);
998 Checks all fields to make sure this is a valid service. If there is an error,
999 returns the error, otherwise returns false. Called by the insert and replace
1002 Sets any fixed values; see L<FS::part_svc>.
1009 my($recref) = $self->hashref;
1011 my $x = $self->setfixed( $self->_fieldhandlers );
1012 return $x unless ref($x);
1015 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1017 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1020 my $error = $self->ut_numbern('svcnum')
1021 #|| $self->ut_number('domsvc')
1022 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1023 || $self->ut_textn('sec_phrase')
1024 || $self->ut_snumbern('seconds')
1025 || $self->ut_snumbern('upbytes')
1026 || $self->ut_snumbern('downbytes')
1027 || $self->ut_snumbern('totalbytes')
1028 || $self->ut_enum( '_password_encoding',
1029 [ '', qw( plain crypt ldap ) ]
1032 return $error if $error;
1035 local $username_letter = $username_letter;
1036 if ($self->svcnum) {
1037 my $cust_svc = $self->cust_svc
1038 or return "no cust_svc record found for svcnum ". $self->svcnum;
1039 my $cust_pkg = $cust_svc->cust_pkg;
1041 if ($self->pkgnum) {
1042 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1046 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1049 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1050 if ( $username_uppercase ) {
1051 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1052 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1053 $recref->{username} = $1;
1055 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1056 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1057 $recref->{username} = $1;
1060 if ( $username_letterfirst ) {
1061 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1062 } elsif ( $username_letter ) {
1063 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1065 if ( $username_noperiod ) {
1066 $recref->{username} =~ /\./ and return gettext('illegal_username');
1068 if ( $username_nounderscore ) {
1069 $recref->{username} =~ /_/ and return gettext('illegal_username');
1071 if ( $username_nodash ) {
1072 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1074 unless ( $username_ampersand ) {
1075 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1077 unless ( $username_percent ) {
1078 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1080 unless ( $username_colon ) {
1081 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1084 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1085 $recref->{popnum} = $1;
1086 return "Unknown popnum" unless
1087 ! $recref->{popnum} ||
1088 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1090 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1092 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1093 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1095 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1096 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1097 #not all systems use gid=uid
1098 #you can set a fixed gid in part_svc
1100 return "Only root can have uid 0"
1101 if $recref->{uid} == 0
1102 && $recref->{username} !~ /^(root|toor|smtp)$/;
1104 unless ( $recref->{username} eq 'sync' ) {
1105 if ( grep $_ eq $recref->{shell}, @shells ) {
1106 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1108 return "Illegal shell \`". $self->shell. "\'; ".
1109 "shells configuration value contains: @shells";
1112 $recref->{shell} = '/bin/sync';
1116 $recref->{gid} ne '' ?
1117 return "Can't have gid without uid" : ( $recref->{gid}='' );
1118 #$recref->{dir} ne '' ?
1119 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1120 $recref->{shell} ne '' ?
1121 return "Can't have shell without uid" : ( $recref->{shell}='' );
1124 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1126 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1127 or return "Illegal directory: ". $recref->{dir};
1128 $recref->{dir} = $1;
1129 return "Illegal directory"
1130 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1131 return "Illegal directory"
1132 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1133 unless ( $recref->{dir} ) {
1134 $recref->{dir} = $dir_prefix . '/';
1135 if ( $dirhash > 0 ) {
1136 for my $h ( 1 .. $dirhash ) {
1137 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1139 } elsif ( $dirhash < 0 ) {
1140 for my $h ( reverse $dirhash .. -1 ) {
1141 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1144 $recref->{dir} .= $recref->{username};
1150 # $error = $self->ut_textn('finger');
1151 # return $error if $error;
1152 if ( $self->getfield('finger') eq '' ) {
1153 my $cust_pkg = $self->svcnum
1154 ? $self->cust_svc->cust_pkg
1155 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1157 my $cust_main = $cust_pkg->cust_main;
1158 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1161 $self->getfield('finger') =~
1162 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1163 or return "Illegal finger: ". $self->getfield('finger');
1164 $self->setfield('finger', $1);
1166 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1167 $recref->{quota} = $1;
1169 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1170 if ( $recref->{slipip} eq '' ) {
1171 $recref->{slipip} = '';
1172 } elsif ( $recref->{slipip} eq '0e0' ) {
1173 $recref->{slipip} = '0e0';
1175 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1176 or return "Illegal slipip: ". $self->slipip;
1177 $recref->{slipip} = $1;
1182 #arbitrary RADIUS stuff; allow ut_textn for now
1183 foreach ( grep /^radius_/, fields('svc_acct') ) {
1184 $self->ut_textn($_);
1187 if ( $recref->{_password_encoding} eq 'ldap' ) {
1189 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1190 $recref->{_password} = uc($1).$2;
1192 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1195 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1197 if ( $recref->{_password} =~
1198 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1199 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1202 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1205 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1208 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1210 #generate a password if it is blank
1211 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1212 unless length( $recref->{_password} );
1214 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1215 $recref->{_password} = $1;
1217 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1218 FS::Msgcat::_gettext('illegal_password_characters').
1219 ": ". $recref->{_password};
1222 if ( $password_noampersand ) {
1223 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1225 if ( $password_noexclamation ) {
1226 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1231 #carp "warning: _password_encoding unspecified\n";
1233 #generate a password if it is blank
1234 unless ( length( $recref->{_password} ) ) {
1236 $recref->{_password} =
1237 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1238 $recref->{_password_encoding} = 'plain';
1242 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1243 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1244 $recref->{_password} = $1.$3;
1245 $recref->{_password_encoding} = 'plain';
1246 } elsif ( $recref->{_password} =~
1247 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1249 $recref->{_password} = $1.$3;
1250 $recref->{_password_encoding} = 'crypt';
1251 } elsif ( $recref->{_password} eq '*' ) {
1252 $recref->{_password} = '*';
1253 $recref->{_password_encoding} = 'crypt';
1254 } elsif ( $recref->{_password} eq '!' ) {
1255 $recref->{_password_encoding} = 'crypt';
1256 $recref->{_password} = '!';
1257 } elsif ( $recref->{_password} eq '!!' ) {
1258 $recref->{_password} = '!!';
1259 $recref->{_password_encoding} = 'crypt';
1261 #return "Illegal password";
1262 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1263 FS::Msgcat::_gettext('illegal_password_characters').
1264 ": ". $recref->{_password};
1271 $self->SUPER::check;
1277 Internal function to check the username against the list of system usernames
1278 from the I<system_usernames> configuration value. Returns true if the username
1279 is listed on the system username list.
1285 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1286 $conf->config('system_usernames')
1290 =item _check_duplicate
1292 Internal method to check for duplicates usernames, username@domain pairs and
1295 If the I<global_unique-username> configuration value is set to B<username> or
1296 B<username@domain>, enforces global username or username@domain uniqueness.
1298 In all cases, check for duplicate uids and usernames or username@domain pairs
1299 per export and with identical I<svcpart> values.
1303 sub _check_duplicate {
1306 my $global_unique = $conf->config('global_unique-username') || 'none';
1307 return '' if $global_unique eq 'disabled';
1311 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1312 unless ( $part_svc ) {
1313 return 'unknown svcpart '. $self->svcpart;
1316 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1317 qsearch( 'svc_acct', { 'username' => $self->username } );
1318 return gettext('username_in_use')
1319 if $global_unique eq 'username' && @dup_user;
1321 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1322 qsearch( 'svc_acct', { 'username' => $self->username,
1323 'domsvc' => $self->domsvc } );
1324 return gettext('username_in_use')
1325 if $global_unique eq 'username@domain' && @dup_userdomain;
1328 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1329 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1330 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1331 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1336 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1337 my $exports = FS::part_export::export_info('svc_acct');
1338 my %conflict_user_svcpart;
1339 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1341 foreach my $part_export ( $part_svc->part_export ) {
1343 #this will catch to the same exact export
1344 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1346 #this will catch to exports w/same exporthost+type ???
1347 #my @other_part_export = qsearch('part_export', {
1348 # 'machine' => $part_export->machine,
1349 # 'exporttype' => $part_export->exporttype,
1351 #foreach my $other_part_export ( @other_part_export ) {
1352 # push @svcparts, map { $_->svcpart }
1353 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1356 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1357 #silly kludge to avoid uninitialized value errors
1358 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1359 ? $exports->{$part_export->exporttype}{'nodomain'}
1361 if ( $nodomain =~ /^Y/i ) {
1362 $conflict_user_svcpart{$_} = $part_export->exportnum
1365 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1370 foreach my $dup_user ( @dup_user ) {
1371 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1372 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1373 return "duplicate username ". $self->username.
1374 ": conflicts with svcnum ". $dup_user->svcnum.
1375 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1379 foreach my $dup_userdomain ( @dup_userdomain ) {
1380 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1381 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1382 return "duplicate username\@domain ". $self->email.
1383 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1384 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1388 foreach my $dup_uid ( @dup_uid ) {
1389 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1390 if ( exists($conflict_user_svcpart{$dup_svcpart})
1391 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1392 return "duplicate uid ". $self->uid.
1393 ": conflicts with svcnum ". $dup_uid->svcnum.
1395 ( $conflict_user_svcpart{$dup_svcpart}
1396 || $conflict_userdomain_svcpart{$dup_svcpart} );
1408 Depriciated, use radius_reply instead.
1413 carp "FS::svc_acct::radius depriciated, use radius_reply";
1414 $_[0]->radius_reply;
1419 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1420 reply attributes of this record.
1422 Note that this is now the preferred method for reading RADIUS attributes -
1423 accessing the columns directly is discouraged, as the column names are
1424 expected to change in the future.
1431 return %{ $self->{'radius_reply'} }
1432 if exists $self->{'radius_reply'};
1437 my($column, $attrib) = ($1, $2);
1438 #$attrib =~ s/_/\-/g;
1439 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1440 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1442 if ( $self->slipip && $self->slipip ne '0e0' ) {
1443 $reply{$radius_ip} = $self->slipip;
1446 if ( $self->seconds !~ /^$/ ) {
1447 $reply{'Session-Timeout'} = $self->seconds;
1450 if ( $conf->exists('radius-chillispot-max') ) {
1451 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1453 #hmm. just because sqlradius.pm says so?
1460 foreach my $what (qw( input output total )) {
1461 my $is = $whatis{$what}.'bytes';
1462 if ( $self->$is() =~ /\d/ ) {
1463 my $big = new Math::BigInt $self->$is();
1464 $big = new Math::BigInt '0' if $big->is_neg();
1465 my $att = "Chillispot-Max-\u$what";
1466 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1467 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1478 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1479 check attributes of this record.
1481 Note that this is now the preferred method for reading RADIUS attributes -
1482 accessing the columns directly is discouraged, as the column names are
1483 expected to change in the future.
1490 return %{ $self->{'radius_check'} }
1491 if exists $self->{'radius_check'};
1496 my($column, $attrib) = ($1, $2);
1497 #$attrib =~ s/_/\-/g;
1498 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1499 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1502 my($pw_attrib, $password) = $self->radius_password;
1503 $check{$pw_attrib} = $password;
1505 my $cust_svc = $self->cust_svc;
1507 my $cust_pkg = $cust_svc->cust_pkg;
1508 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1509 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1512 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1513 "; can't set Expiration\n"
1521 =item radius_password
1523 Returns a key/value pair containing the RADIUS attribute name and value
1528 sub radius_password {
1531 my($pw_attrib, $password);
1532 if ( $self->_password_encoding eq 'ldap' ) {
1534 $pw_attrib = 'Password-With-Header';
1535 $password = $self->_password;
1537 } elsif ( $self->_password_encoding eq 'crypt' ) {
1539 $pw_attrib = 'Crypt-Password';
1540 $password = $self->_password;
1542 } elsif ( $self->_password_encoding eq 'plain' ) {
1544 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1545 $password = $self->_password;
1549 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1550 $password = $self->_password;
1554 ($pw_attrib, $password);
1560 This method instructs the object to "snapshot" or freeze RADIUS check and
1561 reply attributes to the current values.
1565 #bah, my english is too broken this morning
1566 #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
1567 #the FS::cust_pkg's replace method to trigger the correct export updates when
1568 #package dates change)
1573 $self->{$_} = { $self->$_() }
1574 foreach qw( radius_reply radius_check );
1578 =item forget_snapshot
1580 This methos instructs the object to forget any previously snapshotted
1581 RADIUS check and reply attributes.
1585 sub forget_snapshot {
1589 foreach qw( radius_reply radius_check );
1593 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1595 Returns the domain associated with this account.
1597 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1604 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1605 my $svc_domain = $self->svc_domain(@_)
1606 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1607 $svc_domain->domain;
1612 Returns the FS::svc_domain record for this account's domain (see
1617 # FS::h_svc_acct has a history-aware svc_domain override
1622 ? $self->{'_domsvc'}
1623 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1628 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1632 #inherited from svc_Common
1634 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1636 Returns an email address associated with the account.
1638 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1645 $self->username. '@'. $self->domain(@_);
1650 Returns an array of FS::acct_snarf records associated with the account.
1651 If the acct_snarf table does not exist or there are no associated records,
1652 an empty list is returned
1658 return () unless dbdef->table('acct_snarf');
1659 eval "use FS::acct_snarf;";
1661 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1664 =item decrement_upbytes OCTETS
1666 Decrements the I<upbytes> field of this record by the given amount. If there
1667 is an error, returns the error, otherwise returns false.
1671 sub decrement_upbytes {
1672 shift->_op_usage('-', 'upbytes', @_);
1675 =item increment_upbytes OCTETS
1677 Increments the I<upbytes> field of this record by the given amount. If there
1678 is an error, returns the error, otherwise returns false.
1682 sub increment_upbytes {
1683 shift->_op_usage('+', 'upbytes', @_);
1686 =item decrement_downbytes OCTETS
1688 Decrements the I<downbytes> field of this record by the given amount. If there
1689 is an error, returns the error, otherwise returns false.
1693 sub decrement_downbytes {
1694 shift->_op_usage('-', 'downbytes', @_);
1697 =item increment_downbytes OCTETS
1699 Increments the I<downbytes> field of this record by the given amount. If there
1700 is an error, returns the error, otherwise returns false.
1704 sub increment_downbytes {
1705 shift->_op_usage('+', 'downbytes', @_);
1708 =item decrement_totalbytes OCTETS
1710 Decrements the I<totalbytes> field of this record by the given amount. If there
1711 is an error, returns the error, otherwise returns false.
1715 sub decrement_totalbytes {
1716 shift->_op_usage('-', 'totalbytes', @_);
1719 =item increment_totalbytes OCTETS
1721 Increments the I<totalbytes> field of this record by the given amount. If there
1722 is an error, returns the error, otherwise returns false.
1726 sub increment_totalbytes {
1727 shift->_op_usage('+', 'totalbytes', @_);
1730 =item decrement_seconds SECONDS
1732 Decrements the I<seconds> field of this record by the given amount. If there
1733 is an error, returns the error, otherwise returns false.
1737 sub decrement_seconds {
1738 shift->_op_usage('-', 'seconds', @_);
1741 =item increment_seconds SECONDS
1743 Increments the I<seconds> field of this record by the given amount. If there
1744 is an error, returns the error, otherwise returns false.
1748 sub increment_seconds {
1749 shift->_op_usage('+', 'seconds', @_);
1757 my %op2condition = (
1758 '-' => sub { my($self, $column, $amount) = @_;
1759 $self->$column - $amount <= 0;
1761 '+' => sub { my($self, $column, $amount) = @_;
1762 ($self->$column || 0) + $amount > 0;
1765 my %op2warncondition = (
1766 '-' => sub { my($self, $column, $amount) = @_;
1767 my $threshold = $column . '_threshold';
1768 $self->$column - $amount <= $self->$threshold + 0;
1770 '+' => sub { my($self, $column, $amount) = @_;
1771 ($self->$column || 0) + $amount > 0;
1776 my( $self, $op, $column, $amount ) = @_;
1778 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1779 ' ('. $self->email. "): $op $amount\n"
1782 return '' unless $amount;
1784 local $SIG{HUP} = 'IGNORE';
1785 local $SIG{INT} = 'IGNORE';
1786 local $SIG{QUIT} = 'IGNORE';
1787 local $SIG{TERM} = 'IGNORE';
1788 local $SIG{TSTP} = 'IGNORE';
1789 local $SIG{PIPE} = 'IGNORE';
1791 my $oldAutoCommit = $FS::UID::AutoCommit;
1792 local $FS::UID::AutoCommit = 0;
1795 my $sql = "UPDATE svc_acct SET $column = ".
1796 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1797 " $op ? WHERE svcnum = ?";
1801 my $sth = $dbh->prepare( $sql )
1802 or die "Error preparing $sql: ". $dbh->errstr;
1803 my $rv = $sth->execute($amount, $self->svcnum);
1804 die "Error executing $sql: ". $sth->errstr
1805 unless defined($rv);
1806 die "Can't update $column for svcnum". $self->svcnum
1809 #$self->snapshot; #not necessary, we retain the old values
1810 #create an object with the updated usage values
1811 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1813 my $error = $new->replace($self);
1815 $dbh->rollback if $oldAutoCommit;
1816 return "Error replacing: $error";
1819 #overlimit_action eq 'cancel' handling
1820 my $cust_pkg = $self->cust_svc->cust_pkg;
1822 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1823 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1827 my $error = $cust_pkg->cancel; #XXX should have a reason
1829 $dbh->rollback if $oldAutoCommit;
1830 return "Error cancelling: $error";
1833 #nothing else is relevant if we're cancelling, so commit & return success
1834 warn "$me update successful; committing\n"
1836 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1841 my $action = $op2action{$op};
1843 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1844 ( $action eq 'suspend' && !$self->overlimit
1845 || $action eq 'unsuspend' && $self->overlimit )
1847 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1848 if ($part_export->option('overlimit_groups')) {
1850 my $other = new FS::svc_acct $self->hashref;
1851 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1852 ($self, $part_export->option('overlimit_groups'));
1853 $other->usergroup( $groups );
1854 if ($action eq 'suspend'){
1855 $new = $other; $old = $self;
1857 $new = $self; $old = $other;
1859 my $error = $part_export->export_replace($new, $old);
1860 $error ||= $self->overlimit($action);
1862 $dbh->rollback if $oldAutoCommit;
1863 return "Error replacing radius groups in export, ${op}: $error";
1869 if ( $conf->exists("svc_acct-usage_$action")
1870 && &{$op2condition{$op}}($self, $column, $amount) ) {
1871 #my $error = $self->$action();
1872 my $error = $self->cust_svc->cust_pkg->$action();
1873 # $error ||= $self->overlimit($action);
1875 $dbh->rollback if $oldAutoCommit;
1876 return "Error ${action}ing: $error";
1880 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1881 my $wqueue = new FS::queue {
1882 'svcnum' => $self->svcnum,
1883 'job' => 'FS::svc_acct::reached_threshold',
1888 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1892 my $error = $wqueue->insert(
1893 'svcnum' => $self->svcnum,
1895 'column' => $column,
1899 $dbh->rollback if $oldAutoCommit;
1900 return "Error queuing threshold activity: $error";
1904 warn "$me update successful; committing\n"
1906 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1912 my( $self, $valueref, %options ) = @_;
1914 warn "$me set_usage called for svcnum ". $self->svcnum.
1915 ' ('. $self->email. "): ".
1916 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1919 local $SIG{HUP} = 'IGNORE';
1920 local $SIG{INT} = 'IGNORE';
1921 local $SIG{QUIT} = 'IGNORE';
1922 local $SIG{TERM} = 'IGNORE';
1923 local $SIG{TSTP} = 'IGNORE';
1924 local $SIG{PIPE} = 'IGNORE';
1926 local $FS::svc_Common::noexport_hack = 1;
1927 my $oldAutoCommit = $FS::UID::AutoCommit;
1928 local $FS::UID::AutoCommit = 0;
1933 if ( $options{null} ) {
1934 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1935 qw( seconds upbytes downbytes totalbytes )
1938 foreach my $field (keys %$valueref){
1939 $reset = 1 if $valueref->{$field};
1940 $self->setfield($field, $valueref->{$field});
1941 $self->setfield( $field.'_threshold',
1942 int($self->getfield($field)
1943 * ( $conf->exists('svc_acct-usage_threshold')
1944 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1949 $handyhash{$field} = $self->getfield($field);
1950 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1952 #my $error = $self->replace; #NO! we avoid the call to ->check for
1953 #die $error if $error; #services not explicity changed via the UI
1955 my $sql = "UPDATE svc_acct SET " .
1956 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
1957 " WHERE svcnum = ". $self->svcnum;
1962 if (scalar(keys %handyhash)) {
1963 my $sth = $dbh->prepare( $sql )
1964 or die "Error preparing $sql: ". $dbh->errstr;
1965 my $rv = $sth->execute();
1966 die "Error executing $sql: ". $sth->errstr
1967 unless defined($rv);
1968 die "Can't update usage for svcnum ". $self->svcnum
1972 #$self->snapshot; #not necessary, we retain the old values
1973 #create an object with the updated usage values
1974 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1976 my $error = $new->replace($self);
1978 $dbh->rollback if $oldAutoCommit;
1979 return "Error replacing: $error";
1985 if ($self->overlimit) {
1986 $error = $self->overlimit('unsuspend');
1987 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1988 if ($part_export->option('overlimit_groups')) {
1989 my $old = new FS::svc_acct $self->hashref;
1990 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1991 ($self, $part_export->option('overlimit_groups'));
1992 $old->usergroup( $groups );
1993 $error ||= $part_export->export_replace($self, $old);
1998 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1999 $error ||= $self->cust_svc->cust_pkg->unsuspend;
2002 $dbh->rollback if $oldAutoCommit;
2003 return "Error unsuspending: $error";
2007 warn "$me update successful; committing\n"
2009 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2015 =item recharge HASHREF
2017 Increments usage columns by the amount specified in HASHREF as
2018 column=>amount pairs.
2023 my ($self, $vhash) = @_;
2026 warn "[$me] recharge called on $self: ". Dumper($self).
2027 "\nwith vhash: ". Dumper($vhash);
2030 my $oldAutoCommit = $FS::UID::AutoCommit;
2031 local $FS::UID::AutoCommit = 0;
2035 foreach my $column (keys %$vhash){
2036 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2040 $dbh->rollback if $oldAutoCommit;
2042 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2047 =item is_rechargeable
2049 Returns true if this svc_account can be "recharged" and false otherwise.
2053 sub is_rechargable {
2055 $self->seconds ne ''
2056 || $self->upbytes ne ''
2057 || $self->downbytes ne ''
2058 || $self->totalbytes ne '';
2061 =item seconds_since TIMESTAMP
2063 Returns the number of seconds this account has been online since TIMESTAMP,
2064 according to the session monitor (see L<FS::Session>).
2066 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2067 L<Time::Local> and L<Date::Parse> for conversion functions.
2071 #note: POD here, implementation in FS::cust_svc
2074 $self->cust_svc->seconds_since(@_);
2077 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2079 Returns the numbers of seconds this account has been online between
2080 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2081 external SQL radacct table, specified via sqlradius export. Sessions which
2082 started in the specified range but are still open are counted from session
2083 start to the end of the range (unless they are over 1 day old, in which case
2084 they are presumed missing their stop record and not counted). Also, sessions
2085 which end in the range but started earlier are counted from the start of the
2086 range to session end. Finally, sessions which start before the range but end
2087 after are counted for the entire range.
2089 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2090 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2095 #note: POD here, implementation in FS::cust_svc
2096 sub seconds_since_sqlradacct {
2098 $self->cust_svc->seconds_since_sqlradacct(@_);
2101 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2103 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2104 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2105 TIMESTAMP_END (exclusive).
2107 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2108 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2113 #note: POD here, implementation in FS::cust_svc
2114 sub attribute_since_sqlradacct {
2116 $self->cust_svc->attribute_since_sqlradacct(@_);
2119 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2121 Returns an array of hash references of this customers login history for the
2122 given time range. (document this better)
2126 sub get_session_history {
2128 $self->cust_svc->get_session_history(@_);
2131 =item last_login_text
2133 Returns text describing the time of last login.
2137 sub last_login_text {
2139 $self->last_login ? ctime($self->last_login) : 'unknown';
2142 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2147 my($self, $start, $end, %opt ) = @_;
2149 my $did = $self->username; #yup
2151 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2153 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2155 #SELECT $for_update * FROM cdr
2156 # WHERE calldate >= $start #need a conversion
2157 # AND calldate < $end #ditto
2158 # AND ( charged_party = "$did"
2159 # OR charged_party = "$prefix$did" #if length($prefix);
2160 # OR ( ( charged_party IS NULL OR charged_party = '' )
2162 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2165 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2168 if ( length($prefix) ) {
2170 " AND ( charged_party = '$did'
2171 OR charged_party = '$prefix$did'
2172 OR ( ( charged_party IS NULL OR charged_party = '' )
2174 ( src = '$did' OR src = '$prefix$did' )
2180 " AND ( charged_party = '$did'
2181 OR ( ( charged_party IS NULL OR charged_party = '' )
2191 'select' => "$for_update *",
2194 #( freesidestatus IS NULL OR freesidestatus = '' )
2195 'freesidestatus' => '',
2197 'extra_sql' => $charged_or_src,
2205 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2211 if ( $self->usergroup ) {
2212 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2213 unless ref($self->usergroup) eq 'ARRAY';
2214 #when provisioning records, export callback runs in svc_Common.pm before
2215 #radius_usergroup records can be inserted...
2216 @{$self->usergroup};
2218 map { $_->groupname }
2219 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2223 =item clone_suspended
2225 Constructor used by FS::part_export::_export_suspend fallback. Document
2230 sub clone_suspended {
2232 my %hash = $self->hash;
2233 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2234 new FS::svc_acct \%hash;
2237 =item clone_kludge_unsuspend
2239 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2244 sub clone_kludge_unsuspend {
2246 my %hash = $self->hash;
2247 $hash{_password} = '';
2248 new FS::svc_acct \%hash;
2251 =item check_password
2253 Checks the supplied password against the (possibly encrypted) password in the
2254 database. Returns true for a successful authentication, false for no match.
2256 Currently supported encryptions are: classic DES crypt() and MD5
2260 sub check_password {
2261 my($self, $check_password) = @_;
2263 #remove old-style SUSPENDED kludge, they should be allowed to login to
2264 #self-service and pay up
2265 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2267 if ( $self->_password_encoding eq 'ldap' ) {
2269 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2270 return $auth->match($check_password);
2272 } elsif ( $self->_password_encoding eq 'crypt' ) {
2274 my $auth = from_crypt Authen::Passphrase $self->_password;
2275 return $auth->match($check_password);
2277 } elsif ( $self->_password_encoding eq 'plain' ) {
2279 return $check_password eq $password;
2283 #XXX this could be replaced with Authen::Passphrase stuff
2285 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2287 } elsif ( length($password) < 13 ) { #plaintext
2288 $check_password eq $password;
2289 } elsif ( length($password) == 13 ) { #traditional DES crypt
2290 crypt($check_password, $password) eq $password;
2291 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2292 unix_md5_crypt($check_password, $password) eq $password;
2293 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2294 warn "Can't check password: Blowfish encryption not yet supported, ".
2295 "svcnum ". $self->svcnum. "\n";
2298 warn "Can't check password: Unrecognized encryption for svcnum ".
2299 $self->svcnum. "\n";
2307 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2309 Returns an encrypted password, either by passing through an encrypted password
2310 in the database or by encrypting a plaintext password from the database.
2312 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2313 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2314 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2315 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2316 encryption type is only used if the password is not already encrypted in the
2321 sub crypt_password {
2324 if ( $self->_password_encoding eq 'ldap' ) {
2326 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2329 #XXX this could be replaced with Authen::Passphrase stuff
2331 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2332 if ( $encryption eq 'crypt' ) {
2335 $saltset[int(rand(64))].$saltset[int(rand(64))]
2337 } elsif ( $encryption eq 'md5' ) {
2338 unix_md5_crypt( $self->_password );
2339 } elsif ( $encryption eq 'blowfish' ) {
2340 croak "unknown encryption method $encryption";
2342 croak "unknown encryption method $encryption";
2345 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2349 } elsif ( $self->_password_encoding eq 'crypt' ) {
2351 return $self->_password;
2353 } elsif ( $self->_password_encoding eq 'plain' ) {
2355 #XXX this could be replaced with Authen::Passphrase stuff
2357 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2358 if ( $encryption eq 'crypt' ) {
2361 $saltset[int(rand(64))].$saltset[int(rand(64))]
2363 } elsif ( $encryption eq 'md5' ) {
2364 unix_md5_crypt( $self->_password );
2365 } elsif ( $encryption eq 'blowfish' ) {
2366 croak "unknown encryption method $encryption";
2368 croak "unknown encryption method $encryption";
2373 if ( length($self->_password) == 13
2374 || $self->_password =~ /^\$(1|2a?)\$/
2375 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2381 #XXX this could be replaced with Authen::Passphrase stuff
2383 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2384 if ( $encryption eq 'crypt' ) {
2387 $saltset[int(rand(64))].$saltset[int(rand(64))]
2389 } elsif ( $encryption eq 'md5' ) {
2390 unix_md5_crypt( $self->_password );
2391 } elsif ( $encryption eq 'blowfish' ) {
2392 croak "unknown encryption method $encryption";
2394 croak "unknown encryption method $encryption";
2403 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2405 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2406 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2407 "{MD5}5426824942db4253f87a1009fd5d2d4".
2409 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2410 to work the same as the B</crypt_password> method.
2416 #eventually should check a "password-encoding" field
2418 if ( $self->_password_encoding eq 'ldap' ) {
2420 return $self->_password;
2422 } elsif ( $self->_password_encoding eq 'crypt' ) {
2424 if ( length($self->_password) == 13 ) { #crypt
2425 return '{CRYPT}'. $self->_password;
2426 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2428 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2429 # die "Blowfish encryption not supported in this context, svcnum ".
2430 # $self->svcnum. "\n";
2432 warn "encryption method not (yet?) supported in LDAP context";
2433 return '{CRYPT}*'; #unsupported, should not auth
2436 } elsif ( $self->_password_encoding eq 'plain' ) {
2438 return '{PLAIN}'. $self->_password;
2440 #return '{CLEARTEXT}'. $self->_password; #?
2444 if ( length($self->_password) == 13 ) { #crypt
2445 return '{CRYPT}'. $self->_password;
2446 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2448 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2449 warn "Blowfish encryption not supported in this context, svcnum ".
2450 $self->svcnum. "\n";
2453 #are these two necessary anymore?
2454 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2455 return '{SSHA}'. $1;
2456 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2457 return '{NS-MTA-MD5}'. $1;
2460 return '{PLAIN}'. $self->_password;
2462 #return '{CLEARTEXT}'. $self->_password; #?
2464 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2465 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2466 #if ( $encryption eq 'crypt' ) {
2467 # return '{CRYPT}'. crypt(
2469 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2471 #} elsif ( $encryption eq 'md5' ) {
2472 # unix_md5_crypt( $self->_password );
2473 #} elsif ( $encryption eq 'blowfish' ) {
2474 # croak "unknown encryption method $encryption";
2476 # croak "unknown encryption method $encryption";
2484 =item domain_slash_username
2486 Returns $domain/$username/
2490 sub domain_slash_username {
2492 $self->domain. '/'. $self->username. '/';
2495 =item virtual_maildir
2497 Returns $domain/maildirs/$username/
2501 sub virtual_maildir {
2503 $self->domain. '/maildirs/'. $self->username. '/';
2514 This is the FS::svc_acct job-queue-able version. It still uses
2515 FS::Misc::send_email under-the-hood.
2522 eval "use FS::Misc qw(send_email)";
2525 $opt{mimetype} ||= 'text/plain';
2526 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2528 my $error = send_email(
2529 'from' => $opt{from},
2531 'subject' => $opt{subject},
2532 'content-type' => $opt{mimetype},
2533 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2535 die $error if $error;
2538 =item check_and_rebuild_fuzzyfiles
2542 sub check_and_rebuild_fuzzyfiles {
2543 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2544 -e "$dir/svc_acct.username"
2545 or &rebuild_fuzzyfiles;
2548 =item rebuild_fuzzyfiles
2552 sub rebuild_fuzzyfiles {
2554 use Fcntl qw(:flock);
2556 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2560 open(USERNAMELOCK,">>$dir/svc_acct.username")
2561 or die "can't open $dir/svc_acct.username: $!";
2562 flock(USERNAMELOCK,LOCK_EX)
2563 or die "can't lock $dir/svc_acct.username: $!";
2565 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2567 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2568 or die "can't open $dir/svc_acct.username.tmp: $!";
2569 print USERNAMECACHE join("\n", @all_username), "\n";
2570 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2572 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2582 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2583 open(USERNAMECACHE,"<$dir/svc_acct.username")
2584 or die "can't open $dir/svc_acct.username: $!";
2585 my @array = map { chomp; $_; } <USERNAMECACHE>;
2586 close USERNAMECACHE;
2590 =item append_fuzzyfiles USERNAME
2594 sub append_fuzzyfiles {
2595 my $username = shift;
2597 &check_and_rebuild_fuzzyfiles;
2599 use Fcntl qw(:flock);
2601 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2603 open(USERNAME,">>$dir/svc_acct.username")
2604 or die "can't open $dir/svc_acct.username: $!";
2605 flock(USERNAME,LOCK_EX)
2606 or die "can't lock $dir/svc_acct.username: $!";
2608 print USERNAME "$username\n";
2610 flock(USERNAME,LOCK_UN)
2611 or die "can't unlock $dir/svc_acct.username: $!";
2619 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2623 sub radius_usergroup_selector {
2624 my $sel_groups = shift;
2625 my %sel_groups = map { $_=>1 } @$sel_groups;
2627 my $selectname = shift || 'radius_usergroup';
2630 my $sth = $dbh->prepare(
2631 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2632 ) or die $dbh->errstr;
2633 $sth->execute() or die $sth->errstr;
2634 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2638 function ${selectname}_doadd(object) {
2639 var myvalue = object.${selectname}_add.value;
2640 var optionName = new Option(myvalue,myvalue,false,true);
2641 var length = object.$selectname.length;
2642 object.$selectname.options[length] = optionName;
2643 object.${selectname}_add.value = "";
2646 <SELECT MULTIPLE NAME="$selectname">
2649 foreach my $group ( @all_groups ) {
2650 $html .= qq(<OPTION VALUE="$group");
2651 if ( $sel_groups{$group} ) {
2652 $html .= ' SELECTED';
2653 $sel_groups{$group} = 0;
2655 $html .= ">$group</OPTION>\n";
2657 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2658 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2660 $html .= '</SELECT>';
2662 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2663 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2668 =item reached_threshold
2670 Performs some activities when svc_acct thresholds (such as number of seconds
2671 remaining) are reached.
2675 sub reached_threshold {
2678 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2679 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2681 if ( $opt{'op'} eq '+' ){
2682 $svc_acct->setfield( $opt{'column'}.'_threshold',
2683 int($svc_acct->getfield($opt{'column'})
2684 * ( $conf->exists('svc_acct-usage_threshold')
2685 ? $conf->config('svc_acct-usage_threshold')/100
2690 my $error = $svc_acct->replace;
2691 die $error if $error;
2692 }elsif ( $opt{'op'} eq '-' ){
2694 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2695 return '' if ($threshold eq '' );
2697 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2698 my $error = $svc_acct->replace;
2699 die $error if $error; # email next time, i guess
2701 if ( $warning_template ) {
2702 eval "use FS::Misc qw(send_email)";
2705 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2706 my $cust_main = $cust_pkg->cust_main;
2708 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2709 $cust_main->invoicing_list,
2710 ($opt{'to'} ? $opt{'to'} : ())
2713 my $mimetype = $warning_mimetype;
2714 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2716 my $body = $warning_template->fill_in( HASH => {
2717 'custnum' => $cust_main->custnum,
2718 'username' => $svc_acct->username,
2719 'password' => $svc_acct->_password,
2720 'first' => $cust_main->first,
2721 'last' => $cust_main->getfield('last'),
2722 'pkg' => $cust_pkg->part_pkg->pkg,
2723 'column' => $opt{'column'},
2724 'amount' => $opt{'column'} =~/bytes/
2725 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2726 : $svc_acct->getfield($opt{'column'}),
2727 'threshold' => $opt{'column'} =~/bytes/
2728 ? FS::UI::bytecount::display_bytecount($threshold)
2733 my $error = send_email(
2734 'from' => $warning_from,
2736 'subject' => $warning_subject,
2737 'content-type' => $mimetype,
2738 'body' => [ map "$_\n", split("\n", $body) ],
2740 die $error if $error;
2743 die "unknown op: " . $opt{'op'};
2751 The $recref stuff in sub check should be cleaned up.
2753 The suspend, unsuspend and cancel methods update the database, but not the
2754 current object. This is probably a bug as it's unexpected and
2757 radius_usergroup_selector? putting web ui components in here? they should
2758 probably live somewhere else...
2760 insertion of RADIUS group stuff in insert could be done with child_objects now
2761 (would probably clean up export of them too)
2763 _op_usage and set_usage bypass the history... maybe they shouldn't
2767 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2768 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2769 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2770 L<freeside-queued>), L<FS::svc_acct_pop>,
2771 schema.html from the base documentation.
2775 =item domain_select_hash %OPTIONS
2777 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2778 may at present purchase.
2780 Currently available options are: I<pkgnum> I<svcpart>
2784 sub domain_select_hash {
2785 my ($self, %options) = @_;
2791 $part_svc = $self->part_svc;
2792 $cust_pkg = $self->cust_svc->cust_pkg
2796 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2797 if $options{'svcpart'};
2799 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2800 if $options{'pkgnum'};
2802 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2803 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2804 %domains = map { $_->svcnum => $_->domain }
2805 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2806 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2807 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2808 %domains = map { $_->svcnum => $_->domain }
2809 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2810 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2811 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2813 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2816 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2817 my $svc_domain = qsearchs('svc_domain',
2818 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2819 if ( $svc_domain ) {
2820 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2822 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2823 $part_svc->part_svc_column('domsvc')->columnvalue;