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 $passwordmin = ( $passwordmin =~ /\d+/ ) ? $passwordmin : 6; #blank->6, keep 0
61 $passwordmax = $conf->config('passwordmax') || 8;
62 $username_letter = $conf->exists('username-letter');
63 $username_letterfirst = $conf->exists('username-letterfirst');
64 $username_noperiod = $conf->exists('username-noperiod');
65 $username_nounderscore = $conf->exists('username-nounderscore');
66 $username_nodash = $conf->exists('username-nodash');
67 $username_uppercase = $conf->exists('username-uppercase');
68 $username_ampersand = $conf->exists('username-ampersand');
69 $username_percent = $conf->exists('username-percent');
70 $username_colon = $conf->exists('username-colon');
71 $password_noampersand = $conf->exists('password-noexclamation');
72 $password_noexclamation = $conf->exists('password-noexclamation');
73 $dirhash = $conf->config('dirhash') || 0;
74 if ( $conf->exists('warning_email') ) {
75 $warning_template = new Text::Template (
77 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
78 ) or warn "can't create warning email template: $Text::Template::ERROR";
79 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
80 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
81 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
82 $warning_cc = $conf->config('warning_email-cc');
84 $warning_template = '';
86 $warning_subject = '';
87 $warning_mimetype = '';
90 $smtpmachine = $conf->config('smtpmachine');
91 $radius_password = $conf->config('radius-password') || 'Password';
92 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
93 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
97 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
98 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
102 my ( $hashref, $cache ) = @_;
103 if ( $hashref->{'svc_acct_svcnum'} ) {
104 $self->{'_domsvc'} = FS::svc_domain->new( {
105 'svcnum' => $hashref->{'domsvc'},
106 'domain' => $hashref->{'svc_acct_domain'},
107 'catchall' => $hashref->{'svc_acct_catchall'},
114 FS::svc_acct - Object methods for svc_acct records
120 $record = new FS::svc_acct \%hash;
121 $record = new FS::svc_acct { 'column' => 'value' };
123 $error = $record->insert;
125 $error = $new_record->replace($old_record);
127 $error = $record->delete;
129 $error = $record->check;
131 $error = $record->suspend;
133 $error = $record->unsuspend;
135 $error = $record->cancel;
137 %hash = $record->radius;
139 %hash = $record->radius_reply;
141 %hash = $record->radius_check;
143 $domain = $record->domain;
145 $svc_domain = $record->svc_domain;
147 $email = $record->email;
149 $seconds_since = $record->seconds_since($timestamp);
153 An FS::svc_acct object represents an account. FS::svc_acct inherits from
154 FS::svc_Common. The following fields are currently supported:
158 =item svcnum - primary key (assigned automatcially for new accounts)
162 =item _password - generated if blank
164 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
166 =item sec_phrase - security phrase
168 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
176 =item dir - set automatically if blank (and uid is not)
180 =item quota - (unimplementd)
182 =item slipip - IP address
192 =item domsvc - svcnum from svc_domain
194 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
196 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
206 Creates a new account. To add the account to the database, see L<"insert">.
213 'longname_plural' => 'Access accounts and mailboxes',
214 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
215 'display_weight' => 10,
216 'cancel_weight' => 50,
218 'dir' => 'Home directory',
221 def_info => 'set to fixed and blank for no UIDs',
224 'slipip' => 'IP address',
225 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
227 label => 'Access number',
229 select_table => 'svc_acct_pop',
230 select_key => 'popnum',
231 select_label => 'city',
237 disable_default => 1,
244 disable_inventory => 1,
247 '_password' => 'Password',
250 def_info => 'when blank, defaults to UID',
255 def_info => 'set to blank for no shell tracking',
257 #select_list => [ $conf->config('shells') ],
258 select_list => [ $conf ? $conf->config('shells') : () ],
259 disable_inventory => 1,
262 'finger' => 'Real name', # (GECOS)',
266 select_table => 'svc_domain',
267 select_key => 'svcnum',
268 select_label => 'domain',
269 disable_inventory => 1,
273 label => 'RADIUS groups',
274 type => 'radius_usergroup_selector',
275 disable_inventory => 1,
278 'seconds' => { label => 'Seconds',
279 label_sort => 'with Time Remaining',
281 disable_inventory => 1,
283 disable_part_svc_column => 1,
285 'upbytes' => { label => 'Upload',
287 disable_inventory => 1,
289 'format' => \&FS::UI::bytecount::display_bytecount,
290 'parse' => \&FS::UI::bytecount::parse_bytecount,
291 disable_part_svc_column => 1,
293 'downbytes' => { label => 'Download',
295 disable_inventory => 1,
297 'format' => \&FS::UI::bytecount::display_bytecount,
298 'parse' => \&FS::UI::bytecount::parse_bytecount,
299 disable_part_svc_column => 1,
301 'totalbytes'=> { label => 'Total up and download',
303 disable_inventory => 1,
305 'format' => \&FS::UI::bytecount::display_bytecount,
306 'parse' => \&FS::UI::bytecount::parse_bytecount,
307 disable_part_svc_column => 1,
309 'seconds_threshold' => { label => 'Seconds threshold',
311 disable_inventory => 1,
313 disable_part_svc_column => 1,
315 'upbytes_threshold' => { label => 'Upload threshold',
317 disable_inventory => 1,
319 'format' => \&FS::UI::bytecount::display_bytecount,
320 'parse' => \&FS::UI::bytecount::parse_bytecount,
321 disable_part_svc_column => 1,
323 'downbytes_threshold' => { label => 'Download threshold',
325 disable_inventory => 1,
327 'format' => \&FS::UI::bytecount::display_bytecount,
328 'parse' => \&FS::UI::bytecount::parse_bytecount,
329 disable_part_svc_column => 1,
331 'totalbytes_threshold'=> { label => 'Total up and download threshold',
333 disable_inventory => 1,
335 'format' => \&FS::UI::bytecount::display_bytecount,
336 'parse' => \&FS::UI::bytecount::parse_bytecount,
337 disable_part_svc_column => 1,
340 label => 'Last login',
344 label => 'Last logout',
351 sub table { 'svc_acct'; }
353 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
357 #false laziness with edit/svc_acct.cgi
359 my( $self, $groups ) = @_;
360 if ( ref($groups) eq 'ARRAY' ) {
362 } elsif ( length($groups) ) {
363 [ split(/\s*,\s*/, $groups) ];
372 shift->_lastlog('in', @_);
376 shift->_lastlog('out', @_);
380 my( $self, $op, $time ) = @_;
382 if ( defined($time) ) {
383 warn "$me last_log$op called on svcnum ". $self->svcnum.
384 ' ('. $self->email. "): $time\n"
389 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
393 my $sth = $dbh->prepare( $sql )
394 or die "Error preparing $sql: ". $dbh->errstr;
395 my $rv = $sth->execute($time, $self->svcnum);
396 die "Error executing $sql: ". $sth->errstr
398 die "Can't update last_log$op for svcnum". $self->svcnum
401 $self->{'Hash'}->{"last_log$op"} = $time;
403 $self->getfield("last_log$op");
407 =item search_sql STRING
409 Class method which returns an SQL fragment to search for the given string.
414 my( $class, $string ) = @_;
415 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
416 my( $username, $domain ) = ( $1, $2 );
417 my $q_username = dbh->quote($username);
418 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
420 "svc_acct.username = $q_username AND ( ".
421 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
426 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
428 $class->search_sql_field('slipip', $string ).
430 $class->search_sql_field('username', $string ).
434 $class->search_sql_field('username', $string).
436 ? 'OR '. $class->search_sql_field('svcnum', $string)
443 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
445 Returns the "username@domain" string for this account.
447 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
457 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
459 Returns a longer string label for this acccount ("Real Name <username@domain>"
460 if available, or "username@domain").
462 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
469 my $label = $self->label(@_);
470 my $finger = $self->finger;
471 return $label unless $finger =~ /\S/;
472 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
473 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
477 =item insert [ , OPTION => VALUE ... ]
479 Adds this account to the database. If there is an error, returns the error,
480 otherwise returns false.
482 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
483 defined. An FS::cust_svc record will be created and inserted.
485 The additional field I<usergroup> can optionally be defined; if so it should
486 contain an arrayref of group names. See L<FS::radius_usergroup>.
488 The additional field I<child_objects> can optionally be defined; if so it
489 should contain an arrayref of FS::tablename objects. They will have their
490 svcnum fields set and will be inserted after this record, but before any
491 exports are run. Each element of the array can also optionally be a
492 two-element array reference containing the child object and the name of an
493 alternate field to be filled in with the newly-inserted svcnum, for example
494 C<[ $svc_forward, 'srcsvc' ]>
496 Currently available options are: I<depend_jobnum>
498 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
499 jobnums), all provisioning jobs will have a dependancy on the supplied
500 jobnum(s) (they will not run until the specific job(s) complete(s)).
502 (TODOC: L<FS::queue> and L<freeside-queued>)
504 (TODOC: new exports!)
513 warn "[$me] insert called on $self: ". Dumper($self).
514 "\nwith options: ". Dumper(%options);
517 local $SIG{HUP} = 'IGNORE';
518 local $SIG{INT} = 'IGNORE';
519 local $SIG{QUIT} = 'IGNORE';
520 local $SIG{TERM} = 'IGNORE';
521 local $SIG{TSTP} = 'IGNORE';
522 local $SIG{PIPE} = 'IGNORE';
524 my $oldAutoCommit = $FS::UID::AutoCommit;
525 local $FS::UID::AutoCommit = 0;
528 my $error = $self->check;
529 return $error if $error;
531 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
532 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
533 unless ( $cust_svc ) {
534 $dbh->rollback if $oldAutoCommit;
535 return "no cust_svc record found for svcnum ". $self->svcnum;
537 $self->pkgnum($cust_svc->pkgnum);
538 $self->svcpart($cust_svc->svcpart);
541 # set usage fields and thresholds if unset but set in a package def
542 if ( $self->pkgnum ) {
543 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
544 my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
545 if ( $part_pkg && $part_pkg->can('usage_valuehash') ) {
547 my %values = $part_pkg->usage_valuehash;
548 my $multiplier = $conf->exists('svc_acct-usage_threshold')
549 ? 1 - $conf->config('svc_acct-usage_threshold')/100
550 : 0.20; #doesn't matter
552 foreach ( keys %values ) {
553 next if $self->getfield($_);
554 $self->setfield( $_, $values{$_} );
555 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
556 if $conf->exists('svc_acct-usage_threshold');
563 $error = $self->SUPER::insert(
564 'jobnums' => \@jobnums,
565 'child_objects' => $self->child_objects,
569 $dbh->rollback if $oldAutoCommit;
573 if ( $self->usergroup ) {
574 foreach my $groupname ( @{$self->usergroup} ) {
575 my $radius_usergroup = new FS::radius_usergroup ( {
576 svcnum => $self->svcnum,
577 groupname => $groupname,
579 my $error = $radius_usergroup->insert;
581 $dbh->rollback if $oldAutoCommit;
587 unless ( $skip_fuzzyfiles ) {
588 $error = $self->queue_fuzzyfiles_update;
590 $dbh->rollback if $oldAutoCommit;
591 return "updating fuzzy search cache: $error";
595 my $cust_pkg = $self->cust_svc->cust_pkg;
598 my $cust_main = $cust_pkg->cust_main;
599 my $agentnum = $cust_main->agentnum;
601 if ( $conf->exists('emailinvoiceautoalways')
602 || $conf->exists('emailinvoiceauto')
603 && ! $cust_main->invoicing_list_emailonly
605 my @invoicing_list = $cust_main->invoicing_list;
606 push @invoicing_list, $self->email;
607 $cust_main->invoicing_list(\@invoicing_list);
611 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
612 = ('','','','','','');
614 if ( $conf->exists('welcome_email', $agentnum) ) {
615 $welcome_template = new Text::Template (
617 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
618 ) or warn "can't create welcome email template: $Text::Template::ERROR";
619 $welcome_from = $conf->config('welcome_email-from', $agentnum);
620 # || 'your-isp-is-dum'
621 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
623 $welcome_subject_template = new Text::Template (
625 SOURCE => $welcome_subject,
626 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
627 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
630 if ( $welcome_template && $cust_pkg ) {
631 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
635 'custnum' => $self->custnum,
636 'username' => $self->username,
637 'password' => $self->_password,
638 'first' => $cust_main->first,
639 'last' => $cust_main->getfield('last'),
640 'pkg' => $cust_pkg->part_pkg->pkg,
642 my $wqueue = new FS::queue {
643 'svcnum' => $self->svcnum,
644 'job' => 'FS::svc_acct::send_email'
646 my $error = $wqueue->insert(
648 'from' => $welcome_from,
649 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
650 'mimetype' => $welcome_mimetype,
651 'body' => $welcome_template->fill_in( HASH => \%hash, ),
654 $dbh->rollback if $oldAutoCommit;
655 return "error queuing welcome email: $error";
658 if ( $options{'depend_jobnum'} ) {
659 warn "$me depend_jobnum found; adding to welcome email dependancies"
661 if ( ref($options{'depend_jobnum'}) ) {
662 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
663 "to welcome email dependancies"
665 push @jobnums, @{ $options{'depend_jobnum'} };
667 warn "$me adding job $options{'depend_jobnum'} ".
668 "to welcome email dependancies"
670 push @jobnums, $options{'depend_jobnum'};
674 foreach my $jobnum ( @jobnums ) {
675 my $error = $wqueue->depend_insert($jobnum);
677 $dbh->rollback if $oldAutoCommit;
678 return "error queuing welcome email job dependancy: $error";
688 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
694 Deletes this account from the database. If there is an error, returns the
695 error, otherwise returns false.
697 The corresponding FS::cust_svc record will be deleted as well.
699 (TODOC: new exports!)
706 return "can't delete system account" if $self->_check_system;
708 return "Can't delete an account which is a (svc_forward) source!"
709 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
711 return "Can't delete an account which is a (svc_forward) destination!"
712 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
714 return "Can't delete an account with (svc_www) web service!"
715 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
717 # what about records in session ? (they should refer to history table)
719 local $SIG{HUP} = 'IGNORE';
720 local $SIG{INT} = 'IGNORE';
721 local $SIG{QUIT} = 'IGNORE';
722 local $SIG{TERM} = 'IGNORE';
723 local $SIG{TSTP} = 'IGNORE';
724 local $SIG{PIPE} = 'IGNORE';
726 my $oldAutoCommit = $FS::UID::AutoCommit;
727 local $FS::UID::AutoCommit = 0;
730 foreach my $cust_main_invoice (
731 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
733 unless ( defined($cust_main_invoice) ) {
734 warn "WARNING: something's wrong with qsearch";
737 my %hash = $cust_main_invoice->hash;
738 $hash{'dest'} = $self->email;
739 my $new = new FS::cust_main_invoice \%hash;
740 my $error = $new->replace($cust_main_invoice);
742 $dbh->rollback if $oldAutoCommit;
747 foreach my $svc_domain (
748 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
750 my %hash = new FS::svc_domain->hash;
751 $hash{'catchall'} = '';
752 my $new = new FS::svc_domain \%hash;
753 my $error = $new->replace($svc_domain);
755 $dbh->rollback if $oldAutoCommit;
760 my $error = $self->SUPER::delete;
762 $dbh->rollback if $oldAutoCommit;
766 foreach my $radius_usergroup (
767 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
769 my $error = $radius_usergroup->delete;
771 $dbh->rollback if $oldAutoCommit;
776 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
780 =item replace OLD_RECORD
782 Replaces OLD_RECORD with this one in the database. If there is an error,
783 returns the error, otherwise returns false.
785 The additional field I<usergroup> can optionally be defined; if so it should
786 contain an arrayref of group names. See L<FS::radius_usergroup>.
794 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
798 warn "$me replacing $old with $new\n" if $DEBUG;
802 return "can't modify system account" if $old->_check_system;
805 #no warnings 'numeric'; #alas, a 5.006-ism
808 foreach my $xid (qw( uid gid )) {
810 return "Can't change $xid!"
811 if ! $conf->exists("svc_acct-edit_$xid")
812 && $old->$xid() != $new->$xid()
813 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
818 #change homdir when we change username
819 $new->setfield('dir', '') if $old->username ne $new->username;
821 local $SIG{HUP} = 'IGNORE';
822 local $SIG{INT} = 'IGNORE';
823 local $SIG{QUIT} = 'IGNORE';
824 local $SIG{TERM} = 'IGNORE';
825 local $SIG{TSTP} = 'IGNORE';
826 local $SIG{PIPE} = 'IGNORE';
828 my $oldAutoCommit = $FS::UID::AutoCommit;
829 local $FS::UID::AutoCommit = 0;
832 # redundant, but so $new->usergroup gets set
833 $error = $new->check;
834 return $error if $error;
836 $old->usergroup( [ $old->radius_groups ] );
838 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
839 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
841 if ( $new->usergroup ) {
842 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
843 my @newgroups = @{$new->usergroup};
844 foreach my $oldgroup ( @{$old->usergroup} ) {
845 if ( grep { $oldgroup eq $_ } @newgroups ) {
846 @newgroups = grep { $oldgroup ne $_ } @newgroups;
849 my $radius_usergroup = qsearchs('radius_usergroup', {
850 svcnum => $old->svcnum,
851 groupname => $oldgroup,
853 my $error = $radius_usergroup->delete;
855 $dbh->rollback if $oldAutoCommit;
856 return "error deleting radius_usergroup $oldgroup: $error";
860 foreach my $newgroup ( @newgroups ) {
861 my $radius_usergroup = new FS::radius_usergroup ( {
862 svcnum => $new->svcnum,
863 groupname => $newgroup,
865 my $error = $radius_usergroup->insert;
867 $dbh->rollback if $oldAutoCommit;
868 return "error adding radius_usergroup $newgroup: $error";
874 $error = $new->SUPER::replace($old, @_);
876 $dbh->rollback if $oldAutoCommit;
877 return $error if $error;
880 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
881 $error = $new->queue_fuzzyfiles_update;
883 $dbh->rollback if $oldAutoCommit;
884 return "updating fuzzy search cache: $error";
888 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
892 =item queue_fuzzyfiles_update
894 Used by insert & replace to update the fuzzy search cache
898 sub queue_fuzzyfiles_update {
901 local $SIG{HUP} = 'IGNORE';
902 local $SIG{INT} = 'IGNORE';
903 local $SIG{QUIT} = 'IGNORE';
904 local $SIG{TERM} = 'IGNORE';
905 local $SIG{TSTP} = 'IGNORE';
906 local $SIG{PIPE} = 'IGNORE';
908 my $oldAutoCommit = $FS::UID::AutoCommit;
909 local $FS::UID::AutoCommit = 0;
912 my $queue = new FS::queue {
913 'svcnum' => $self->svcnum,
914 'job' => 'FS::svc_acct::append_fuzzyfiles'
916 my $error = $queue->insert($self->username);
918 $dbh->rollback if $oldAutoCommit;
919 return "queueing job (transaction rolled back): $error";
922 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
930 Suspends this account by calling export-specific suspend hooks. If there is
931 an error, returns the error, otherwise returns false.
933 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
939 return "can't suspend system account" if $self->_check_system;
940 $self->SUPER::suspend(@_);
945 Unsuspends this account by by calling export-specific suspend hooks. If there
946 is an error, returns the error, otherwise returns false.
948 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
954 my %hash = $self->hash;
955 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
956 $hash{_password} = $1;
957 my $new = new FS::svc_acct ( \%hash );
958 my $error = $new->replace($self);
959 return $error if $error;
962 $self->SUPER::unsuspend(@_);
967 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
969 If the B<auto_unset_catchall> configuration option is set, this method will
970 automatically remove any references to the canceled service in the catchall
971 field of svc_domain. This allows packages that contain both a svc_domain and
972 its catchall svc_acct to be canceled in one step.
977 # Only one thing to do at this level
979 foreach my $svc_domain (
980 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
981 if($conf->exists('auto_unset_catchall')) {
982 my %hash = $svc_domain->hash;
983 $hash{catchall} = '';
984 my $new = new FS::svc_domain ( \%hash );
985 my $error = $new->replace($svc_domain);
986 return $error if $error;
988 return "cannot unprovision svc_acct #".$self->svcnum.
989 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
993 $self->SUPER::cancel(@_);
999 Checks all fields to make sure this is a valid service. If there is an error,
1000 returns the error, otherwise returns false. Called by the insert and replace
1003 Sets any fixed values; see L<FS::part_svc>.
1010 my($recref) = $self->hashref;
1012 my $x = $self->setfixed( $self->_fieldhandlers );
1013 return $x unless ref($x);
1016 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1018 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1021 my $error = $self->ut_numbern('svcnum')
1022 #|| $self->ut_number('domsvc')
1023 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1024 || $self->ut_textn('sec_phrase')
1025 || $self->ut_snumbern('seconds')
1026 || $self->ut_snumbern('upbytes')
1027 || $self->ut_snumbern('downbytes')
1028 || $self->ut_snumbern('totalbytes')
1029 || $self->ut_enum( '_password_encoding',
1030 [ '', qw( plain crypt ldap ) ]
1033 return $error if $error;
1036 local $username_letter = $username_letter;
1037 if ($self->svcnum) {
1038 my $cust_svc = $self->cust_svc
1039 or return "no cust_svc record found for svcnum ". $self->svcnum;
1040 my $cust_pkg = $cust_svc->cust_pkg;
1042 if ($self->pkgnum) {
1043 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1047 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1050 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1051 if ( $username_uppercase ) {
1052 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1053 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1054 $recref->{username} = $1;
1056 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1057 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1058 $recref->{username} = $1;
1061 if ( $username_letterfirst ) {
1062 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1063 } elsif ( $username_letter ) {
1064 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1066 if ( $username_noperiod ) {
1067 $recref->{username} =~ /\./ and return gettext('illegal_username');
1069 if ( $username_nounderscore ) {
1070 $recref->{username} =~ /_/ and return gettext('illegal_username');
1072 if ( $username_nodash ) {
1073 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1075 unless ( $username_ampersand ) {
1076 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1078 unless ( $username_percent ) {
1079 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1081 unless ( $username_colon ) {
1082 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1085 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1086 $recref->{popnum} = $1;
1087 return "Unknown popnum" unless
1088 ! $recref->{popnum} ||
1089 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1091 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1093 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1094 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1096 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1097 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1098 #not all systems use gid=uid
1099 #you can set a fixed gid in part_svc
1101 return "Only root can have uid 0"
1102 if $recref->{uid} == 0
1103 && $recref->{username} !~ /^(root|toor|smtp)$/;
1105 unless ( $recref->{username} eq 'sync' ) {
1106 if ( grep $_ eq $recref->{shell}, @shells ) {
1107 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1109 return "Illegal shell \`". $self->shell. "\'; ".
1110 "shells configuration value contains: @shells";
1113 $recref->{shell} = '/bin/sync';
1117 $recref->{gid} ne '' ?
1118 return "Can't have gid without uid" : ( $recref->{gid}='' );
1119 #$recref->{dir} ne '' ?
1120 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1121 $recref->{shell} ne '' ?
1122 return "Can't have shell without uid" : ( $recref->{shell}='' );
1125 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1127 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1128 or return "Illegal directory: ". $recref->{dir};
1129 $recref->{dir} = $1;
1130 return "Illegal directory"
1131 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1132 return "Illegal directory"
1133 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1134 unless ( $recref->{dir} ) {
1135 $recref->{dir} = $dir_prefix . '/';
1136 if ( $dirhash > 0 ) {
1137 for my $h ( 1 .. $dirhash ) {
1138 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1140 } elsif ( $dirhash < 0 ) {
1141 for my $h ( reverse $dirhash .. -1 ) {
1142 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1145 $recref->{dir} .= $recref->{username};
1151 # $error = $self->ut_textn('finger');
1152 # return $error if $error;
1153 if ( $self->getfield('finger') eq '' ) {
1154 my $cust_pkg = $self->svcnum
1155 ? $self->cust_svc->cust_pkg
1156 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1158 my $cust_main = $cust_pkg->cust_main;
1159 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1162 $self->getfield('finger') =~
1163 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1164 or return "Illegal finger: ". $self->getfield('finger');
1165 $self->setfield('finger', $1);
1167 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1168 $recref->{quota} = $1;
1170 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1171 if ( $recref->{slipip} eq '' ) {
1172 $recref->{slipip} = '';
1173 } elsif ( $recref->{slipip} eq '0e0' ) {
1174 $recref->{slipip} = '0e0';
1176 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1177 or return "Illegal slipip: ". $self->slipip;
1178 $recref->{slipip} = $1;
1183 #arbitrary RADIUS stuff; allow ut_textn for now
1184 foreach ( grep /^radius_/, fields('svc_acct') ) {
1185 $self->ut_textn($_);
1188 if ( $recref->{_password_encoding} eq 'ldap' ) {
1190 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1191 $recref->{_password} = uc($1).$2;
1193 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1196 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1198 if ( $recref->{_password} =~
1199 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1200 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1203 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1206 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1209 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1211 #generate a password if it is blank
1212 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1213 unless length( $recref->{_password} );
1215 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1216 $recref->{_password} = $1;
1218 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1219 FS::Msgcat::_gettext('illegal_password_characters').
1220 ": ". $recref->{_password};
1223 if ( $password_noampersand ) {
1224 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1226 if ( $password_noexclamation ) {
1227 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1232 #carp "warning: _password_encoding unspecified\n";
1234 #generate a password if it is blank
1235 unless ( length($recref->{_password}) || ! $passwordmin ) {
1237 $recref->{_password} =
1238 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1239 $recref->{_password_encoding} = 'plain';
1243 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1244 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1245 $recref->{_password} = $1.$3;
1246 $recref->{_password_encoding} = 'plain';
1247 } elsif ( $recref->{_password} =~
1248 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1250 $recref->{_password} = $1.$3;
1251 $recref->{_password_encoding} = 'crypt';
1252 } elsif ( $recref->{_password} eq '*' ) {
1253 $recref->{_password} = '*';
1254 $recref->{_password_encoding} = 'crypt';
1255 } elsif ( $recref->{_password} eq '!' ) {
1256 $recref->{_password_encoding} = 'crypt';
1257 $recref->{_password} = '!';
1258 } elsif ( $recref->{_password} eq '!!' ) {
1259 $recref->{_password} = '!!';
1260 $recref->{_password_encoding} = 'crypt';
1262 #return "Illegal password";
1263 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1264 FS::Msgcat::_gettext('illegal_password_characters').
1265 ": ". $recref->{_password};
1272 $self->SUPER::check;
1278 Internal function to check the username against the list of system usernames
1279 from the I<system_usernames> configuration value. Returns true if the username
1280 is listed on the system username list.
1286 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1287 $conf->config('system_usernames')
1291 =item _check_duplicate
1293 Internal method to check for duplicates usernames, username@domain pairs and
1296 If the I<global_unique-username> configuration value is set to B<username> or
1297 B<username@domain>, enforces global username or username@domain uniqueness.
1299 In all cases, check for duplicate uids and usernames or username@domain pairs
1300 per export and with identical I<svcpart> values.
1304 sub _check_duplicate {
1307 my $global_unique = $conf->config('global_unique-username') || 'none';
1308 return '' if $global_unique eq 'disabled';
1312 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1313 unless ( $part_svc ) {
1314 return 'unknown svcpart '. $self->svcpart;
1317 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1318 qsearch( 'svc_acct', { 'username' => $self->username } );
1319 return gettext('username_in_use')
1320 if $global_unique eq 'username' && @dup_user;
1322 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1323 qsearch( 'svc_acct', { 'username' => $self->username,
1324 'domsvc' => $self->domsvc } );
1325 return gettext('username_in_use')
1326 if $global_unique eq 'username@domain' && @dup_userdomain;
1329 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1330 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1331 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1332 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1337 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1338 my $exports = FS::part_export::export_info('svc_acct');
1339 my %conflict_user_svcpart;
1340 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1342 foreach my $part_export ( $part_svc->part_export ) {
1344 #this will catch to the same exact export
1345 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1347 #this will catch to exports w/same exporthost+type ???
1348 #my @other_part_export = qsearch('part_export', {
1349 # 'machine' => $part_export->machine,
1350 # 'exporttype' => $part_export->exporttype,
1352 #foreach my $other_part_export ( @other_part_export ) {
1353 # push @svcparts, map { $_->svcpart }
1354 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1357 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1358 #silly kludge to avoid uninitialized value errors
1359 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1360 ? $exports->{$part_export->exporttype}{'nodomain'}
1362 if ( $nodomain =~ /^Y/i ) {
1363 $conflict_user_svcpart{$_} = $part_export->exportnum
1366 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1371 foreach my $dup_user ( @dup_user ) {
1372 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1373 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1374 return "duplicate username ". $self->username.
1375 ": conflicts with svcnum ". $dup_user->svcnum.
1376 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1380 foreach my $dup_userdomain ( @dup_userdomain ) {
1381 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1382 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1383 return "duplicate username\@domain ". $self->email.
1384 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1385 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1389 foreach my $dup_uid ( @dup_uid ) {
1390 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1391 if ( exists($conflict_user_svcpart{$dup_svcpart})
1392 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1393 return "duplicate uid ". $self->uid.
1394 ": conflicts with svcnum ". $dup_uid->svcnum.
1396 ( $conflict_user_svcpart{$dup_svcpart}
1397 || $conflict_userdomain_svcpart{$dup_svcpart} );
1409 Depriciated, use radius_reply instead.
1414 carp "FS::svc_acct::radius depriciated, use radius_reply";
1415 $_[0]->radius_reply;
1420 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1421 reply attributes of this record.
1423 Note that this is now the preferred method for reading RADIUS attributes -
1424 accessing the columns directly is discouraged, as the column names are
1425 expected to change in the future.
1432 return %{ $self->{'radius_reply'} }
1433 if exists $self->{'radius_reply'};
1438 my($column, $attrib) = ($1, $2);
1439 #$attrib =~ s/_/\-/g;
1440 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1441 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1443 if ( $self->slipip && $self->slipip ne '0e0' ) {
1444 $reply{$radius_ip} = $self->slipip;
1447 if ( $self->seconds !~ /^$/ ) {
1448 $reply{'Session-Timeout'} = $self->seconds;
1451 if ( $conf->exists('radius-chillispot-max') ) {
1452 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1454 #hmm. just because sqlradius.pm says so?
1461 foreach my $what (qw( input output total )) {
1462 my $is = $whatis{$what}.'bytes';
1463 if ( $self->$is() =~ /\d/ ) {
1464 my $big = new Math::BigInt $self->$is();
1465 $big = new Math::BigInt '0' if $big->is_neg();
1466 my $att = "Chillispot-Max-\u$what";
1467 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1468 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1479 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1480 check attributes of this record.
1482 Note that this is now the preferred method for reading RADIUS attributes -
1483 accessing the columns directly is discouraged, as the column names are
1484 expected to change in the future.
1491 return %{ $self->{'radius_check'} }
1492 if exists $self->{'radius_check'};
1497 my($column, $attrib) = ($1, $2);
1498 #$attrib =~ s/_/\-/g;
1499 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1500 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1503 my($pw_attrib, $password) = $self->radius_password;
1504 $check{$pw_attrib} = $password;
1506 my $cust_svc = $self->cust_svc;
1508 my $cust_pkg = $cust_svc->cust_pkg;
1509 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1510 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1513 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1514 "; can't set Expiration\n"
1522 =item radius_password
1524 Returns a key/value pair containing the RADIUS attribute name and value
1529 sub radius_password {
1532 my($pw_attrib, $password);
1533 if ( $self->_password_encoding eq 'ldap' ) {
1535 $pw_attrib = 'Password-With-Header';
1536 $password = $self->_password;
1538 } elsif ( $self->_password_encoding eq 'crypt' ) {
1540 $pw_attrib = 'Crypt-Password';
1541 $password = $self->_password;
1543 } elsif ( $self->_password_encoding eq 'plain' ) {
1545 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1546 $password = $self->_password;
1550 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1551 $password = $self->_password;
1555 ($pw_attrib, $password);
1561 This method instructs the object to "snapshot" or freeze RADIUS check and
1562 reply attributes to the current values.
1566 #bah, my english is too broken this morning
1567 #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
1568 #the FS::cust_pkg's replace method to trigger the correct export updates when
1569 #package dates change)
1574 $self->{$_} = { $self->$_() }
1575 foreach qw( radius_reply radius_check );
1579 =item forget_snapshot
1581 This methos instructs the object to forget any previously snapshotted
1582 RADIUS check and reply attributes.
1586 sub forget_snapshot {
1590 foreach qw( radius_reply radius_check );
1594 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1596 Returns the domain associated with this account.
1598 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1605 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1606 my $svc_domain = $self->svc_domain(@_)
1607 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1608 $svc_domain->domain;
1613 Returns the FS::svc_domain record for this account's domain (see
1618 # FS::h_svc_acct has a history-aware svc_domain override
1623 ? $self->{'_domsvc'}
1624 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1629 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1633 #inherited from svc_Common
1635 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1637 Returns an email address associated with the account.
1639 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1646 $self->username. '@'. $self->domain(@_);
1651 Returns an array of FS::acct_snarf records associated with the account.
1652 If the acct_snarf table does not exist or there are no associated records,
1653 an empty list is returned
1659 return () unless dbdef->table('acct_snarf');
1660 eval "use FS::acct_snarf;";
1662 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1665 =item decrement_upbytes OCTETS
1667 Decrements the I<upbytes> field of this record by the given amount. If there
1668 is an error, returns the error, otherwise returns false.
1672 sub decrement_upbytes {
1673 shift->_op_usage('-', 'upbytes', @_);
1676 =item increment_upbytes OCTETS
1678 Increments the I<upbytes> field of this record by the given amount. If there
1679 is an error, returns the error, otherwise returns false.
1683 sub increment_upbytes {
1684 shift->_op_usage('+', 'upbytes', @_);
1687 =item decrement_downbytes OCTETS
1689 Decrements the I<downbytes> field of this record by the given amount. If there
1690 is an error, returns the error, otherwise returns false.
1694 sub decrement_downbytes {
1695 shift->_op_usage('-', 'downbytes', @_);
1698 =item increment_downbytes OCTETS
1700 Increments the I<downbytes> field of this record by the given amount. If there
1701 is an error, returns the error, otherwise returns false.
1705 sub increment_downbytes {
1706 shift->_op_usage('+', 'downbytes', @_);
1709 =item decrement_totalbytes OCTETS
1711 Decrements the I<totalbytes> field of this record by the given amount. If there
1712 is an error, returns the error, otherwise returns false.
1716 sub decrement_totalbytes {
1717 shift->_op_usage('-', 'totalbytes', @_);
1720 =item increment_totalbytes OCTETS
1722 Increments the I<totalbytes> field of this record by the given amount. If there
1723 is an error, returns the error, otherwise returns false.
1727 sub increment_totalbytes {
1728 shift->_op_usage('+', 'totalbytes', @_);
1731 =item decrement_seconds SECONDS
1733 Decrements the I<seconds> field of this record by the given amount. If there
1734 is an error, returns the error, otherwise returns false.
1738 sub decrement_seconds {
1739 shift->_op_usage('-', 'seconds', @_);
1742 =item increment_seconds SECONDS
1744 Increments the I<seconds> field of this record by the given amount. If there
1745 is an error, returns the error, otherwise returns false.
1749 sub increment_seconds {
1750 shift->_op_usage('+', 'seconds', @_);
1758 my %op2condition = (
1759 '-' => sub { my($self, $column, $amount) = @_;
1760 $self->$column - $amount <= 0;
1762 '+' => sub { my($self, $column, $amount) = @_;
1763 ($self->$column || 0) + $amount > 0;
1766 my %op2warncondition = (
1767 '-' => sub { my($self, $column, $amount) = @_;
1768 my $threshold = $column . '_threshold';
1769 $self->$column - $amount <= $self->$threshold + 0;
1771 '+' => sub { my($self, $column, $amount) = @_;
1772 ($self->$column || 0) + $amount > 0;
1777 my( $self, $op, $column, $amount ) = @_;
1779 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1780 ' ('. $self->email. "): $op $amount\n"
1783 return '' unless $amount;
1785 local $SIG{HUP} = 'IGNORE';
1786 local $SIG{INT} = 'IGNORE';
1787 local $SIG{QUIT} = 'IGNORE';
1788 local $SIG{TERM} = 'IGNORE';
1789 local $SIG{TSTP} = 'IGNORE';
1790 local $SIG{PIPE} = 'IGNORE';
1792 my $oldAutoCommit = $FS::UID::AutoCommit;
1793 local $FS::UID::AutoCommit = 0;
1796 my $sql = "UPDATE svc_acct SET $column = ".
1797 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1798 " $op ? WHERE svcnum = ?";
1802 my $sth = $dbh->prepare( $sql )
1803 or die "Error preparing $sql: ". $dbh->errstr;
1804 my $rv = $sth->execute($amount, $self->svcnum);
1805 die "Error executing $sql: ". $sth->errstr
1806 unless defined($rv);
1807 die "Can't update $column for svcnum". $self->svcnum
1810 #$self->snapshot; #not necessary, we retain the old values
1811 #create an object with the updated usage values
1812 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1814 my $error = $new->replace($self);
1816 $dbh->rollback if $oldAutoCommit;
1817 return "Error replacing: $error";
1820 #overlimit_action eq 'cancel' handling
1821 my $cust_pkg = $self->cust_svc->cust_pkg;
1823 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1824 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1828 my $error = $cust_pkg->cancel; #XXX should have a reason
1830 $dbh->rollback if $oldAutoCommit;
1831 return "Error cancelling: $error";
1834 #nothing else is relevant if we're cancelling, so commit & return success
1835 warn "$me update successful; committing\n"
1837 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1842 my $action = $op2action{$op};
1844 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1845 ( $action eq 'suspend' && !$self->overlimit
1846 || $action eq 'unsuspend' && $self->overlimit )
1848 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1849 if ($part_export->option('overlimit_groups')) {
1851 my $other = new FS::svc_acct $self->hashref;
1852 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1853 ($self, $part_export->option('overlimit_groups'));
1854 $other->usergroup( $groups );
1855 if ($action eq 'suspend'){
1856 $new = $other; $old = $self;
1858 $new = $self; $old = $other;
1860 my $error = $part_export->export_replace($new, $old);
1861 $error ||= $self->overlimit($action);
1863 $dbh->rollback if $oldAutoCommit;
1864 return "Error replacing radius groups in export, ${op}: $error";
1870 if ( $conf->exists("svc_acct-usage_$action")
1871 && &{$op2condition{$op}}($self, $column, $amount) ) {
1872 #my $error = $self->$action();
1873 my $error = $self->cust_svc->cust_pkg->$action();
1874 # $error ||= $self->overlimit($action);
1876 $dbh->rollback if $oldAutoCommit;
1877 return "Error ${action}ing: $error";
1881 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1882 my $wqueue = new FS::queue {
1883 'svcnum' => $self->svcnum,
1884 'job' => 'FS::svc_acct::reached_threshold',
1889 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1893 my $error = $wqueue->insert(
1894 'svcnum' => $self->svcnum,
1896 'column' => $column,
1900 $dbh->rollback if $oldAutoCommit;
1901 return "Error queuing threshold activity: $error";
1905 warn "$me update successful; committing\n"
1907 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1913 my( $self, $valueref, %options ) = @_;
1915 warn "$me set_usage called for svcnum ". $self->svcnum.
1916 ' ('. $self->email. "): ".
1917 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1920 local $SIG{HUP} = 'IGNORE';
1921 local $SIG{INT} = 'IGNORE';
1922 local $SIG{QUIT} = 'IGNORE';
1923 local $SIG{TERM} = 'IGNORE';
1924 local $SIG{TSTP} = 'IGNORE';
1925 local $SIG{PIPE} = 'IGNORE';
1927 local $FS::svc_Common::noexport_hack = 1;
1928 my $oldAutoCommit = $FS::UID::AutoCommit;
1929 local $FS::UID::AutoCommit = 0;
1934 if ( $options{null} ) {
1935 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1936 qw( seconds upbytes downbytes totalbytes )
1939 foreach my $field (keys %$valueref){
1940 $reset = 1 if $valueref->{$field};
1941 $self->setfield($field, $valueref->{$field});
1942 $self->setfield( $field.'_threshold',
1943 int($self->getfield($field)
1944 * ( $conf->exists('svc_acct-usage_threshold')
1945 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1950 $handyhash{$field} = $self->getfield($field);
1951 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1953 #my $error = $self->replace; #NO! we avoid the call to ->check for
1954 #die $error if $error; #services not explicity changed via the UI
1956 my $sql = "UPDATE svc_acct SET " .
1957 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
1958 " WHERE svcnum = ". $self->svcnum;
1963 if (scalar(keys %handyhash)) {
1964 my $sth = $dbh->prepare( $sql )
1965 or die "Error preparing $sql: ". $dbh->errstr;
1966 my $rv = $sth->execute();
1967 die "Error executing $sql: ". $sth->errstr
1968 unless defined($rv);
1969 die "Can't update usage for svcnum ". $self->svcnum
1973 #$self->snapshot; #not necessary, we retain the old values
1974 #create an object with the updated usage values
1975 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1977 my $error = $new->replace($self);
1979 $dbh->rollback if $oldAutoCommit;
1980 return "Error replacing: $error";
1986 if ($self->overlimit) {
1987 $error = $self->overlimit('unsuspend');
1988 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1989 if ($part_export->option('overlimit_groups')) {
1990 my $old = new FS::svc_acct $self->hashref;
1991 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1992 ($self, $part_export->option('overlimit_groups'));
1993 $old->usergroup( $groups );
1994 $error ||= $part_export->export_replace($self, $old);
1999 if ( $conf->exists("svc_acct-usage_unsuspend")) {
2000 $error ||= $self->cust_svc->cust_pkg->unsuspend;
2003 $dbh->rollback if $oldAutoCommit;
2004 return "Error unsuspending: $error";
2008 warn "$me update successful; committing\n"
2010 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2016 =item recharge HASHREF
2018 Increments usage columns by the amount specified in HASHREF as
2019 column=>amount pairs.
2024 my ($self, $vhash) = @_;
2027 warn "[$me] recharge called on $self: ". Dumper($self).
2028 "\nwith vhash: ". Dumper($vhash);
2031 my $oldAutoCommit = $FS::UID::AutoCommit;
2032 local $FS::UID::AutoCommit = 0;
2036 foreach my $column (keys %$vhash){
2037 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2041 $dbh->rollback if $oldAutoCommit;
2043 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2048 =item is_rechargeable
2050 Returns true if this svc_account can be "recharged" and false otherwise.
2054 sub is_rechargable {
2056 $self->seconds ne ''
2057 || $self->upbytes ne ''
2058 || $self->downbytes ne ''
2059 || $self->totalbytes ne '';
2062 =item seconds_since TIMESTAMP
2064 Returns the number of seconds this account has been online since TIMESTAMP,
2065 according to the session monitor (see L<FS::Session>).
2067 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2068 L<Time::Local> and L<Date::Parse> for conversion functions.
2072 #note: POD here, implementation in FS::cust_svc
2075 $self->cust_svc->seconds_since(@_);
2078 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2080 Returns the numbers of seconds this account has been online between
2081 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2082 external SQL radacct table, specified via sqlradius export. Sessions which
2083 started in the specified range but are still open are counted from session
2084 start to the end of the range (unless they are over 1 day old, in which case
2085 they are presumed missing their stop record and not counted). Also, sessions
2086 which end in the range but started earlier are counted from the start of the
2087 range to session end. Finally, sessions which start before the range but end
2088 after are counted for the entire range.
2090 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2091 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2096 #note: POD here, implementation in FS::cust_svc
2097 sub seconds_since_sqlradacct {
2099 $self->cust_svc->seconds_since_sqlradacct(@_);
2102 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2104 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2105 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2106 TIMESTAMP_END (exclusive).
2108 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2109 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2114 #note: POD here, implementation in FS::cust_svc
2115 sub attribute_since_sqlradacct {
2117 $self->cust_svc->attribute_since_sqlradacct(@_);
2120 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2122 Returns an array of hash references of this customers login history for the
2123 given time range. (document this better)
2127 sub get_session_history {
2129 $self->cust_svc->get_session_history(@_);
2132 =item last_login_text
2134 Returns text describing the time of last login.
2138 sub last_login_text {
2140 $self->last_login ? ctime($self->last_login) : 'unknown';
2143 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2148 my($self, $start, $end, %opt ) = @_;
2150 my $did = $self->username; #yup
2152 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2154 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2156 #SELECT $for_update * FROM cdr
2157 # WHERE calldate >= $start #need a conversion
2158 # AND calldate < $end #ditto
2159 # AND ( charged_party = "$did"
2160 # OR charged_party = "$prefix$did" #if length($prefix);
2161 # OR ( ( charged_party IS NULL OR charged_party = '' )
2163 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2166 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2169 if ( length($prefix) ) {
2171 " AND ( charged_party = '$did'
2172 OR charged_party = '$prefix$did'
2173 OR ( ( charged_party IS NULL OR charged_party = '' )
2175 ( src = '$did' OR src = '$prefix$did' )
2181 " AND ( charged_party = '$did'
2182 OR ( ( charged_party IS NULL OR charged_party = '' )
2192 'select' => "$for_update *",
2195 #( freesidestatus IS NULL OR freesidestatus = '' )
2196 'freesidestatus' => '',
2198 'extra_sql' => $charged_or_src,
2206 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2212 if ( $self->usergroup ) {
2213 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2214 unless ref($self->usergroup) eq 'ARRAY';
2215 #when provisioning records, export callback runs in svc_Common.pm before
2216 #radius_usergroup records can be inserted...
2217 @{$self->usergroup};
2219 map { $_->groupname }
2220 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2224 =item clone_suspended
2226 Constructor used by FS::part_export::_export_suspend fallback. Document
2231 sub clone_suspended {
2233 my %hash = $self->hash;
2234 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2235 new FS::svc_acct \%hash;
2238 =item clone_kludge_unsuspend
2240 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2245 sub clone_kludge_unsuspend {
2247 my %hash = $self->hash;
2248 $hash{_password} = '';
2249 new FS::svc_acct \%hash;
2252 =item check_password
2254 Checks the supplied password against the (possibly encrypted) password in the
2255 database. Returns true for a successful authentication, false for no match.
2257 Currently supported encryptions are: classic DES crypt() and MD5
2261 sub check_password {
2262 my($self, $check_password) = @_;
2264 #remove old-style SUSPENDED kludge, they should be allowed to login to
2265 #self-service and pay up
2266 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2268 if ( $self->_password_encoding eq 'ldap' ) {
2270 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2271 return $auth->match($check_password);
2273 } elsif ( $self->_password_encoding eq 'crypt' ) {
2275 my $auth = from_crypt Authen::Passphrase $self->_password;
2276 return $auth->match($check_password);
2278 } elsif ( $self->_password_encoding eq 'plain' ) {
2280 return $check_password eq $password;
2284 #XXX this could be replaced with Authen::Passphrase stuff
2286 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2288 } elsif ( length($password) < 13 ) { #plaintext
2289 $check_password eq $password;
2290 } elsif ( length($password) == 13 ) { #traditional DES crypt
2291 crypt($check_password, $password) eq $password;
2292 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2293 unix_md5_crypt($check_password, $password) eq $password;
2294 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2295 warn "Can't check password: Blowfish encryption not yet supported, ".
2296 "svcnum ". $self->svcnum. "\n";
2299 warn "Can't check password: Unrecognized encryption for svcnum ".
2300 $self->svcnum. "\n";
2308 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2310 Returns an encrypted password, either by passing through an encrypted password
2311 in the database or by encrypting a plaintext password from the database.
2313 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2314 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2315 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2316 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2317 encryption type is only used if the password is not already encrypted in the
2322 sub crypt_password {
2325 if ( $self->_password_encoding eq 'ldap' ) {
2327 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2330 #XXX this could be replaced with Authen::Passphrase stuff
2332 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2333 if ( $encryption eq 'crypt' ) {
2336 $saltset[int(rand(64))].$saltset[int(rand(64))]
2338 } elsif ( $encryption eq 'md5' ) {
2339 unix_md5_crypt( $self->_password );
2340 } elsif ( $encryption eq 'blowfish' ) {
2341 croak "unknown encryption method $encryption";
2343 croak "unknown encryption method $encryption";
2346 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2350 } elsif ( $self->_password_encoding eq 'crypt' ) {
2352 return $self->_password;
2354 } elsif ( $self->_password_encoding eq 'plain' ) {
2356 #XXX this could be replaced with Authen::Passphrase stuff
2358 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2359 if ( $encryption eq 'crypt' ) {
2362 $saltset[int(rand(64))].$saltset[int(rand(64))]
2364 } elsif ( $encryption eq 'md5' ) {
2365 unix_md5_crypt( $self->_password );
2366 } elsif ( $encryption eq 'blowfish' ) {
2367 croak "unknown encryption method $encryption";
2369 croak "unknown encryption method $encryption";
2374 if ( length($self->_password) == 13
2375 || $self->_password =~ /^\$(1|2a?)\$/
2376 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2382 #XXX this could be replaced with Authen::Passphrase stuff
2384 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2385 if ( $encryption eq 'crypt' ) {
2388 $saltset[int(rand(64))].$saltset[int(rand(64))]
2390 } elsif ( $encryption eq 'md5' ) {
2391 unix_md5_crypt( $self->_password );
2392 } elsif ( $encryption eq 'blowfish' ) {
2393 croak "unknown encryption method $encryption";
2395 croak "unknown encryption method $encryption";
2404 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2406 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2407 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2408 "{MD5}5426824942db4253f87a1009fd5d2d4".
2410 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2411 to work the same as the B</crypt_password> method.
2417 #eventually should check a "password-encoding" field
2419 if ( $self->_password_encoding eq 'ldap' ) {
2421 return $self->_password;
2423 } elsif ( $self->_password_encoding eq 'crypt' ) {
2425 if ( length($self->_password) == 13 ) { #crypt
2426 return '{CRYPT}'. $self->_password;
2427 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2429 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2430 # die "Blowfish encryption not supported in this context, svcnum ".
2431 # $self->svcnum. "\n";
2433 warn "encryption method not (yet?) supported in LDAP context";
2434 return '{CRYPT}*'; #unsupported, should not auth
2437 } elsif ( $self->_password_encoding eq 'plain' ) {
2439 return '{PLAIN}'. $self->_password;
2441 #return '{CLEARTEXT}'. $self->_password; #?
2445 if ( length($self->_password) == 13 ) { #crypt
2446 return '{CRYPT}'. $self->_password;
2447 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2449 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2450 warn "Blowfish encryption not supported in this context, svcnum ".
2451 $self->svcnum. "\n";
2454 #are these two necessary anymore?
2455 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2456 return '{SSHA}'. $1;
2457 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2458 return '{NS-MTA-MD5}'. $1;
2461 return '{PLAIN}'. $self->_password;
2463 #return '{CLEARTEXT}'. $self->_password; #?
2465 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2466 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2467 #if ( $encryption eq 'crypt' ) {
2468 # return '{CRYPT}'. crypt(
2470 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2472 #} elsif ( $encryption eq 'md5' ) {
2473 # unix_md5_crypt( $self->_password );
2474 #} elsif ( $encryption eq 'blowfish' ) {
2475 # croak "unknown encryption method $encryption";
2477 # croak "unknown encryption method $encryption";
2485 =item domain_slash_username
2487 Returns $domain/$username/
2491 sub domain_slash_username {
2493 $self->domain. '/'. $self->username. '/';
2496 =item virtual_maildir
2498 Returns $domain/maildirs/$username/
2502 sub virtual_maildir {
2504 $self->domain. '/maildirs/'. $self->username. '/';
2515 This is the FS::svc_acct job-queue-able version. It still uses
2516 FS::Misc::send_email under-the-hood.
2523 eval "use FS::Misc qw(send_email)";
2526 $opt{mimetype} ||= 'text/plain';
2527 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2529 my $error = send_email(
2530 'from' => $opt{from},
2532 'subject' => $opt{subject},
2533 'content-type' => $opt{mimetype},
2534 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2536 die $error if $error;
2539 =item check_and_rebuild_fuzzyfiles
2543 sub check_and_rebuild_fuzzyfiles {
2544 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2545 -e "$dir/svc_acct.username"
2546 or &rebuild_fuzzyfiles;
2549 =item rebuild_fuzzyfiles
2553 sub rebuild_fuzzyfiles {
2555 use Fcntl qw(:flock);
2557 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2561 open(USERNAMELOCK,">>$dir/svc_acct.username")
2562 or die "can't open $dir/svc_acct.username: $!";
2563 flock(USERNAMELOCK,LOCK_EX)
2564 or die "can't lock $dir/svc_acct.username: $!";
2566 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2568 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2569 or die "can't open $dir/svc_acct.username.tmp: $!";
2570 print USERNAMECACHE join("\n", @all_username), "\n";
2571 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2573 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2583 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2584 open(USERNAMECACHE,"<$dir/svc_acct.username")
2585 or die "can't open $dir/svc_acct.username: $!";
2586 my @array = map { chomp; $_; } <USERNAMECACHE>;
2587 close USERNAMECACHE;
2591 =item append_fuzzyfiles USERNAME
2595 sub append_fuzzyfiles {
2596 my $username = shift;
2598 &check_and_rebuild_fuzzyfiles;
2600 use Fcntl qw(:flock);
2602 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2604 open(USERNAME,">>$dir/svc_acct.username")
2605 or die "can't open $dir/svc_acct.username: $!";
2606 flock(USERNAME,LOCK_EX)
2607 or die "can't lock $dir/svc_acct.username: $!";
2609 print USERNAME "$username\n";
2611 flock(USERNAME,LOCK_UN)
2612 or die "can't unlock $dir/svc_acct.username: $!";
2620 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2624 sub radius_usergroup_selector {
2625 my $sel_groups = shift;
2626 my %sel_groups = map { $_=>1 } @$sel_groups;
2628 my $selectname = shift || 'radius_usergroup';
2631 my $sth = $dbh->prepare(
2632 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2633 ) or die $dbh->errstr;
2634 $sth->execute() or die $sth->errstr;
2635 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2639 function ${selectname}_doadd(object) {
2640 var myvalue = object.${selectname}_add.value;
2641 var optionName = new Option(myvalue,myvalue,false,true);
2642 var length = object.$selectname.length;
2643 object.$selectname.options[length] = optionName;
2644 object.${selectname}_add.value = "";
2647 <SELECT MULTIPLE NAME="$selectname">
2650 foreach my $group ( @all_groups ) {
2651 $html .= qq(<OPTION VALUE="$group");
2652 if ( $sel_groups{$group} ) {
2653 $html .= ' SELECTED';
2654 $sel_groups{$group} = 0;
2656 $html .= ">$group</OPTION>\n";
2658 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2659 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2661 $html .= '</SELECT>';
2663 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2664 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2669 =item reached_threshold
2671 Performs some activities when svc_acct thresholds (such as number of seconds
2672 remaining) are reached.
2676 sub reached_threshold {
2679 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2680 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2682 if ( $opt{'op'} eq '+' ){
2683 $svc_acct->setfield( $opt{'column'}.'_threshold',
2684 int($svc_acct->getfield($opt{'column'})
2685 * ( $conf->exists('svc_acct-usage_threshold')
2686 ? $conf->config('svc_acct-usage_threshold')/100
2691 my $error = $svc_acct->replace;
2692 die $error if $error;
2693 }elsif ( $opt{'op'} eq '-' ){
2695 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2696 return '' if ($threshold eq '' );
2698 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2699 my $error = $svc_acct->replace;
2700 die $error if $error; # email next time, i guess
2702 if ( $warning_template ) {
2703 eval "use FS::Misc qw(send_email)";
2706 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2707 my $cust_main = $cust_pkg->cust_main;
2709 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2710 $cust_main->invoicing_list,
2711 ($opt{'to'} ? $opt{'to'} : ())
2714 my $mimetype = $warning_mimetype;
2715 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2717 my $body = $warning_template->fill_in( HASH => {
2718 'custnum' => $cust_main->custnum,
2719 'username' => $svc_acct->username,
2720 'password' => $svc_acct->_password,
2721 'first' => $cust_main->first,
2722 'last' => $cust_main->getfield('last'),
2723 'pkg' => $cust_pkg->part_pkg->pkg,
2724 'column' => $opt{'column'},
2725 'amount' => $opt{'column'} =~/bytes/
2726 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2727 : $svc_acct->getfield($opt{'column'}),
2728 'threshold' => $opt{'column'} =~/bytes/
2729 ? FS::UI::bytecount::display_bytecount($threshold)
2734 my $error = send_email(
2735 'from' => $warning_from,
2737 'subject' => $warning_subject,
2738 'content-type' => $mimetype,
2739 'body' => [ map "$_\n", split("\n", $body) ],
2741 die $error if $error;
2744 die "unknown op: " . $opt{'op'};
2752 The $recref stuff in sub check should be cleaned up.
2754 The suspend, unsuspend and cancel methods update the database, but not the
2755 current object. This is probably a bug as it's unexpected and
2758 radius_usergroup_selector? putting web ui components in here? they should
2759 probably live somewhere else...
2761 insertion of RADIUS group stuff in insert could be done with child_objects now
2762 (would probably clean up export of them too)
2764 _op_usage and set_usage bypass the history... maybe they shouldn't
2768 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2769 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2770 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2771 L<freeside-queued>), L<FS::svc_acct_pop>,
2772 schema.html from the base documentation.
2776 =item domain_select_hash %OPTIONS
2778 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2779 may at present purchase.
2781 Currently available options are: I<pkgnum> I<svcpart>
2785 sub domain_select_hash {
2786 my ($self, %options) = @_;
2792 $part_svc = $self->part_svc;
2793 $cust_pkg = $self->cust_svc->cust_pkg
2797 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2798 if $options{'svcpart'};
2800 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2801 if $options{'pkgnum'};
2803 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2804 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2805 %domains = map { $_->svcnum => $_->domain }
2806 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2807 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2808 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2809 %domains = map { $_->svcnum => $_->domain }
2810 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2811 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2812 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2814 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2817 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2818 my $svc_domain = qsearchs('svc_domain',
2819 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2820 if ( $svc_domain ) {
2821 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2823 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2824 $part_svc->part_svc_column('domsvc')->columnvalue;