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 ).
432 $class->search_sql_field('username', $string);
436 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
438 Returns the "username@domain" string for this account.
440 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
450 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
452 Returns a longer string label for this acccount ("Real Name <username@domain>"
453 if available, or "username@domain").
455 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
462 my $label = $self->label(@_);
463 my $finger = $self->finger;
464 return $label unless $finger =~ /\S/;
465 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
466 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
470 =item insert [ , OPTION => VALUE ... ]
472 Adds this account to the database. If there is an error, returns the error,
473 otherwise returns false.
475 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
476 defined. An FS::cust_svc record will be created and inserted.
478 The additional field I<usergroup> can optionally be defined; if so it should
479 contain an arrayref of group names. See L<FS::radius_usergroup>.
481 The additional field I<child_objects> can optionally be defined; if so it
482 should contain an arrayref of FS::tablename objects. They will have their
483 svcnum fields set and will be inserted after this record, but before any
484 exports are run. Each element of the array can also optionally be a
485 two-element array reference containing the child object and the name of an
486 alternate field to be filled in with the newly-inserted svcnum, for example
487 C<[ $svc_forward, 'srcsvc' ]>
489 Currently available options are: I<depend_jobnum>
491 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
492 jobnums), all provisioning jobs will have a dependancy on the supplied
493 jobnum(s) (they will not run until the specific job(s) complete(s)).
495 (TODOC: L<FS::queue> and L<freeside-queued>)
497 (TODOC: new exports!)
506 warn "[$me] insert called on $self: ". Dumper($self).
507 "\nwith options: ". Dumper(%options);
510 local $SIG{HUP} = 'IGNORE';
511 local $SIG{INT} = 'IGNORE';
512 local $SIG{QUIT} = 'IGNORE';
513 local $SIG{TERM} = 'IGNORE';
514 local $SIG{TSTP} = 'IGNORE';
515 local $SIG{PIPE} = 'IGNORE';
517 my $oldAutoCommit = $FS::UID::AutoCommit;
518 local $FS::UID::AutoCommit = 0;
521 my $error = $self->check;
522 return $error if $error;
524 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
525 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
526 unless ( $cust_svc ) {
527 $dbh->rollback if $oldAutoCommit;
528 return "no cust_svc record found for svcnum ". $self->svcnum;
530 $self->pkgnum($cust_svc->pkgnum);
531 $self->svcpart($cust_svc->svcpart);
534 # set usage fields and thresholds if unset but set in a package def
535 if ( $self->pkgnum ) {
536 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
537 my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
538 if ( $part_pkg && $part_pkg->can('usage_valuehash') ) {
540 my %values = $part_pkg->usage_valuehash;
541 my $multiplier = $conf->exists('svc_acct-usage_threshold')
542 ? 1 - $conf->config('svc_acct-usage_threshold')/100
543 : 0.20; #doesn't matter
545 foreach ( keys %values ) {
546 next if $self->getfield($_);
547 $self->setfield( $_, $values{$_} );
548 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
549 if $conf->exists('svc_acct-usage_threshold');
556 $error = $self->SUPER::insert(
557 'jobnums' => \@jobnums,
558 'child_objects' => $self->child_objects,
562 $dbh->rollback if $oldAutoCommit;
566 if ( $self->usergroup ) {
567 foreach my $groupname ( @{$self->usergroup} ) {
568 my $radius_usergroup = new FS::radius_usergroup ( {
569 svcnum => $self->svcnum,
570 groupname => $groupname,
572 my $error = $radius_usergroup->insert;
574 $dbh->rollback if $oldAutoCommit;
580 unless ( $skip_fuzzyfiles ) {
581 $error = $self->queue_fuzzyfiles_update;
583 $dbh->rollback if $oldAutoCommit;
584 return "updating fuzzy search cache: $error";
588 my $cust_pkg = $self->cust_svc->cust_pkg;
591 my $cust_main = $cust_pkg->cust_main;
592 my $agentnum = $cust_main->agentnum;
594 if ( $conf->exists('emailinvoiceautoalways')
595 || $conf->exists('emailinvoiceauto')
596 && ! $cust_main->invoicing_list_emailonly
598 my @invoicing_list = $cust_main->invoicing_list;
599 push @invoicing_list, $self->email;
600 $cust_main->invoicing_list(\@invoicing_list);
604 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
605 = ('','','','','','');
607 if ( $conf->exists('welcome_email', $agentnum) ) {
608 $welcome_template = new Text::Template (
610 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
611 ) or warn "can't create welcome email template: $Text::Template::ERROR";
612 $welcome_from = $conf->config('welcome_email-from', $agentnum);
613 # || 'your-isp-is-dum'
614 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
616 $welcome_subject_template = new Text::Template (
618 SOURCE => $welcome_subject,
619 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
620 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
623 if ( $welcome_template && $cust_pkg ) {
624 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
628 'custnum' => $self->custnum,
629 'username' => $self->username,
630 'password' => $self->_password,
631 'first' => $cust_main->first,
632 'last' => $cust_main->getfield('last'),
633 'pkg' => $cust_pkg->part_pkg->pkg,
635 my $wqueue = new FS::queue {
636 'svcnum' => $self->svcnum,
637 'job' => 'FS::svc_acct::send_email'
639 my $error = $wqueue->insert(
641 'from' => $welcome_from,
642 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
643 'mimetype' => $welcome_mimetype,
644 'body' => $welcome_template->fill_in( HASH => \%hash, ),
647 $dbh->rollback if $oldAutoCommit;
648 return "error queuing welcome email: $error";
651 if ( $options{'depend_jobnum'} ) {
652 warn "$me depend_jobnum found; adding to welcome email dependancies"
654 if ( ref($options{'depend_jobnum'}) ) {
655 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
656 "to welcome email dependancies"
658 push @jobnums, @{ $options{'depend_jobnum'} };
660 warn "$me adding job $options{'depend_jobnum'} ".
661 "to welcome email dependancies"
663 push @jobnums, $options{'depend_jobnum'};
667 foreach my $jobnum ( @jobnums ) {
668 my $error = $wqueue->depend_insert($jobnum);
670 $dbh->rollback if $oldAutoCommit;
671 return "error queuing welcome email job dependancy: $error";
681 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
687 Deletes this account from the database. If there is an error, returns the
688 error, otherwise returns false.
690 The corresponding FS::cust_svc record will be deleted as well.
692 (TODOC: new exports!)
699 return "can't delete system account" if $self->_check_system;
701 return "Can't delete an account which is a (svc_forward) source!"
702 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
704 return "Can't delete an account which is a (svc_forward) destination!"
705 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
707 return "Can't delete an account with (svc_www) web service!"
708 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
710 # what about records in session ? (they should refer to history table)
712 local $SIG{HUP} = 'IGNORE';
713 local $SIG{INT} = 'IGNORE';
714 local $SIG{QUIT} = 'IGNORE';
715 local $SIG{TERM} = 'IGNORE';
716 local $SIG{TSTP} = 'IGNORE';
717 local $SIG{PIPE} = 'IGNORE';
719 my $oldAutoCommit = $FS::UID::AutoCommit;
720 local $FS::UID::AutoCommit = 0;
723 foreach my $cust_main_invoice (
724 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
726 unless ( defined($cust_main_invoice) ) {
727 warn "WARNING: something's wrong with qsearch";
730 my %hash = $cust_main_invoice->hash;
731 $hash{'dest'} = $self->email;
732 my $new = new FS::cust_main_invoice \%hash;
733 my $error = $new->replace($cust_main_invoice);
735 $dbh->rollback if $oldAutoCommit;
740 foreach my $svc_domain (
741 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
743 my %hash = new FS::svc_domain->hash;
744 $hash{'catchall'} = '';
745 my $new = new FS::svc_domain \%hash;
746 my $error = $new->replace($svc_domain);
748 $dbh->rollback if $oldAutoCommit;
753 my $error = $self->SUPER::delete;
755 $dbh->rollback if $oldAutoCommit;
759 foreach my $radius_usergroup (
760 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
762 my $error = $radius_usergroup->delete;
764 $dbh->rollback if $oldAutoCommit;
769 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
773 =item replace OLD_RECORD
775 Replaces OLD_RECORD with this one in the database. If there is an error,
776 returns the error, otherwise returns false.
778 The additional field I<usergroup> can optionally be defined; if so it should
779 contain an arrayref of group names. See L<FS::radius_usergroup>.
787 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
791 warn "$me replacing $old with $new\n" if $DEBUG;
795 return "can't modify system account" if $old->_check_system;
798 #no warnings 'numeric'; #alas, a 5.006-ism
801 foreach my $xid (qw( uid gid )) {
803 return "Can't change $xid!"
804 if ! $conf->exists("svc_acct-edit_$xid")
805 && $old->$xid() != $new->$xid()
806 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
811 #change homdir when we change username
812 $new->setfield('dir', '') if $old->username ne $new->username;
814 local $SIG{HUP} = 'IGNORE';
815 local $SIG{INT} = 'IGNORE';
816 local $SIG{QUIT} = 'IGNORE';
817 local $SIG{TERM} = 'IGNORE';
818 local $SIG{TSTP} = 'IGNORE';
819 local $SIG{PIPE} = 'IGNORE';
821 my $oldAutoCommit = $FS::UID::AutoCommit;
822 local $FS::UID::AutoCommit = 0;
825 # redundant, but so $new->usergroup gets set
826 $error = $new->check;
827 return $error if $error;
829 $old->usergroup( [ $old->radius_groups ] );
831 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
832 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
834 if ( $new->usergroup ) {
835 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
836 my @newgroups = @{$new->usergroup};
837 foreach my $oldgroup ( @{$old->usergroup} ) {
838 if ( grep { $oldgroup eq $_ } @newgroups ) {
839 @newgroups = grep { $oldgroup ne $_ } @newgroups;
842 my $radius_usergroup = qsearchs('radius_usergroup', {
843 svcnum => $old->svcnum,
844 groupname => $oldgroup,
846 my $error = $radius_usergroup->delete;
848 $dbh->rollback if $oldAutoCommit;
849 return "error deleting radius_usergroup $oldgroup: $error";
853 foreach my $newgroup ( @newgroups ) {
854 my $radius_usergroup = new FS::radius_usergroup ( {
855 svcnum => $new->svcnum,
856 groupname => $newgroup,
858 my $error = $radius_usergroup->insert;
860 $dbh->rollback if $oldAutoCommit;
861 return "error adding radius_usergroup $newgroup: $error";
867 $error = $new->SUPER::replace($old, @_);
869 $dbh->rollback if $oldAutoCommit;
870 return $error if $error;
873 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
874 $error = $new->queue_fuzzyfiles_update;
876 $dbh->rollback if $oldAutoCommit;
877 return "updating fuzzy search cache: $error";
881 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
885 =item queue_fuzzyfiles_update
887 Used by insert & replace to update the fuzzy search cache
891 sub queue_fuzzyfiles_update {
894 local $SIG{HUP} = 'IGNORE';
895 local $SIG{INT} = 'IGNORE';
896 local $SIG{QUIT} = 'IGNORE';
897 local $SIG{TERM} = 'IGNORE';
898 local $SIG{TSTP} = 'IGNORE';
899 local $SIG{PIPE} = 'IGNORE';
901 my $oldAutoCommit = $FS::UID::AutoCommit;
902 local $FS::UID::AutoCommit = 0;
905 my $queue = new FS::queue {
906 'svcnum' => $self->svcnum,
907 'job' => 'FS::svc_acct::append_fuzzyfiles'
909 my $error = $queue->insert($self->username);
911 $dbh->rollback if $oldAutoCommit;
912 return "queueing job (transaction rolled back): $error";
915 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
923 Suspends this account by calling export-specific suspend hooks. If there is
924 an error, returns the error, otherwise returns false.
926 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
932 return "can't suspend system account" if $self->_check_system;
933 $self->SUPER::suspend(@_);
938 Unsuspends this account by by calling export-specific suspend hooks. If there
939 is an error, returns the error, otherwise returns false.
941 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
947 my %hash = $self->hash;
948 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
949 $hash{_password} = $1;
950 my $new = new FS::svc_acct ( \%hash );
951 my $error = $new->replace($self);
952 return $error if $error;
955 $self->SUPER::unsuspend(@_);
960 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
962 If the B<auto_unset_catchall> configuration option is set, this method will
963 automatically remove any references to the canceled service in the catchall
964 field of svc_domain. This allows packages that contain both a svc_domain and
965 its catchall svc_acct to be canceled in one step.
970 # Only one thing to do at this level
972 foreach my $svc_domain (
973 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
974 if($conf->exists('auto_unset_catchall')) {
975 my %hash = $svc_domain->hash;
976 $hash{catchall} = '';
977 my $new = new FS::svc_domain ( \%hash );
978 my $error = $new->replace($svc_domain);
979 return $error if $error;
981 return "cannot unprovision svc_acct #".$self->svcnum.
982 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
986 $self->SUPER::cancel(@_);
992 Checks all fields to make sure this is a valid service. If there is an error,
993 returns the error, otherwise returns false. Called by the insert and replace
996 Sets any fixed values; see L<FS::part_svc>.
1003 my($recref) = $self->hashref;
1005 my $x = $self->setfixed( $self->_fieldhandlers );
1006 return $x unless ref($x);
1009 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1011 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1014 my $error = $self->ut_numbern('svcnum')
1015 #|| $self->ut_number('domsvc')
1016 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1017 || $self->ut_textn('sec_phrase')
1018 || $self->ut_snumbern('seconds')
1019 || $self->ut_snumbern('upbytes')
1020 || $self->ut_snumbern('downbytes')
1021 || $self->ut_snumbern('totalbytes')
1022 || $self->ut_enum( '_password_encoding',
1023 [ '', qw( plain crypt ldap ) ]
1026 return $error if $error;
1029 local $username_letter = $username_letter;
1030 if ($self->svcnum) {
1031 my $cust_svc = $self->cust_svc
1032 or return "no cust_svc record found for svcnum ". $self->svcnum;
1033 my $cust_pkg = $cust_svc->cust_pkg;
1035 if ($self->pkgnum) {
1036 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1040 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1043 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1044 if ( $username_uppercase ) {
1045 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1046 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1047 $recref->{username} = $1;
1049 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1050 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1051 $recref->{username} = $1;
1054 if ( $username_letterfirst ) {
1055 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1056 } elsif ( $username_letter ) {
1057 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1059 if ( $username_noperiod ) {
1060 $recref->{username} =~ /\./ and return gettext('illegal_username');
1062 if ( $username_nounderscore ) {
1063 $recref->{username} =~ /_/ and return gettext('illegal_username');
1065 if ( $username_nodash ) {
1066 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1068 unless ( $username_ampersand ) {
1069 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1071 unless ( $username_percent ) {
1072 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1074 unless ( $username_colon ) {
1075 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1078 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1079 $recref->{popnum} = $1;
1080 return "Unknown popnum" unless
1081 ! $recref->{popnum} ||
1082 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1084 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1086 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1087 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1089 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1090 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1091 #not all systems use gid=uid
1092 #you can set a fixed gid in part_svc
1094 return "Only root can have uid 0"
1095 if $recref->{uid} == 0
1096 && $recref->{username} !~ /^(root|toor|smtp)$/;
1098 unless ( $recref->{username} eq 'sync' ) {
1099 if ( grep $_ eq $recref->{shell}, @shells ) {
1100 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1102 return "Illegal shell \`". $self->shell. "\'; ".
1103 "shells configuration value contains: @shells";
1106 $recref->{shell} = '/bin/sync';
1110 $recref->{gid} ne '' ?
1111 return "Can't have gid without uid" : ( $recref->{gid}='' );
1112 #$recref->{dir} ne '' ?
1113 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1114 $recref->{shell} ne '' ?
1115 return "Can't have shell without uid" : ( $recref->{shell}='' );
1118 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1120 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1121 or return "Illegal directory: ". $recref->{dir};
1122 $recref->{dir} = $1;
1123 return "Illegal directory"
1124 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1125 return "Illegal directory"
1126 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1127 unless ( $recref->{dir} ) {
1128 $recref->{dir} = $dir_prefix . '/';
1129 if ( $dirhash > 0 ) {
1130 for my $h ( 1 .. $dirhash ) {
1131 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1133 } elsif ( $dirhash < 0 ) {
1134 for my $h ( reverse $dirhash .. -1 ) {
1135 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1138 $recref->{dir} .= $recref->{username};
1144 # $error = $self->ut_textn('finger');
1145 # return $error if $error;
1146 if ( $self->getfield('finger') eq '' ) {
1147 my $cust_pkg = $self->svcnum
1148 ? $self->cust_svc->cust_pkg
1149 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1151 my $cust_main = $cust_pkg->cust_main;
1152 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1155 $self->getfield('finger') =~
1156 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1157 or return "Illegal finger: ". $self->getfield('finger');
1158 $self->setfield('finger', $1);
1160 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1161 $recref->{quota} = $1;
1163 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1164 if ( $recref->{slipip} eq '' ) {
1165 $recref->{slipip} = '';
1166 } elsif ( $recref->{slipip} eq '0e0' ) {
1167 $recref->{slipip} = '0e0';
1169 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1170 or return "Illegal slipip: ". $self->slipip;
1171 $recref->{slipip} = $1;
1176 #arbitrary RADIUS stuff; allow ut_textn for now
1177 foreach ( grep /^radius_/, fields('svc_acct') ) {
1178 $self->ut_textn($_);
1181 if ( $recref->{_password_encoding} eq 'ldap' ) {
1183 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1184 $recref->{_password} = uc($1).$2;
1186 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1189 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1191 if ( $recref->{_password} =~
1192 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1193 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1196 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1199 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1202 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1204 #generate a password if it is blank
1205 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1206 unless length( $recref->{_password} );
1208 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1209 $recref->{_password} = $1;
1211 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1212 FS::Msgcat::_gettext('illegal_password_characters').
1213 ": ". $recref->{_password};
1216 if ( $password_noampersand ) {
1217 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1219 if ( $password_noexclamation ) {
1220 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1225 #carp "warning: _password_encoding unspecified\n";
1227 #generate a password if it is blank
1228 unless ( length( $recref->{_password} ) ) {
1230 $recref->{_password} =
1231 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1232 $recref->{_password_encoding} = 'plain';
1236 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1237 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1238 $recref->{_password} = $1.$3;
1239 $recref->{_password_encoding} = 'plain';
1240 } elsif ( $recref->{_password} =~
1241 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1243 $recref->{_password} = $1.$3;
1244 $recref->{_password_encoding} = 'crypt';
1245 } elsif ( $recref->{_password} eq '*' ) {
1246 $recref->{_password} = '*';
1247 $recref->{_password_encoding} = 'crypt';
1248 } elsif ( $recref->{_password} eq '!' ) {
1249 $recref->{_password_encoding} = 'crypt';
1250 $recref->{_password} = '!';
1251 } elsif ( $recref->{_password} eq '!!' ) {
1252 $recref->{_password} = '!!';
1253 $recref->{_password_encoding} = 'crypt';
1255 #return "Illegal password";
1256 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1257 FS::Msgcat::_gettext('illegal_password_characters').
1258 ": ". $recref->{_password};
1265 $self->SUPER::check;
1271 Internal function to check the username against the list of system usernames
1272 from the I<system_usernames> configuration value. Returns true if the username
1273 is listed on the system username list.
1279 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1280 $conf->config('system_usernames')
1284 =item _check_duplicate
1286 Internal method to check for duplicates usernames, username@domain pairs and
1289 If the I<global_unique-username> configuration value is set to B<username> or
1290 B<username@domain>, enforces global username or username@domain uniqueness.
1292 In all cases, check for duplicate uids and usernames or username@domain pairs
1293 per export and with identical I<svcpart> values.
1297 sub _check_duplicate {
1300 my $global_unique = $conf->config('global_unique-username') || 'none';
1301 return '' if $global_unique eq 'disabled';
1305 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1306 unless ( $part_svc ) {
1307 return 'unknown svcpart '. $self->svcpart;
1310 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1311 qsearch( 'svc_acct', { 'username' => $self->username } );
1312 return gettext('username_in_use')
1313 if $global_unique eq 'username' && @dup_user;
1315 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1316 qsearch( 'svc_acct', { 'username' => $self->username,
1317 'domsvc' => $self->domsvc } );
1318 return gettext('username_in_use')
1319 if $global_unique eq 'username@domain' && @dup_userdomain;
1322 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1323 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1324 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1325 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1330 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1331 my $exports = FS::part_export::export_info('svc_acct');
1332 my %conflict_user_svcpart;
1333 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1335 foreach my $part_export ( $part_svc->part_export ) {
1337 #this will catch to the same exact export
1338 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1340 #this will catch to exports w/same exporthost+type ???
1341 #my @other_part_export = qsearch('part_export', {
1342 # 'machine' => $part_export->machine,
1343 # 'exporttype' => $part_export->exporttype,
1345 #foreach my $other_part_export ( @other_part_export ) {
1346 # push @svcparts, map { $_->svcpart }
1347 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1350 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1351 #silly kludge to avoid uninitialized value errors
1352 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1353 ? $exports->{$part_export->exporttype}{'nodomain'}
1355 if ( $nodomain =~ /^Y/i ) {
1356 $conflict_user_svcpart{$_} = $part_export->exportnum
1359 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1364 foreach my $dup_user ( @dup_user ) {
1365 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1366 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1367 return "duplicate username ". $self->username.
1368 ": conflicts with svcnum ". $dup_user->svcnum.
1369 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1373 foreach my $dup_userdomain ( @dup_userdomain ) {
1374 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1375 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1376 return "duplicate username\@domain ". $self->email.
1377 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1378 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1382 foreach my $dup_uid ( @dup_uid ) {
1383 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1384 if ( exists($conflict_user_svcpart{$dup_svcpart})
1385 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1386 return "duplicate uid ". $self->uid.
1387 ": conflicts with svcnum ". $dup_uid->svcnum.
1389 ( $conflict_user_svcpart{$dup_svcpart}
1390 || $conflict_userdomain_svcpart{$dup_svcpart} );
1402 Depriciated, use radius_reply instead.
1407 carp "FS::svc_acct::radius depriciated, use radius_reply";
1408 $_[0]->radius_reply;
1413 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1414 reply attributes of this record.
1416 Note that this is now the preferred method for reading RADIUS attributes -
1417 accessing the columns directly is discouraged, as the column names are
1418 expected to change in the future.
1425 return %{ $self->{'radius_reply'} }
1426 if exists $self->{'radius_reply'};
1431 my($column, $attrib) = ($1, $2);
1432 #$attrib =~ s/_/\-/g;
1433 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1434 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1436 if ( $self->slipip && $self->slipip ne '0e0' ) {
1437 $reply{$radius_ip} = $self->slipip;
1440 if ( $self->seconds !~ /^$/ ) {
1441 $reply{'Session-Timeout'} = $self->seconds;
1444 if ( $conf->exists('radius-chillispot-max') ) {
1445 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1447 #hmm. just because sqlradius.pm says so?
1454 foreach my $what (qw( input output total )) {
1455 my $is = $whatis{$what}.'bytes';
1456 if ( $self->$is() =~ /\d/ ) {
1457 my $big = new Math::BigInt $self->$is();
1458 my $att = "Chillispot-Max-\u$what";
1459 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1460 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1471 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1472 check attributes of this record.
1474 Note that this is now the preferred method for reading RADIUS attributes -
1475 accessing the columns directly is discouraged, as the column names are
1476 expected to change in the future.
1483 return %{ $self->{'radius_check'} }
1484 if exists $self->{'radius_check'};
1489 my($column, $attrib) = ($1, $2);
1490 #$attrib =~ s/_/\-/g;
1491 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1492 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1495 my($pw_attrib, $password) = $self->radius_password;
1496 $check{$pw_attrib} = $password;
1498 my $cust_svc = $self->cust_svc;
1500 my $cust_pkg = $cust_svc->cust_pkg;
1501 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1502 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1505 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1506 "; can't set Expiration\n"
1514 =item radius_password
1516 Returns a key/value pair containing the RADIUS attribute name and value
1521 sub radius_password {
1524 my($pw_attrib, $password);
1525 if ( $self->_password_encoding eq 'ldap' ) {
1527 $pw_attrib = 'Password-With-Header';
1528 $password = $self->_password;
1530 } elsif ( $self->_password_encoding eq 'crypt' ) {
1532 $pw_attrib = 'Crypt-Password';
1533 $password = $self->_password;
1535 } elsif ( $self->_password_encoding eq 'plain' ) {
1537 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1538 $password = $self->_password;
1542 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1543 $password = $self->_password;
1547 ($pw_attrib, $password);
1553 This method instructs the object to "snapshot" or freeze RADIUS check and
1554 reply attributes to the current values.
1558 #bah, my english is too broken this morning
1559 #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
1560 #the FS::cust_pkg's replace method to trigger the correct export updates when
1561 #package dates change)
1566 $self->{$_} = { $self->$_() }
1567 foreach qw( radius_reply radius_check );
1571 =item forget_snapshot
1573 This methos instructs the object to forget any previously snapshotted
1574 RADIUS check and reply attributes.
1578 sub forget_snapshot {
1582 foreach qw( radius_reply radius_check );
1586 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1588 Returns the domain associated with this account.
1590 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1597 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1598 my $svc_domain = $self->svc_domain(@_)
1599 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1600 $svc_domain->domain;
1605 Returns the FS::svc_domain record for this account's domain (see
1610 # FS::h_svc_acct has a history-aware svc_domain override
1615 ? $self->{'_domsvc'}
1616 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1621 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1625 #inherited from svc_Common
1627 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1629 Returns an email address associated with the account.
1631 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1638 $self->username. '@'. $self->domain(@_);
1643 Returns an array of FS::acct_snarf records associated with the account.
1644 If the acct_snarf table does not exist or there are no associated records,
1645 an empty list is returned
1651 return () unless dbdef->table('acct_snarf');
1652 eval "use FS::acct_snarf;";
1654 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1657 =item decrement_upbytes OCTETS
1659 Decrements the I<upbytes> field of this record by the given amount. If there
1660 is an error, returns the error, otherwise returns false.
1664 sub decrement_upbytes {
1665 shift->_op_usage('-', 'upbytes', @_);
1668 =item increment_upbytes OCTETS
1670 Increments 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 increment_upbytes {
1676 shift->_op_usage('+', 'upbytes', @_);
1679 =item decrement_downbytes OCTETS
1681 Decrements the I<downbytes> field of this record by the given amount. If there
1682 is an error, returns the error, otherwise returns false.
1686 sub decrement_downbytes {
1687 shift->_op_usage('-', 'downbytes', @_);
1690 =item increment_downbytes OCTETS
1692 Increments 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 increment_downbytes {
1698 shift->_op_usage('+', 'downbytes', @_);
1701 =item decrement_totalbytes OCTETS
1703 Decrements the I<totalbytes> field of this record by the given amount. If there
1704 is an error, returns the error, otherwise returns false.
1708 sub decrement_totalbytes {
1709 shift->_op_usage('-', 'totalbytes', @_);
1712 =item increment_totalbytes OCTETS
1714 Increments 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 increment_totalbytes {
1720 shift->_op_usage('+', 'totalbytes', @_);
1723 =item decrement_seconds SECONDS
1725 Decrements the I<seconds> field of this record by the given amount. If there
1726 is an error, returns the error, otherwise returns false.
1730 sub decrement_seconds {
1731 shift->_op_usage('-', 'seconds', @_);
1734 =item increment_seconds SECONDS
1736 Increments 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 increment_seconds {
1742 shift->_op_usage('+', 'seconds', @_);
1750 my %op2condition = (
1751 '-' => sub { my($self, $column, $amount) = @_;
1752 $self->$column - $amount <= 0;
1754 '+' => sub { my($self, $column, $amount) = @_;
1755 ($self->$column || 0) + $amount > 0;
1758 my %op2warncondition = (
1759 '-' => sub { my($self, $column, $amount) = @_;
1760 my $threshold = $column . '_threshold';
1761 $self->$column - $amount <= $self->$threshold + 0;
1763 '+' => sub { my($self, $column, $amount) = @_;
1764 ($self->$column || 0) + $amount > 0;
1769 my( $self, $op, $column, $amount ) = @_;
1771 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1772 ' ('. $self->email. "): $op $amount\n"
1775 return '' unless $amount;
1777 local $SIG{HUP} = 'IGNORE';
1778 local $SIG{INT} = 'IGNORE';
1779 local $SIG{QUIT} = 'IGNORE';
1780 local $SIG{TERM} = 'IGNORE';
1781 local $SIG{TSTP} = 'IGNORE';
1782 local $SIG{PIPE} = 'IGNORE';
1784 my $oldAutoCommit = $FS::UID::AutoCommit;
1785 local $FS::UID::AutoCommit = 0;
1788 my $sql = "UPDATE svc_acct SET $column = ".
1789 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1790 " $op ? WHERE svcnum = ?";
1794 my $sth = $dbh->prepare( $sql )
1795 or die "Error preparing $sql: ". $dbh->errstr;
1796 my $rv = $sth->execute($amount, $self->svcnum);
1797 die "Error executing $sql: ". $sth->errstr
1798 unless defined($rv);
1799 die "Can't update $column for svcnum". $self->svcnum
1802 #$self->snapshot; #not necessary, we retain the old values
1803 #create an object with the updated usage values
1804 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1806 my $error = $new->replace($self);
1808 $dbh->rollback if $oldAutoCommit;
1809 return "Error replacing: $error";
1812 #overlimit_action eq 'cancel' handling
1813 my $cust_pkg = $self->cust_svc->cust_pkg;
1815 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1816 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1820 my $error = $cust_pkg->cancel; #XXX should have a reason
1822 $dbh->rollback if $oldAutoCommit;
1823 return "Error cancelling: $error";
1826 #nothing else is relevant if we're cancelling, so commit & return success
1827 warn "$me update successful; committing\n"
1829 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1834 my $action = $op2action{$op};
1836 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1837 ( $action eq 'suspend' && !$self->overlimit
1838 || $action eq 'unsuspend' && $self->overlimit )
1840 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1841 if ($part_export->option('overlimit_groups')) {
1843 my $other = new FS::svc_acct $self->hashref;
1844 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1845 ($self, $part_export->option('overlimit_groups'));
1846 $other->usergroup( $groups );
1847 if ($action eq 'suspend'){
1848 $new = $other; $old = $self;
1850 $new = $self; $old = $other;
1852 my $error = $part_export->export_replace($new, $old);
1853 $error ||= $self->overlimit($action);
1855 $dbh->rollback if $oldAutoCommit;
1856 return "Error replacing radius groups in export, ${op}: $error";
1862 if ( $conf->exists("svc_acct-usage_$action")
1863 && &{$op2condition{$op}}($self, $column, $amount) ) {
1864 #my $error = $self->$action();
1865 my $error = $self->cust_svc->cust_pkg->$action();
1866 # $error ||= $self->overlimit($action);
1868 $dbh->rollback if $oldAutoCommit;
1869 return "Error ${action}ing: $error";
1873 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1874 my $wqueue = new FS::queue {
1875 'svcnum' => $self->svcnum,
1876 'job' => 'FS::svc_acct::reached_threshold',
1881 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1885 my $error = $wqueue->insert(
1886 'svcnum' => $self->svcnum,
1888 'column' => $column,
1892 $dbh->rollback if $oldAutoCommit;
1893 return "Error queuing threshold activity: $error";
1897 warn "$me update successful; committing\n"
1899 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1905 my( $self, $valueref, %options ) = @_;
1907 warn "$me set_usage called for svcnum ". $self->svcnum.
1908 ' ('. $self->email. "): ".
1909 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1912 local $SIG{HUP} = 'IGNORE';
1913 local $SIG{INT} = 'IGNORE';
1914 local $SIG{QUIT} = 'IGNORE';
1915 local $SIG{TERM} = 'IGNORE';
1916 local $SIG{TSTP} = 'IGNORE';
1917 local $SIG{PIPE} = 'IGNORE';
1919 local $FS::svc_Common::noexport_hack = 1;
1920 my $oldAutoCommit = $FS::UID::AutoCommit;
1921 local $FS::UID::AutoCommit = 0;
1926 if ( $options{null} ) {
1927 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1928 qw( seconds upbytes downbytes totalbytes )
1931 foreach my $field (keys %$valueref){
1932 $reset = 1 if $valueref->{$field};
1933 $self->setfield($field, $valueref->{$field});
1934 $self->setfield( $field.'_threshold',
1935 int($self->getfield($field)
1936 * ( $conf->exists('svc_acct-usage_threshold')
1937 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1942 $handyhash{$field} = $self->getfield($field);
1943 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1945 #my $error = $self->replace; #NO! we avoid the call to ->check for
1946 #die $error if $error; #services not explicity changed via the UI
1948 my $sql = "UPDATE svc_acct SET " .
1949 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
1950 " WHERE svcnum = ". $self->svcnum;
1955 if (scalar(keys %handyhash)) {
1956 my $sth = $dbh->prepare( $sql )
1957 or die "Error preparing $sql: ". $dbh->errstr;
1958 my $rv = $sth->execute();
1959 die "Error executing $sql: ". $sth->errstr
1960 unless defined($rv);
1961 die "Can't update usage for svcnum ". $self->svcnum
1965 #$self->snapshot; #not necessary, we retain the old values
1966 #create an object with the updated usage values
1967 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1969 my $error = $new->replace($self);
1971 $dbh->rollback if $oldAutoCommit;
1972 return "Error replacing: $error";
1978 if ($self->overlimit) {
1979 $error = $self->overlimit('unsuspend');
1980 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1981 if ($part_export->option('overlimit_groups')) {
1982 my $old = new FS::svc_acct $self->hashref;
1983 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1984 ($self, $part_export->option('overlimit_groups'));
1985 $old->usergroup( $groups );
1986 $error ||= $part_export->export_replace($self, $old);
1991 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1992 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1995 $dbh->rollback if $oldAutoCommit;
1996 return "Error unsuspending: $error";
2000 warn "$me update successful; committing\n"
2002 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2008 =item recharge HASHREF
2010 Increments usage columns by the amount specified in HASHREF as
2011 column=>amount pairs.
2016 my ($self, $vhash) = @_;
2019 warn "[$me] recharge called on $self: ". Dumper($self).
2020 "\nwith vhash: ". Dumper($vhash);
2023 my $oldAutoCommit = $FS::UID::AutoCommit;
2024 local $FS::UID::AutoCommit = 0;
2028 foreach my $column (keys %$vhash){
2029 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2033 $dbh->rollback if $oldAutoCommit;
2035 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2040 =item is_rechargeable
2042 Returns true if this svc_account can be "recharged" and false otherwise.
2046 sub is_rechargable {
2048 $self->seconds ne ''
2049 || $self->upbytes ne ''
2050 || $self->downbytes ne ''
2051 || $self->totalbytes ne '';
2054 =item seconds_since TIMESTAMP
2056 Returns the number of seconds this account has been online since TIMESTAMP,
2057 according to the session monitor (see L<FS::Session>).
2059 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2060 L<Time::Local> and L<Date::Parse> for conversion functions.
2064 #note: POD here, implementation in FS::cust_svc
2067 $self->cust_svc->seconds_since(@_);
2070 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2072 Returns the numbers of seconds this account has been online between
2073 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2074 external SQL radacct table, specified via sqlradius export. Sessions which
2075 started in the specified range but are still open are counted from session
2076 start to the end of the range (unless they are over 1 day old, in which case
2077 they are presumed missing their stop record and not counted). Also, sessions
2078 which end in the range but started earlier are counted from the start of the
2079 range to session end. Finally, sessions which start before the range but end
2080 after are counted for the entire range.
2082 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2083 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2088 #note: POD here, implementation in FS::cust_svc
2089 sub seconds_since_sqlradacct {
2091 $self->cust_svc->seconds_since_sqlradacct(@_);
2094 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2096 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2097 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2098 TIMESTAMP_END (exclusive).
2100 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2101 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2106 #note: POD here, implementation in FS::cust_svc
2107 sub attribute_since_sqlradacct {
2109 $self->cust_svc->attribute_since_sqlradacct(@_);
2112 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2114 Returns an array of hash references of this customers login history for the
2115 given time range. (document this better)
2119 sub get_session_history {
2121 $self->cust_svc->get_session_history(@_);
2124 =item last_login_text
2126 Returns text describing the time of last login.
2130 sub last_login_text {
2132 $self->last_login ? ctime($self->last_login) : 'unknown';
2135 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2140 my($self, $start, $end, %opt ) = @_;
2142 my $did = $self->username; #yup
2144 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2146 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2148 #SELECT $for_update * FROM cdr
2149 # WHERE calldate >= $start #need a conversion
2150 # AND calldate < $end #ditto
2151 # AND ( charged_party = "$did"
2152 # OR charged_party = "$prefix$did" #if length($prefix);
2153 # OR ( ( charged_party IS NULL OR charged_party = '' )
2155 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2158 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2161 if ( length($prefix) ) {
2163 " AND ( charged_party = '$did'
2164 OR charged_party = '$prefix$did'
2165 OR ( ( charged_party IS NULL OR charged_party = '' )
2167 ( src = '$did' OR src = '$prefix$did' )
2173 " AND ( charged_party = '$did'
2174 OR ( ( charged_party IS NULL OR charged_party = '' )
2184 'select' => "$for_update *",
2187 #( freesidestatus IS NULL OR freesidestatus = '' )
2188 'freesidestatus' => '',
2190 'extra_sql' => $charged_or_src,
2198 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2204 if ( $self->usergroup ) {
2205 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2206 unless ref($self->usergroup) eq 'ARRAY';
2207 #when provisioning records, export callback runs in svc_Common.pm before
2208 #radius_usergroup records can be inserted...
2209 @{$self->usergroup};
2211 map { $_->groupname }
2212 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2216 =item clone_suspended
2218 Constructor used by FS::part_export::_export_suspend fallback. Document
2223 sub clone_suspended {
2225 my %hash = $self->hash;
2226 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2227 new FS::svc_acct \%hash;
2230 =item clone_kludge_unsuspend
2232 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2237 sub clone_kludge_unsuspend {
2239 my %hash = $self->hash;
2240 $hash{_password} = '';
2241 new FS::svc_acct \%hash;
2244 =item check_password
2246 Checks the supplied password against the (possibly encrypted) password in the
2247 database. Returns true for a successful authentication, false for no match.
2249 Currently supported encryptions are: classic DES crypt() and MD5
2253 sub check_password {
2254 my($self, $check_password) = @_;
2256 #remove old-style SUSPENDED kludge, they should be allowed to login to
2257 #self-service and pay up
2258 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2260 if ( $self->_password_encoding eq 'ldap' ) {
2262 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2263 return $auth->match($check_password);
2265 } elsif ( $self->_password_encoding eq 'crypt' ) {
2267 my $auth = from_crypt Authen::Passphrase $self->_password;
2268 return $auth->match($check_password);
2270 } elsif ( $self->_password_encoding eq 'plain' ) {
2272 return $check_password eq $password;
2276 #XXX this could be replaced with Authen::Passphrase stuff
2278 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2280 } elsif ( length($password) < 13 ) { #plaintext
2281 $check_password eq $password;
2282 } elsif ( length($password) == 13 ) { #traditional DES crypt
2283 crypt($check_password, $password) eq $password;
2284 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2285 unix_md5_crypt($check_password, $password) eq $password;
2286 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2287 warn "Can't check password: Blowfish encryption not yet supported, ".
2288 "svcnum ". $self->svcnum. "\n";
2291 warn "Can't check password: Unrecognized encryption for svcnum ".
2292 $self->svcnum. "\n";
2300 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2302 Returns an encrypted password, either by passing through an encrypted password
2303 in the database or by encrypting a plaintext password from the database.
2305 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2306 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2307 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2308 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2309 encryption type is only used if the password is not already encrypted in the
2314 sub crypt_password {
2317 if ( $self->_password_encoding eq 'ldap' ) {
2319 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2322 #XXX this could be replaced with Authen::Passphrase stuff
2324 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2325 if ( $encryption eq 'crypt' ) {
2328 $saltset[int(rand(64))].$saltset[int(rand(64))]
2330 } elsif ( $encryption eq 'md5' ) {
2331 unix_md5_crypt( $self->_password );
2332 } elsif ( $encryption eq 'blowfish' ) {
2333 croak "unknown encryption method $encryption";
2335 croak "unknown encryption method $encryption";
2338 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2342 } elsif ( $self->_password_encoding eq 'crypt' ) {
2344 return $self->_password;
2346 } elsif ( $self->_password_encoding eq 'plain' ) {
2348 #XXX this could be replaced with Authen::Passphrase stuff
2350 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2351 if ( $encryption eq 'crypt' ) {
2354 $saltset[int(rand(64))].$saltset[int(rand(64))]
2356 } elsif ( $encryption eq 'md5' ) {
2357 unix_md5_crypt( $self->_password );
2358 } elsif ( $encryption eq 'blowfish' ) {
2359 croak "unknown encryption method $encryption";
2361 croak "unknown encryption method $encryption";
2366 if ( length($self->_password) == 13
2367 || $self->_password =~ /^\$(1|2a?)\$/
2368 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2374 #XXX this could be replaced with Authen::Passphrase stuff
2376 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2377 if ( $encryption eq 'crypt' ) {
2380 $saltset[int(rand(64))].$saltset[int(rand(64))]
2382 } elsif ( $encryption eq 'md5' ) {
2383 unix_md5_crypt( $self->_password );
2384 } elsif ( $encryption eq 'blowfish' ) {
2385 croak "unknown encryption method $encryption";
2387 croak "unknown encryption method $encryption";
2396 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2398 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2399 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2400 "{MD5}5426824942db4253f87a1009fd5d2d4".
2402 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2403 to work the same as the B</crypt_password> method.
2409 #eventually should check a "password-encoding" field
2411 if ( $self->_password_encoding eq 'ldap' ) {
2413 return $self->_password;
2415 } elsif ( $self->_password_encoding eq 'crypt' ) {
2417 if ( length($self->_password) == 13 ) { #crypt
2418 return '{CRYPT}'. $self->_password;
2419 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2421 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2422 # die "Blowfish encryption not supported in this context, svcnum ".
2423 # $self->svcnum. "\n";
2425 warn "encryption method not (yet?) supported in LDAP context";
2426 return '{CRYPT}*'; #unsupported, should not auth
2429 } elsif ( $self->_password_encoding eq 'plain' ) {
2431 return '{PLAIN}'. $self->_password;
2433 #return '{CLEARTEXT}'. $self->_password; #?
2437 if ( length($self->_password) == 13 ) { #crypt
2438 return '{CRYPT}'. $self->_password;
2439 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2441 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2442 warn "Blowfish encryption not supported in this context, svcnum ".
2443 $self->svcnum. "\n";
2446 #are these two necessary anymore?
2447 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2448 return '{SSHA}'. $1;
2449 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2450 return '{NS-MTA-MD5}'. $1;
2453 return '{PLAIN}'. $self->_password;
2455 #return '{CLEARTEXT}'. $self->_password; #?
2457 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2458 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2459 #if ( $encryption eq 'crypt' ) {
2460 # return '{CRYPT}'. crypt(
2462 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2464 #} elsif ( $encryption eq 'md5' ) {
2465 # unix_md5_crypt( $self->_password );
2466 #} elsif ( $encryption eq 'blowfish' ) {
2467 # croak "unknown encryption method $encryption";
2469 # croak "unknown encryption method $encryption";
2477 =item domain_slash_username
2479 Returns $domain/$username/
2483 sub domain_slash_username {
2485 $self->domain. '/'. $self->username. '/';
2488 =item virtual_maildir
2490 Returns $domain/maildirs/$username/
2494 sub virtual_maildir {
2496 $self->domain. '/maildirs/'. $self->username. '/';
2507 This is the FS::svc_acct job-queue-able version. It still uses
2508 FS::Misc::send_email under-the-hood.
2515 eval "use FS::Misc qw(send_email)";
2518 $opt{mimetype} ||= 'text/plain';
2519 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2521 my $error = send_email(
2522 'from' => $opt{from},
2524 'subject' => $opt{subject},
2525 'content-type' => $opt{mimetype},
2526 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2528 die $error if $error;
2531 =item check_and_rebuild_fuzzyfiles
2535 sub check_and_rebuild_fuzzyfiles {
2536 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2537 -e "$dir/svc_acct.username"
2538 or &rebuild_fuzzyfiles;
2541 =item rebuild_fuzzyfiles
2545 sub rebuild_fuzzyfiles {
2547 use Fcntl qw(:flock);
2549 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2553 open(USERNAMELOCK,">>$dir/svc_acct.username")
2554 or die "can't open $dir/svc_acct.username: $!";
2555 flock(USERNAMELOCK,LOCK_EX)
2556 or die "can't lock $dir/svc_acct.username: $!";
2558 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2560 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2561 or die "can't open $dir/svc_acct.username.tmp: $!";
2562 print USERNAMECACHE join("\n", @all_username), "\n";
2563 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2565 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2575 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2576 open(USERNAMECACHE,"<$dir/svc_acct.username")
2577 or die "can't open $dir/svc_acct.username: $!";
2578 my @array = map { chomp; $_; } <USERNAMECACHE>;
2579 close USERNAMECACHE;
2583 =item append_fuzzyfiles USERNAME
2587 sub append_fuzzyfiles {
2588 my $username = shift;
2590 &check_and_rebuild_fuzzyfiles;
2592 use Fcntl qw(:flock);
2594 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2596 open(USERNAME,">>$dir/svc_acct.username")
2597 or die "can't open $dir/svc_acct.username: $!";
2598 flock(USERNAME,LOCK_EX)
2599 or die "can't lock $dir/svc_acct.username: $!";
2601 print USERNAME "$username\n";
2603 flock(USERNAME,LOCK_UN)
2604 or die "can't unlock $dir/svc_acct.username: $!";
2612 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2616 sub radius_usergroup_selector {
2617 my $sel_groups = shift;
2618 my %sel_groups = map { $_=>1 } @$sel_groups;
2620 my $selectname = shift || 'radius_usergroup';
2623 my $sth = $dbh->prepare(
2624 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2625 ) or die $dbh->errstr;
2626 $sth->execute() or die $sth->errstr;
2627 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2631 function ${selectname}_doadd(object) {
2632 var myvalue = object.${selectname}_add.value;
2633 var optionName = new Option(myvalue,myvalue,false,true);
2634 var length = object.$selectname.length;
2635 object.$selectname.options[length] = optionName;
2636 object.${selectname}_add.value = "";
2639 <SELECT MULTIPLE NAME="$selectname">
2642 foreach my $group ( @all_groups ) {
2643 $html .= qq(<OPTION VALUE="$group");
2644 if ( $sel_groups{$group} ) {
2645 $html .= ' SELECTED';
2646 $sel_groups{$group} = 0;
2648 $html .= ">$group</OPTION>\n";
2650 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2651 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2653 $html .= '</SELECT>';
2655 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2656 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2661 =item reached_threshold
2663 Performs some activities when svc_acct thresholds (such as number of seconds
2664 remaining) are reached.
2668 sub reached_threshold {
2671 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2672 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2674 if ( $opt{'op'} eq '+' ){
2675 $svc_acct->setfield( $opt{'column'}.'_threshold',
2676 int($svc_acct->getfield($opt{'column'})
2677 * ( $conf->exists('svc_acct-usage_threshold')
2678 ? $conf->config('svc_acct-usage_threshold')/100
2683 my $error = $svc_acct->replace;
2684 die $error if $error;
2685 }elsif ( $opt{'op'} eq '-' ){
2687 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2688 return '' if ($threshold eq '' );
2690 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2691 my $error = $svc_acct->replace;
2692 die $error if $error; # email next time, i guess
2694 if ( $warning_template ) {
2695 eval "use FS::Misc qw(send_email)";
2698 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2699 my $cust_main = $cust_pkg->cust_main;
2701 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2702 $cust_main->invoicing_list,
2703 ($opt{'to'} ? $opt{'to'} : ())
2706 my $mimetype = $warning_mimetype;
2707 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2709 my $body = $warning_template->fill_in( HASH => {
2710 'custnum' => $cust_main->custnum,
2711 'username' => $svc_acct->username,
2712 'password' => $svc_acct->_password,
2713 'first' => $cust_main->first,
2714 'last' => $cust_main->getfield('last'),
2715 'pkg' => $cust_pkg->part_pkg->pkg,
2716 'column' => $opt{'column'},
2717 'amount' => $opt{'column'} =~/bytes/
2718 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2719 : $svc_acct->getfield($opt{'column'}),
2720 'threshold' => $opt{'column'} =~/bytes/
2721 ? FS::UI::bytecount::display_bytecount($threshold)
2726 my $error = send_email(
2727 'from' => $warning_from,
2729 'subject' => $warning_subject,
2730 'content-type' => $mimetype,
2731 'body' => [ map "$_\n", split("\n", $body) ],
2733 die $error if $error;
2736 die "unknown op: " . $opt{'op'};
2744 The $recref stuff in sub check should be cleaned up.
2746 The suspend, unsuspend and cancel methods update the database, but not the
2747 current object. This is probably a bug as it's unexpected and
2750 radius_usergroup_selector? putting web ui components in here? they should
2751 probably live somewhere else...
2753 insertion of RADIUS group stuff in insert could be done with child_objects now
2754 (would probably clean up export of them too)
2756 _op_usage and set_usage bypass the history... maybe they shouldn't
2760 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2761 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2762 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2763 L<freeside-queued>), L<FS::svc_acct_pop>,
2764 schema.html from the base documentation.
2768 =item domain_select_hash %OPTIONS
2770 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2771 may at present purchase.
2773 Currently available options are: I<pkgnum> I<svcpart>
2777 sub domain_select_hash {
2778 my ($self, %options) = @_;
2784 $part_svc = $self->part_svc;
2785 $cust_pkg = $self->cust_svc->cust_pkg
2789 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2790 if $options{'svcpart'};
2792 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2793 if $options{'pkgnum'};
2795 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2796 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2797 %domains = map { $_->svcnum => $_->domain }
2798 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2799 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2800 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2801 %domains = map { $_->svcnum => $_->domain }
2802 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2803 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2804 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2806 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2809 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2810 my $svc_domain = qsearchs('svc_domain',
2811 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2812 if ( $svc_domain ) {
2813 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2815 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2816 $part_svc->part_svc_column('domsvc')->columnvalue;