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 $big = new Math::BigInt '0' if $big->is_neg();
1459 my $att = "Chillispot-Max-\u$what";
1460 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1461 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1472 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1473 check attributes of this record.
1475 Note that this is now the preferred method for reading RADIUS attributes -
1476 accessing the columns directly is discouraged, as the column names are
1477 expected to change in the future.
1484 return %{ $self->{'radius_check'} }
1485 if exists $self->{'radius_check'};
1490 my($column, $attrib) = ($1, $2);
1491 #$attrib =~ s/_/\-/g;
1492 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1493 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1496 my($pw_attrib, $password) = $self->radius_password;
1497 $check{$pw_attrib} = $password;
1499 my $cust_svc = $self->cust_svc;
1501 my $cust_pkg = $cust_svc->cust_pkg;
1502 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1503 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1506 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1507 "; can't set Expiration\n"
1515 =item radius_password
1517 Returns a key/value pair containing the RADIUS attribute name and value
1522 sub radius_password {
1525 my($pw_attrib, $password);
1526 if ( $self->_password_encoding eq 'ldap' ) {
1528 $pw_attrib = 'Password-With-Header';
1529 $password = $self->_password;
1531 } elsif ( $self->_password_encoding eq 'crypt' ) {
1533 $pw_attrib = 'Crypt-Password';
1534 $password = $self->_password;
1536 } elsif ( $self->_password_encoding eq 'plain' ) {
1538 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1539 $password = $self->_password;
1543 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1544 $password = $self->_password;
1548 ($pw_attrib, $password);
1554 This method instructs the object to "snapshot" or freeze RADIUS check and
1555 reply attributes to the current values.
1559 #bah, my english is too broken this morning
1560 #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
1561 #the FS::cust_pkg's replace method to trigger the correct export updates when
1562 #package dates change)
1567 $self->{$_} = { $self->$_() }
1568 foreach qw( radius_reply radius_check );
1572 =item forget_snapshot
1574 This methos instructs the object to forget any previously snapshotted
1575 RADIUS check and reply attributes.
1579 sub forget_snapshot {
1583 foreach qw( radius_reply radius_check );
1587 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1589 Returns the domain associated with this account.
1591 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1598 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1599 my $svc_domain = $self->svc_domain(@_)
1600 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1601 $svc_domain->domain;
1606 Returns the FS::svc_domain record for this account's domain (see
1611 # FS::h_svc_acct has a history-aware svc_domain override
1616 ? $self->{'_domsvc'}
1617 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1622 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1626 #inherited from svc_Common
1628 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1630 Returns an email address associated with the account.
1632 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1639 $self->username. '@'. $self->domain(@_);
1644 Returns an array of FS::acct_snarf records associated with the account.
1645 If the acct_snarf table does not exist or there are no associated records,
1646 an empty list is returned
1652 return () unless dbdef->table('acct_snarf');
1653 eval "use FS::acct_snarf;";
1655 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1658 =item decrement_upbytes OCTETS
1660 Decrements the I<upbytes> field of this record by the given amount. If there
1661 is an error, returns the error, otherwise returns false.
1665 sub decrement_upbytes {
1666 shift->_op_usage('-', 'upbytes', @_);
1669 =item increment_upbytes OCTETS
1671 Increments the I<upbytes> field of this record by the given amount. If there
1672 is an error, returns the error, otherwise returns false.
1676 sub increment_upbytes {
1677 shift->_op_usage('+', 'upbytes', @_);
1680 =item decrement_downbytes OCTETS
1682 Decrements the I<downbytes> field of this record by the given amount. If there
1683 is an error, returns the error, otherwise returns false.
1687 sub decrement_downbytes {
1688 shift->_op_usage('-', 'downbytes', @_);
1691 =item increment_downbytes OCTETS
1693 Increments the I<downbytes> field of this record by the given amount. If there
1694 is an error, returns the error, otherwise returns false.
1698 sub increment_downbytes {
1699 shift->_op_usage('+', 'downbytes', @_);
1702 =item decrement_totalbytes OCTETS
1704 Decrements the I<totalbytes> field of this record by the given amount. If there
1705 is an error, returns the error, otherwise returns false.
1709 sub decrement_totalbytes {
1710 shift->_op_usage('-', 'totalbytes', @_);
1713 =item increment_totalbytes OCTETS
1715 Increments the I<totalbytes> field of this record by the given amount. If there
1716 is an error, returns the error, otherwise returns false.
1720 sub increment_totalbytes {
1721 shift->_op_usage('+', 'totalbytes', @_);
1724 =item decrement_seconds SECONDS
1726 Decrements the I<seconds> field of this record by the given amount. If there
1727 is an error, returns the error, otherwise returns false.
1731 sub decrement_seconds {
1732 shift->_op_usage('-', 'seconds', @_);
1735 =item increment_seconds SECONDS
1737 Increments the I<seconds> field of this record by the given amount. If there
1738 is an error, returns the error, otherwise returns false.
1742 sub increment_seconds {
1743 shift->_op_usage('+', 'seconds', @_);
1751 my %op2condition = (
1752 '-' => sub { my($self, $column, $amount) = @_;
1753 $self->$column - $amount <= 0;
1755 '+' => sub { my($self, $column, $amount) = @_;
1756 ($self->$column || 0) + $amount > 0;
1759 my %op2warncondition = (
1760 '-' => sub { my($self, $column, $amount) = @_;
1761 my $threshold = $column . '_threshold';
1762 $self->$column - $amount <= $self->$threshold + 0;
1764 '+' => sub { my($self, $column, $amount) = @_;
1765 ($self->$column || 0) + $amount > 0;
1770 my( $self, $op, $column, $amount ) = @_;
1772 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1773 ' ('. $self->email. "): $op $amount\n"
1776 return '' unless $amount;
1778 local $SIG{HUP} = 'IGNORE';
1779 local $SIG{INT} = 'IGNORE';
1780 local $SIG{QUIT} = 'IGNORE';
1781 local $SIG{TERM} = 'IGNORE';
1782 local $SIG{TSTP} = 'IGNORE';
1783 local $SIG{PIPE} = 'IGNORE';
1785 my $oldAutoCommit = $FS::UID::AutoCommit;
1786 local $FS::UID::AutoCommit = 0;
1789 my $sql = "UPDATE svc_acct SET $column = ".
1790 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1791 " $op ? WHERE svcnum = ?";
1795 my $sth = $dbh->prepare( $sql )
1796 or die "Error preparing $sql: ". $dbh->errstr;
1797 my $rv = $sth->execute($amount, $self->svcnum);
1798 die "Error executing $sql: ". $sth->errstr
1799 unless defined($rv);
1800 die "Can't update $column for svcnum". $self->svcnum
1803 #$self->snapshot; #not necessary, we retain the old values
1804 #create an object with the updated usage values
1805 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1807 my $error = $new->replace($self);
1809 $dbh->rollback if $oldAutoCommit;
1810 return "Error replacing: $error";
1813 #overlimit_action eq 'cancel' handling
1814 my $cust_pkg = $self->cust_svc->cust_pkg;
1816 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1817 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1821 my $error = $cust_pkg->cancel; #XXX should have a reason
1823 $dbh->rollback if $oldAutoCommit;
1824 return "Error cancelling: $error";
1827 #nothing else is relevant if we're cancelling, so commit & return success
1828 warn "$me update successful; committing\n"
1830 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1835 my $action = $op2action{$op};
1837 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1838 ( $action eq 'suspend' && !$self->overlimit
1839 || $action eq 'unsuspend' && $self->overlimit )
1841 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1842 if ($part_export->option('overlimit_groups')) {
1844 my $other = new FS::svc_acct $self->hashref;
1845 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1846 ($self, $part_export->option('overlimit_groups'));
1847 $other->usergroup( $groups );
1848 if ($action eq 'suspend'){
1849 $new = $other; $old = $self;
1851 $new = $self; $old = $other;
1853 my $error = $part_export->export_replace($new, $old);
1854 $error ||= $self->overlimit($action);
1856 $dbh->rollback if $oldAutoCommit;
1857 return "Error replacing radius groups in export, ${op}: $error";
1863 if ( $conf->exists("svc_acct-usage_$action")
1864 && &{$op2condition{$op}}($self, $column, $amount) ) {
1865 #my $error = $self->$action();
1866 my $error = $self->cust_svc->cust_pkg->$action();
1867 # $error ||= $self->overlimit($action);
1869 $dbh->rollback if $oldAutoCommit;
1870 return "Error ${action}ing: $error";
1874 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1875 my $wqueue = new FS::queue {
1876 'svcnum' => $self->svcnum,
1877 'job' => 'FS::svc_acct::reached_threshold',
1882 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1886 my $error = $wqueue->insert(
1887 'svcnum' => $self->svcnum,
1889 'column' => $column,
1893 $dbh->rollback if $oldAutoCommit;
1894 return "Error queuing threshold activity: $error";
1898 warn "$me update successful; committing\n"
1900 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1906 my( $self, $valueref, %options ) = @_;
1908 warn "$me set_usage called for svcnum ". $self->svcnum.
1909 ' ('. $self->email. "): ".
1910 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1913 local $SIG{HUP} = 'IGNORE';
1914 local $SIG{INT} = 'IGNORE';
1915 local $SIG{QUIT} = 'IGNORE';
1916 local $SIG{TERM} = 'IGNORE';
1917 local $SIG{TSTP} = 'IGNORE';
1918 local $SIG{PIPE} = 'IGNORE';
1920 local $FS::svc_Common::noexport_hack = 1;
1921 my $oldAutoCommit = $FS::UID::AutoCommit;
1922 local $FS::UID::AutoCommit = 0;
1927 if ( $options{null} ) {
1928 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1929 qw( seconds upbytes downbytes totalbytes )
1932 foreach my $field (keys %$valueref){
1933 $reset = 1 if $valueref->{$field};
1934 $self->setfield($field, $valueref->{$field});
1935 $self->setfield( $field.'_threshold',
1936 int($self->getfield($field)
1937 * ( $conf->exists('svc_acct-usage_threshold')
1938 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1943 $handyhash{$field} = $self->getfield($field);
1944 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1946 #my $error = $self->replace; #NO! we avoid the call to ->check for
1947 #die $error if $error; #services not explicity changed via the UI
1949 my $sql = "UPDATE svc_acct SET " .
1950 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
1951 " WHERE svcnum = ". $self->svcnum;
1956 if (scalar(keys %handyhash)) {
1957 my $sth = $dbh->prepare( $sql )
1958 or die "Error preparing $sql: ". $dbh->errstr;
1959 my $rv = $sth->execute();
1960 die "Error executing $sql: ". $sth->errstr
1961 unless defined($rv);
1962 die "Can't update usage for svcnum ". $self->svcnum
1966 #$self->snapshot; #not necessary, we retain the old values
1967 #create an object with the updated usage values
1968 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1970 my $error = $new->replace($self);
1972 $dbh->rollback if $oldAutoCommit;
1973 return "Error replacing: $error";
1979 if ($self->overlimit) {
1980 $error = $self->overlimit('unsuspend');
1981 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1982 if ($part_export->option('overlimit_groups')) {
1983 my $old = new FS::svc_acct $self->hashref;
1984 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1985 ($self, $part_export->option('overlimit_groups'));
1986 $old->usergroup( $groups );
1987 $error ||= $part_export->export_replace($self, $old);
1992 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1993 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1996 $dbh->rollback if $oldAutoCommit;
1997 return "Error unsuspending: $error";
2001 warn "$me update successful; committing\n"
2003 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2009 =item recharge HASHREF
2011 Increments usage columns by the amount specified in HASHREF as
2012 column=>amount pairs.
2017 my ($self, $vhash) = @_;
2020 warn "[$me] recharge called on $self: ". Dumper($self).
2021 "\nwith vhash: ". Dumper($vhash);
2024 my $oldAutoCommit = $FS::UID::AutoCommit;
2025 local $FS::UID::AutoCommit = 0;
2029 foreach my $column (keys %$vhash){
2030 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2034 $dbh->rollback if $oldAutoCommit;
2036 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2041 =item is_rechargeable
2043 Returns true if this svc_account can be "recharged" and false otherwise.
2047 sub is_rechargable {
2049 $self->seconds ne ''
2050 || $self->upbytes ne ''
2051 || $self->downbytes ne ''
2052 || $self->totalbytes ne '';
2055 =item seconds_since TIMESTAMP
2057 Returns the number of seconds this account has been online since TIMESTAMP,
2058 according to the session monitor (see L<FS::Session>).
2060 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2061 L<Time::Local> and L<Date::Parse> for conversion functions.
2065 #note: POD here, implementation in FS::cust_svc
2068 $self->cust_svc->seconds_since(@_);
2071 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2073 Returns the numbers of seconds this account has been online between
2074 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2075 external SQL radacct table, specified via sqlradius export. Sessions which
2076 started in the specified range but are still open are counted from session
2077 start to the end of the range (unless they are over 1 day old, in which case
2078 they are presumed missing their stop record and not counted). Also, sessions
2079 which end in the range but started earlier are counted from the start of the
2080 range to session end. Finally, sessions which start before the range but end
2081 after are counted for the entire range.
2083 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2084 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2089 #note: POD here, implementation in FS::cust_svc
2090 sub seconds_since_sqlradacct {
2092 $self->cust_svc->seconds_since_sqlradacct(@_);
2095 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2097 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2098 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2099 TIMESTAMP_END (exclusive).
2101 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2102 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2107 #note: POD here, implementation in FS::cust_svc
2108 sub attribute_since_sqlradacct {
2110 $self->cust_svc->attribute_since_sqlradacct(@_);
2113 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2115 Returns an array of hash references of this customers login history for the
2116 given time range. (document this better)
2120 sub get_session_history {
2122 $self->cust_svc->get_session_history(@_);
2125 =item last_login_text
2127 Returns text describing the time of last login.
2131 sub last_login_text {
2133 $self->last_login ? ctime($self->last_login) : 'unknown';
2136 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2141 my($self, $start, $end, %opt ) = @_;
2143 my $did = $self->username; #yup
2145 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2147 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2149 #SELECT $for_update * FROM cdr
2150 # WHERE calldate >= $start #need a conversion
2151 # AND calldate < $end #ditto
2152 # AND ( charged_party = "$did"
2153 # OR charged_party = "$prefix$did" #if length($prefix);
2154 # OR ( ( charged_party IS NULL OR charged_party = '' )
2156 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2159 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2162 if ( length($prefix) ) {
2164 " AND ( charged_party = '$did'
2165 OR charged_party = '$prefix$did'
2166 OR ( ( charged_party IS NULL OR charged_party = '' )
2168 ( src = '$did' OR src = '$prefix$did' )
2174 " AND ( charged_party = '$did'
2175 OR ( ( charged_party IS NULL OR charged_party = '' )
2185 'select' => "$for_update *",
2188 #( freesidestatus IS NULL OR freesidestatus = '' )
2189 'freesidestatus' => '',
2191 'extra_sql' => $charged_or_src,
2199 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2205 if ( $self->usergroup ) {
2206 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2207 unless ref($self->usergroup) eq 'ARRAY';
2208 #when provisioning records, export callback runs in svc_Common.pm before
2209 #radius_usergroup records can be inserted...
2210 @{$self->usergroup};
2212 map { $_->groupname }
2213 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2217 =item clone_suspended
2219 Constructor used by FS::part_export::_export_suspend fallback. Document
2224 sub clone_suspended {
2226 my %hash = $self->hash;
2227 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2228 new FS::svc_acct \%hash;
2231 =item clone_kludge_unsuspend
2233 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2238 sub clone_kludge_unsuspend {
2240 my %hash = $self->hash;
2241 $hash{_password} = '';
2242 new FS::svc_acct \%hash;
2245 =item check_password
2247 Checks the supplied password against the (possibly encrypted) password in the
2248 database. Returns true for a successful authentication, false for no match.
2250 Currently supported encryptions are: classic DES crypt() and MD5
2254 sub check_password {
2255 my($self, $check_password) = @_;
2257 #remove old-style SUSPENDED kludge, they should be allowed to login to
2258 #self-service and pay up
2259 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2261 if ( $self->_password_encoding eq 'ldap' ) {
2263 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2264 return $auth->match($check_password);
2266 } elsif ( $self->_password_encoding eq 'crypt' ) {
2268 my $auth = from_crypt Authen::Passphrase $self->_password;
2269 return $auth->match($check_password);
2271 } elsif ( $self->_password_encoding eq 'plain' ) {
2273 return $check_password eq $password;
2277 #XXX this could be replaced with Authen::Passphrase stuff
2279 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2281 } elsif ( length($password) < 13 ) { #plaintext
2282 $check_password eq $password;
2283 } elsif ( length($password) == 13 ) { #traditional DES crypt
2284 crypt($check_password, $password) eq $password;
2285 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2286 unix_md5_crypt($check_password, $password) eq $password;
2287 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2288 warn "Can't check password: Blowfish encryption not yet supported, ".
2289 "svcnum ". $self->svcnum. "\n";
2292 warn "Can't check password: Unrecognized encryption for svcnum ".
2293 $self->svcnum. "\n";
2301 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2303 Returns an encrypted password, either by passing through an encrypted password
2304 in the database or by encrypting a plaintext password from the database.
2306 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2307 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2308 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2309 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2310 encryption type is only used if the password is not already encrypted in the
2315 sub crypt_password {
2318 if ( $self->_password_encoding eq 'ldap' ) {
2320 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2323 #XXX this could be replaced with Authen::Passphrase stuff
2325 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2326 if ( $encryption eq 'crypt' ) {
2329 $saltset[int(rand(64))].$saltset[int(rand(64))]
2331 } elsif ( $encryption eq 'md5' ) {
2332 unix_md5_crypt( $self->_password );
2333 } elsif ( $encryption eq 'blowfish' ) {
2334 croak "unknown encryption method $encryption";
2336 croak "unknown encryption method $encryption";
2339 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2343 } elsif ( $self->_password_encoding eq 'crypt' ) {
2345 return $self->_password;
2347 } elsif ( $self->_password_encoding eq 'plain' ) {
2349 #XXX this could be replaced with Authen::Passphrase stuff
2351 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2352 if ( $encryption eq 'crypt' ) {
2355 $saltset[int(rand(64))].$saltset[int(rand(64))]
2357 } elsif ( $encryption eq 'md5' ) {
2358 unix_md5_crypt( $self->_password );
2359 } elsif ( $encryption eq 'blowfish' ) {
2360 croak "unknown encryption method $encryption";
2362 croak "unknown encryption method $encryption";
2367 if ( length($self->_password) == 13
2368 || $self->_password =~ /^\$(1|2a?)\$/
2369 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2375 #XXX this could be replaced with Authen::Passphrase stuff
2377 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2378 if ( $encryption eq 'crypt' ) {
2381 $saltset[int(rand(64))].$saltset[int(rand(64))]
2383 } elsif ( $encryption eq 'md5' ) {
2384 unix_md5_crypt( $self->_password );
2385 } elsif ( $encryption eq 'blowfish' ) {
2386 croak "unknown encryption method $encryption";
2388 croak "unknown encryption method $encryption";
2397 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2399 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2400 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2401 "{MD5}5426824942db4253f87a1009fd5d2d4".
2403 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2404 to work the same as the B</crypt_password> method.
2410 #eventually should check a "password-encoding" field
2412 if ( $self->_password_encoding eq 'ldap' ) {
2414 return $self->_password;
2416 } elsif ( $self->_password_encoding eq 'crypt' ) {
2418 if ( length($self->_password) == 13 ) { #crypt
2419 return '{CRYPT}'. $self->_password;
2420 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2422 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2423 # die "Blowfish encryption not supported in this context, svcnum ".
2424 # $self->svcnum. "\n";
2426 warn "encryption method not (yet?) supported in LDAP context";
2427 return '{CRYPT}*'; #unsupported, should not auth
2430 } elsif ( $self->_password_encoding eq 'plain' ) {
2432 return '{PLAIN}'. $self->_password;
2434 #return '{CLEARTEXT}'. $self->_password; #?
2438 if ( length($self->_password) == 13 ) { #crypt
2439 return '{CRYPT}'. $self->_password;
2440 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2442 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2443 warn "Blowfish encryption not supported in this context, svcnum ".
2444 $self->svcnum. "\n";
2447 #are these two necessary anymore?
2448 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2449 return '{SSHA}'. $1;
2450 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2451 return '{NS-MTA-MD5}'. $1;
2454 return '{PLAIN}'. $self->_password;
2456 #return '{CLEARTEXT}'. $self->_password; #?
2458 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2459 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2460 #if ( $encryption eq 'crypt' ) {
2461 # return '{CRYPT}'. crypt(
2463 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2465 #} elsif ( $encryption eq 'md5' ) {
2466 # unix_md5_crypt( $self->_password );
2467 #} elsif ( $encryption eq 'blowfish' ) {
2468 # croak "unknown encryption method $encryption";
2470 # croak "unknown encryption method $encryption";
2478 =item domain_slash_username
2480 Returns $domain/$username/
2484 sub domain_slash_username {
2486 $self->domain. '/'. $self->username. '/';
2489 =item virtual_maildir
2491 Returns $domain/maildirs/$username/
2495 sub virtual_maildir {
2497 $self->domain. '/maildirs/'. $self->username. '/';
2508 This is the FS::svc_acct job-queue-able version. It still uses
2509 FS::Misc::send_email under-the-hood.
2516 eval "use FS::Misc qw(send_email)";
2519 $opt{mimetype} ||= 'text/plain';
2520 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2522 my $error = send_email(
2523 'from' => $opt{from},
2525 'subject' => $opt{subject},
2526 'content-type' => $opt{mimetype},
2527 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2529 die $error if $error;
2532 =item check_and_rebuild_fuzzyfiles
2536 sub check_and_rebuild_fuzzyfiles {
2537 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2538 -e "$dir/svc_acct.username"
2539 or &rebuild_fuzzyfiles;
2542 =item rebuild_fuzzyfiles
2546 sub rebuild_fuzzyfiles {
2548 use Fcntl qw(:flock);
2550 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2554 open(USERNAMELOCK,">>$dir/svc_acct.username")
2555 or die "can't open $dir/svc_acct.username: $!";
2556 flock(USERNAMELOCK,LOCK_EX)
2557 or die "can't lock $dir/svc_acct.username: $!";
2559 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2561 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2562 or die "can't open $dir/svc_acct.username.tmp: $!";
2563 print USERNAMECACHE join("\n", @all_username), "\n";
2564 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2566 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2576 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2577 open(USERNAMECACHE,"<$dir/svc_acct.username")
2578 or die "can't open $dir/svc_acct.username: $!";
2579 my @array = map { chomp; $_; } <USERNAMECACHE>;
2580 close USERNAMECACHE;
2584 =item append_fuzzyfiles USERNAME
2588 sub append_fuzzyfiles {
2589 my $username = shift;
2591 &check_and_rebuild_fuzzyfiles;
2593 use Fcntl qw(:flock);
2595 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2597 open(USERNAME,">>$dir/svc_acct.username")
2598 or die "can't open $dir/svc_acct.username: $!";
2599 flock(USERNAME,LOCK_EX)
2600 or die "can't lock $dir/svc_acct.username: $!";
2602 print USERNAME "$username\n";
2604 flock(USERNAME,LOCK_UN)
2605 or die "can't unlock $dir/svc_acct.username: $!";
2613 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2617 sub radius_usergroup_selector {
2618 my $sel_groups = shift;
2619 my %sel_groups = map { $_=>1 } @$sel_groups;
2621 my $selectname = shift || 'radius_usergroup';
2624 my $sth = $dbh->prepare(
2625 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2626 ) or die $dbh->errstr;
2627 $sth->execute() or die $sth->errstr;
2628 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2632 function ${selectname}_doadd(object) {
2633 var myvalue = object.${selectname}_add.value;
2634 var optionName = new Option(myvalue,myvalue,false,true);
2635 var length = object.$selectname.length;
2636 object.$selectname.options[length] = optionName;
2637 object.${selectname}_add.value = "";
2640 <SELECT MULTIPLE NAME="$selectname">
2643 foreach my $group ( @all_groups ) {
2644 $html .= qq(<OPTION VALUE="$group");
2645 if ( $sel_groups{$group} ) {
2646 $html .= ' SELECTED';
2647 $sel_groups{$group} = 0;
2649 $html .= ">$group</OPTION>\n";
2651 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2652 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2654 $html .= '</SELECT>';
2656 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2657 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2662 =item reached_threshold
2664 Performs some activities when svc_acct thresholds (such as number of seconds
2665 remaining) are reached.
2669 sub reached_threshold {
2672 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2673 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2675 if ( $opt{'op'} eq '+' ){
2676 $svc_acct->setfield( $opt{'column'}.'_threshold',
2677 int($svc_acct->getfield($opt{'column'})
2678 * ( $conf->exists('svc_acct-usage_threshold')
2679 ? $conf->config('svc_acct-usage_threshold')/100
2684 my $error = $svc_acct->replace;
2685 die $error if $error;
2686 }elsif ( $opt{'op'} eq '-' ){
2688 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2689 return '' if ($threshold eq '' );
2691 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2692 my $error = $svc_acct->replace;
2693 die $error if $error; # email next time, i guess
2695 if ( $warning_template ) {
2696 eval "use FS::Misc qw(send_email)";
2699 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2700 my $cust_main = $cust_pkg->cust_main;
2702 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2703 $cust_main->invoicing_list,
2704 ($opt{'to'} ? $opt{'to'} : ())
2707 my $mimetype = $warning_mimetype;
2708 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2710 my $body = $warning_template->fill_in( HASH => {
2711 'custnum' => $cust_main->custnum,
2712 'username' => $svc_acct->username,
2713 'password' => $svc_acct->_password,
2714 'first' => $cust_main->first,
2715 'last' => $cust_main->getfield('last'),
2716 'pkg' => $cust_pkg->part_pkg->pkg,
2717 'column' => $opt{'column'},
2718 'amount' => $opt{'column'} =~/bytes/
2719 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2720 : $svc_acct->getfield($opt{'column'}),
2721 'threshold' => $opt{'column'} =~/bytes/
2722 ? FS::UI::bytecount::display_bytecount($threshold)
2727 my $error = send_email(
2728 'from' => $warning_from,
2730 'subject' => $warning_subject,
2731 'content-type' => $mimetype,
2732 'body' => [ map "$_\n", split("\n", $body) ],
2734 die $error if $error;
2737 die "unknown op: " . $opt{'op'};
2745 The $recref stuff in sub check should be cleaned up.
2747 The suspend, unsuspend and cancel methods update the database, but not the
2748 current object. This is probably a bug as it's unexpected and
2751 radius_usergroup_selector? putting web ui components in here? they should
2752 probably live somewhere else...
2754 insertion of RADIUS group stuff in insert could be done with child_objects now
2755 (would probably clean up export of them too)
2757 _op_usage and set_usage bypass the history... maybe they shouldn't
2761 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2762 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2763 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2764 L<freeside-queued>), L<FS::svc_acct_pop>,
2765 schema.html from the base documentation.
2769 =item domain_select_hash %OPTIONS
2771 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2772 may at present purchase.
2774 Currently available options are: I<pkgnum> I<svcpart>
2778 sub domain_select_hash {
2779 my ($self, %options) = @_;
2785 $part_svc = $self->part_svc;
2786 $cust_pkg = $self->cust_svc->cust_pkg
2790 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2791 if $options{'svcpart'};
2793 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2794 if $options{'pkgnum'};
2796 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2797 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2798 %domains = map { $_->svcnum => $_->domain }
2799 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2800 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2801 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2802 %domains = map { $_->svcnum => $_->domain }
2803 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2804 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2805 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2807 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2810 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2811 my $svc_domain = qsearchs('svc_domain',
2812 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2813 if ( $svc_domain ) {
2814 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2816 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2817 $part_svc->part_svc_column('domsvc')->columnvalue;