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;
37 use FS::cust_main_invoice;
41 use FS::radius_usergroup;
48 @ISA = qw( FS::svc_Common );
51 $me = '[FS::svc_acct]';
53 #ask FS::UID to run this stuff for us later
54 FS::UID->install_callback( sub {
56 $dir_prefix = $conf->config('home');
57 @shells = $conf->config('shells');
58 $usernamemin = $conf->config('usernamemin') || 2;
59 $usernamemax = $conf->config('usernamemax');
60 $passwordmin = $conf->config('passwordmin'); # || 6;
62 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
65 $passwordmax = $conf->config('passwordmax') || 8;
66 $username_letter = $conf->exists('username-letter');
67 $username_letterfirst = $conf->exists('username-letterfirst');
68 $username_noperiod = $conf->exists('username-noperiod');
69 $username_nounderscore = $conf->exists('username-nounderscore');
70 $username_nodash = $conf->exists('username-nodash');
71 $username_uppercase = $conf->exists('username-uppercase');
72 $username_ampersand = $conf->exists('username-ampersand');
73 $username_percent = $conf->exists('username-percent');
74 $username_colon = $conf->exists('username-colon');
75 $password_noampersand = $conf->exists('password-noexclamation');
76 $password_noexclamation = $conf->exists('password-noexclamation');
77 $dirhash = $conf->config('dirhash') || 0;
78 if ( $conf->exists('warning_email') ) {
79 $warning_template = new Text::Template (
81 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
82 ) or warn "can't create warning email template: $Text::Template::ERROR";
83 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
84 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
85 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
86 $warning_cc = $conf->config('warning_email-cc');
88 $warning_template = '';
90 $warning_subject = '';
91 $warning_mimetype = '';
94 $smtpmachine = $conf->config('smtpmachine');
95 $radius_password = $conf->config('radius-password') || 'Password';
96 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
97 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
101 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
102 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
106 my ( $hashref, $cache ) = @_;
107 if ( $hashref->{'svc_acct_svcnum'} ) {
108 $self->{'_domsvc'} = FS::svc_domain->new( {
109 'svcnum' => $hashref->{'domsvc'},
110 'domain' => $hashref->{'svc_acct_domain'},
111 'catchall' => $hashref->{'svc_acct_catchall'},
118 FS::svc_acct - Object methods for svc_acct records
124 $record = new FS::svc_acct \%hash;
125 $record = new FS::svc_acct { 'column' => 'value' };
127 $error = $record->insert;
129 $error = $new_record->replace($old_record);
131 $error = $record->delete;
133 $error = $record->check;
135 $error = $record->suspend;
137 $error = $record->unsuspend;
139 $error = $record->cancel;
141 %hash = $record->radius;
143 %hash = $record->radius_reply;
145 %hash = $record->radius_check;
147 $domain = $record->domain;
149 $svc_domain = $record->svc_domain;
151 $email = $record->email;
153 $seconds_since = $record->seconds_since($timestamp);
157 An FS::svc_acct object represents an account. FS::svc_acct inherits from
158 FS::svc_Common. The following fields are currently supported:
162 =item svcnum - primary key (assigned automatcially for new accounts)
166 =item _password - generated if blank
168 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
170 =item sec_phrase - security phrase
172 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
180 =item dir - set automatically if blank (and uid is not)
184 =item quota - (unimplementd)
186 =item slipip - IP address
196 =item domsvc - svcnum from svc_domain
198 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
200 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
210 Creates a new account. To add the account to the database, see L<"insert">.
217 'longname_plural' => 'Access accounts and mailboxes',
218 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
219 'display_weight' => 10,
220 'cancel_weight' => 50,
222 'dir' => 'Home directory',
225 def_info => 'set to fixed and blank for no UIDs',
228 'slipip' => 'IP address',
229 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
231 label => 'Access number',
233 select_table => 'svc_acct_pop',
234 select_key => 'popnum',
235 select_label => 'city',
241 disable_default => 1,
248 disable_inventory => 1,
251 '_password' => 'Password',
254 def_info => 'when blank, defaults to UID',
259 def_info => 'set to blank for no shell tracking',
261 #select_list => [ $conf->config('shells') ],
262 select_list => [ $conf ? $conf->config('shells') : () ],
263 disable_inventory => 1,
266 'finger' => 'Real name', # (GECOS)',
270 select_table => 'svc_domain',
271 select_key => 'svcnum',
272 select_label => 'domain',
273 disable_inventory => 1,
277 label => 'RADIUS groups',
278 type => 'radius_usergroup_selector',
279 disable_inventory => 1,
282 'seconds' => { label => 'Seconds',
283 label_sort => 'with Time Remaining',
285 disable_inventory => 1,
287 disable_part_svc_column => 1,
289 'upbytes' => { label => 'Upload',
291 disable_inventory => 1,
293 'format' => \&FS::UI::bytecount::display_bytecount,
294 'parse' => \&FS::UI::bytecount::parse_bytecount,
295 disable_part_svc_column => 1,
297 'downbytes' => { label => 'Download',
299 disable_inventory => 1,
301 'format' => \&FS::UI::bytecount::display_bytecount,
302 'parse' => \&FS::UI::bytecount::parse_bytecount,
303 disable_part_svc_column => 1,
305 'totalbytes'=> { label => 'Total up and download',
307 disable_inventory => 1,
309 'format' => \&FS::UI::bytecount::display_bytecount,
310 'parse' => \&FS::UI::bytecount::parse_bytecount,
311 disable_part_svc_column => 1,
313 'seconds_threshold' => { label => 'Seconds threshold',
315 disable_inventory => 1,
317 disable_part_svc_column => 1,
319 'upbytes_threshold' => { label => 'Upload threshold',
321 disable_inventory => 1,
323 'format' => \&FS::UI::bytecount::display_bytecount,
324 'parse' => \&FS::UI::bytecount::parse_bytecount,
325 disable_part_svc_column => 1,
327 'downbytes_threshold' => { label => 'Download threshold',
329 disable_inventory => 1,
331 'format' => \&FS::UI::bytecount::display_bytecount,
332 'parse' => \&FS::UI::bytecount::parse_bytecount,
333 disable_part_svc_column => 1,
335 'totalbytes_threshold'=> { label => 'Total up and download threshold',
337 disable_inventory => 1,
339 'format' => \&FS::UI::bytecount::display_bytecount,
340 'parse' => \&FS::UI::bytecount::parse_bytecount,
341 disable_part_svc_column => 1,
344 label => 'Last login',
348 label => 'Last logout',
355 sub table { 'svc_acct'; }
357 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
361 #false laziness with edit/svc_acct.cgi
363 my( $self, $groups ) = @_;
364 if ( ref($groups) eq 'ARRAY' ) {
366 } elsif ( length($groups) ) {
367 [ split(/\s*,\s*/, $groups) ];
376 shift->_lastlog('in', @_);
380 shift->_lastlog('out', @_);
384 my( $self, $op, $time ) = @_;
386 if ( defined($time) ) {
387 warn "$me last_log$op called on svcnum ". $self->svcnum.
388 ' ('. $self->email. "): $time\n"
393 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
397 my $sth = $dbh->prepare( $sql )
398 or die "Error preparing $sql: ". $dbh->errstr;
399 my $rv = $sth->execute($time, $self->svcnum);
400 die "Error executing $sql: ". $sth->errstr
402 die "Can't update last_log$op for svcnum". $self->svcnum
405 $self->{'Hash'}->{"last_log$op"} = $time;
407 $self->getfield("last_log$op");
411 =item search_sql STRING
413 Class method which returns an SQL fragment to search for the given string.
418 my( $class, $string ) = @_;
419 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
420 my( $username, $domain ) = ( $1, $2 );
421 my $q_username = dbh->quote($username);
422 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
424 "svc_acct.username = $q_username AND ( ".
425 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
430 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
432 $class->search_sql_field('slipip', $string ).
434 $class->search_sql_field('username', $string ).
438 $class->search_sql_field('username', $string).
440 ? 'OR '. $class->search_sql_field('svcnum', $string)
447 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
449 Returns the "username@domain" string for this account.
451 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
461 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
463 Returns a longer string label for this acccount ("Real Name <username@domain>"
464 if available, or "username@domain").
466 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
473 my $label = $self->label(@_);
474 my $finger = $self->finger;
475 return $label unless $finger =~ /\S/;
476 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
477 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
481 =item insert [ , OPTION => VALUE ... ]
483 Adds this account to the database. If there is an error, returns the error,
484 otherwise returns false.
486 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
487 defined. An FS::cust_svc record will be created and inserted.
489 The additional field I<usergroup> can optionally be defined; if so it should
490 contain an arrayref of group names. See L<FS::radius_usergroup>.
492 The additional field I<child_objects> can optionally be defined; if so it
493 should contain an arrayref of FS::tablename objects. They will have their
494 svcnum fields set and will be inserted after this record, but before any
495 exports are run. Each element of the array can also optionally be a
496 two-element array reference containing the child object and the name of an
497 alternate field to be filled in with the newly-inserted svcnum, for example
498 C<[ $svc_forward, 'srcsvc' ]>
500 Currently available options are: I<depend_jobnum>
502 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
503 jobnums), all provisioning jobs will have a dependancy on the supplied
504 jobnum(s) (they will not run until the specific job(s) complete(s)).
506 (TODOC: L<FS::queue> and L<freeside-queued>)
508 (TODOC: new exports!)
517 warn "[$me] insert called on $self: ". Dumper($self).
518 "\nwith options: ". Dumper(%options);
521 local $SIG{HUP} = 'IGNORE';
522 local $SIG{INT} = 'IGNORE';
523 local $SIG{QUIT} = 'IGNORE';
524 local $SIG{TERM} = 'IGNORE';
525 local $SIG{TSTP} = 'IGNORE';
526 local $SIG{PIPE} = 'IGNORE';
528 my $oldAutoCommit = $FS::UID::AutoCommit;
529 local $FS::UID::AutoCommit = 0;
533 my $error = $self->SUPER::insert(
534 'jobnums' => \@jobnums,
535 'child_objects' => $self->child_objects,
539 $dbh->rollback if $oldAutoCommit;
543 if ( $self->usergroup ) {
544 foreach my $groupname ( @{$self->usergroup} ) {
545 my $radius_usergroup = new FS::radius_usergroup ( {
546 svcnum => $self->svcnum,
547 groupname => $groupname,
549 my $error = $radius_usergroup->insert;
551 $dbh->rollback if $oldAutoCommit;
557 unless ( $skip_fuzzyfiles ) {
558 $error = $self->queue_fuzzyfiles_update;
560 $dbh->rollback if $oldAutoCommit;
561 return "updating fuzzy search cache: $error";
565 my $cust_pkg = $self->cust_svc->cust_pkg;
568 my $cust_main = $cust_pkg->cust_main;
569 my $agentnum = $cust_main->agentnum;
571 if ( $conf->exists('emailinvoiceautoalways')
572 || $conf->exists('emailinvoiceauto')
573 && ! $cust_main->invoicing_list_emailonly
575 my @invoicing_list = $cust_main->invoicing_list;
576 push @invoicing_list, $self->email;
577 $cust_main->invoicing_list(\@invoicing_list);
581 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
582 = ('','','','','','');
584 if ( $conf->exists('welcome_email', $agentnum) ) {
585 $welcome_template = new Text::Template (
587 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
588 ) or warn "can't create welcome email template: $Text::Template::ERROR";
589 $welcome_from = $conf->config('welcome_email-from', $agentnum);
590 # || 'your-isp-is-dum'
591 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
593 $welcome_subject_template = new Text::Template (
595 SOURCE => $welcome_subject,
596 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
597 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
600 if ( $welcome_template && $cust_pkg ) {
601 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
605 'custnum' => $self->custnum,
606 'username' => $self->username,
607 'password' => $self->_password,
608 'first' => $cust_main->first,
609 'last' => $cust_main->getfield('last'),
610 'pkg' => $cust_pkg->part_pkg->pkg,
612 my $wqueue = new FS::queue {
613 'svcnum' => $self->svcnum,
614 'job' => 'FS::svc_acct::send_email'
616 my $error = $wqueue->insert(
618 'from' => $welcome_from,
619 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
620 'mimetype' => $welcome_mimetype,
621 'body' => $welcome_template->fill_in( HASH => \%hash, ),
624 $dbh->rollback if $oldAutoCommit;
625 return "error queuing welcome email: $error";
628 if ( $options{'depend_jobnum'} ) {
629 warn "$me depend_jobnum found; adding to welcome email dependancies"
631 if ( ref($options{'depend_jobnum'}) ) {
632 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
633 "to welcome email dependancies"
635 push @jobnums, @{ $options{'depend_jobnum'} };
637 warn "$me adding job $options{'depend_jobnum'} ".
638 "to welcome email dependancies"
640 push @jobnums, $options{'depend_jobnum'};
644 foreach my $jobnum ( @jobnums ) {
645 my $error = $wqueue->depend_insert($jobnum);
647 $dbh->rollback if $oldAutoCommit;
648 return "error queuing welcome email job dependancy: $error";
658 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
662 # set usage fields and thresholds if unset but set in a package def
663 sub preinsert_hook_first {
666 return '' unless $self->pkgnum;
668 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
669 my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
670 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
672 my %values = $part_pkg->usage_valuehash;
673 my $multiplier = $conf->exists('svc_acct-usage_threshold')
674 ? 1 - $conf->config('svc_acct-usage_threshold')/100
675 : 0.20; #doesn't matter
677 foreach ( keys %values ) {
678 next if $self->getfield($_);
679 $self->setfield( $_, $values{$_} );
680 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
681 if $conf->exists('svc_acct-usage_threshold');
689 Deletes this account from the database. If there is an error, returns the
690 error, otherwise returns false.
692 The corresponding FS::cust_svc record will be deleted as well.
694 (TODOC: new exports!)
701 return "can't delete system account" if $self->_check_system;
703 return "Can't delete an account which is a (svc_forward) source!"
704 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
706 return "Can't delete an account which is a (svc_forward) destination!"
707 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
709 return "Can't delete an account with (svc_www) web service!"
710 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
712 # what about records in session ? (they should refer to history table)
714 local $SIG{HUP} = 'IGNORE';
715 local $SIG{INT} = 'IGNORE';
716 local $SIG{QUIT} = 'IGNORE';
717 local $SIG{TERM} = 'IGNORE';
718 local $SIG{TSTP} = 'IGNORE';
719 local $SIG{PIPE} = 'IGNORE';
721 my $oldAutoCommit = $FS::UID::AutoCommit;
722 local $FS::UID::AutoCommit = 0;
725 foreach my $cust_main_invoice (
726 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
728 unless ( defined($cust_main_invoice) ) {
729 warn "WARNING: something's wrong with qsearch";
732 my %hash = $cust_main_invoice->hash;
733 $hash{'dest'} = $self->email;
734 my $new = new FS::cust_main_invoice \%hash;
735 my $error = $new->replace($cust_main_invoice);
737 $dbh->rollback if $oldAutoCommit;
742 foreach my $svc_domain (
743 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
745 my %hash = new FS::svc_domain->hash;
746 $hash{'catchall'} = '';
747 my $new = new FS::svc_domain \%hash;
748 my $error = $new->replace($svc_domain);
750 $dbh->rollback if $oldAutoCommit;
755 my $error = $self->SUPER::delete;
757 $dbh->rollback if $oldAutoCommit;
761 foreach my $radius_usergroup (
762 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
764 my $error = $radius_usergroup->delete;
766 $dbh->rollback if $oldAutoCommit;
771 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
775 =item replace OLD_RECORD
777 Replaces OLD_RECORD with this one in the database. If there is an error,
778 returns the error, otherwise returns false.
780 The additional field I<usergroup> can optionally be defined; if so it should
781 contain an arrayref of group names. See L<FS::radius_usergroup>.
789 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
793 warn "$me replacing $old with $new\n" if $DEBUG;
797 return "can't modify system account" if $old->_check_system;
800 #no warnings 'numeric'; #alas, a 5.006-ism
803 foreach my $xid (qw( uid gid )) {
805 return "Can't change $xid!"
806 if ! $conf->exists("svc_acct-edit_$xid")
807 && $old->$xid() != $new->$xid()
808 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
813 #change homdir when we change username
814 $new->setfield('dir', '') if $old->username ne $new->username;
816 local $SIG{HUP} = 'IGNORE';
817 local $SIG{INT} = 'IGNORE';
818 local $SIG{QUIT} = 'IGNORE';
819 local $SIG{TERM} = 'IGNORE';
820 local $SIG{TSTP} = 'IGNORE';
821 local $SIG{PIPE} = 'IGNORE';
823 my $oldAutoCommit = $FS::UID::AutoCommit;
824 local $FS::UID::AutoCommit = 0;
827 # redundant, but so $new->usergroup gets set
828 $error = $new->check;
829 return $error if $error;
831 $old->usergroup( [ $old->radius_groups ] );
833 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
834 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
836 if ( $new->usergroup ) {
837 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
838 my @newgroups = @{$new->usergroup};
839 foreach my $oldgroup ( @{$old->usergroup} ) {
840 if ( grep { $oldgroup eq $_ } @newgroups ) {
841 @newgroups = grep { $oldgroup ne $_ } @newgroups;
844 my $radius_usergroup = qsearchs('radius_usergroup', {
845 svcnum => $old->svcnum,
846 groupname => $oldgroup,
848 my $error = $radius_usergroup->delete;
850 $dbh->rollback if $oldAutoCommit;
851 return "error deleting radius_usergroup $oldgroup: $error";
855 foreach my $newgroup ( @newgroups ) {
856 my $radius_usergroup = new FS::radius_usergroup ( {
857 svcnum => $new->svcnum,
858 groupname => $newgroup,
860 my $error = $radius_usergroup->insert;
862 $dbh->rollback if $oldAutoCommit;
863 return "error adding radius_usergroup $newgroup: $error";
869 $error = $new->SUPER::replace($old, @_);
871 $dbh->rollback if $oldAutoCommit;
872 return $error if $error;
875 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
876 $error = $new->queue_fuzzyfiles_update;
878 $dbh->rollback if $oldAutoCommit;
879 return "updating fuzzy search cache: $error";
883 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
887 =item queue_fuzzyfiles_update
889 Used by insert & replace to update the fuzzy search cache
893 sub queue_fuzzyfiles_update {
896 local $SIG{HUP} = 'IGNORE';
897 local $SIG{INT} = 'IGNORE';
898 local $SIG{QUIT} = 'IGNORE';
899 local $SIG{TERM} = 'IGNORE';
900 local $SIG{TSTP} = 'IGNORE';
901 local $SIG{PIPE} = 'IGNORE';
903 my $oldAutoCommit = $FS::UID::AutoCommit;
904 local $FS::UID::AutoCommit = 0;
907 my $queue = new FS::queue {
908 'svcnum' => $self->svcnum,
909 'job' => 'FS::svc_acct::append_fuzzyfiles'
911 my $error = $queue->insert($self->username);
913 $dbh->rollback if $oldAutoCommit;
914 return "queueing job (transaction rolled back): $error";
917 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
925 Suspends this account by calling export-specific suspend hooks. If there is
926 an error, returns the error, otherwise returns false.
928 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
934 return "can't suspend system account" if $self->_check_system;
935 $self->SUPER::suspend(@_);
940 Unsuspends this account by by calling export-specific suspend hooks. If there
941 is an error, returns the error, otherwise returns false.
943 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
949 my %hash = $self->hash;
950 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
951 $hash{_password} = $1;
952 my $new = new FS::svc_acct ( \%hash );
953 my $error = $new->replace($self);
954 return $error if $error;
957 $self->SUPER::unsuspend(@_);
962 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
964 If the B<auto_unset_catchall> configuration option is set, this method will
965 automatically remove any references to the canceled service in the catchall
966 field of svc_domain. This allows packages that contain both a svc_domain and
967 its catchall svc_acct to be canceled in one step.
972 # Only one thing to do at this level
974 foreach my $svc_domain (
975 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
976 if($conf->exists('auto_unset_catchall')) {
977 my %hash = $svc_domain->hash;
978 $hash{catchall} = '';
979 my $new = new FS::svc_domain ( \%hash );
980 my $error = $new->replace($svc_domain);
981 return $error if $error;
983 return "cannot unprovision svc_acct #".$self->svcnum.
984 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
988 $self->SUPER::cancel(@_);
994 Checks all fields to make sure this is a valid service. If there is an error,
995 returns the error, otherwise returns false. Called by the insert and replace
998 Sets any fixed values; see L<FS::part_svc>.
1005 my($recref) = $self->hashref;
1007 my $x = $self->setfixed( $self->_fieldhandlers );
1008 return $x unless ref($x);
1011 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1013 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1016 my $error = $self->ut_numbern('svcnum')
1017 #|| $self->ut_number('domsvc')
1018 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1019 || $self->ut_textn('sec_phrase')
1020 || $self->ut_snumbern('seconds')
1021 || $self->ut_snumbern('upbytes')
1022 || $self->ut_snumbern('downbytes')
1023 || $self->ut_snumbern('totalbytes')
1024 || $self->ut_enum( '_password_encoding',
1025 [ '', qw( plain crypt ldap ) ]
1028 return $error if $error;
1031 local $username_letter = $username_letter;
1032 if ($self->svcnum) {
1033 my $cust_svc = $self->cust_svc
1034 or return "no cust_svc record found for svcnum ". $self->svcnum;
1035 my $cust_pkg = $cust_svc->cust_pkg;
1037 if ($self->pkgnum) {
1038 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1042 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1045 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1046 if ( $username_uppercase ) {
1047 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1048 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1049 $recref->{username} = $1;
1051 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1052 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1053 $recref->{username} = $1;
1056 if ( $username_letterfirst ) {
1057 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1058 } elsif ( $username_letter ) {
1059 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1061 if ( $username_noperiod ) {
1062 $recref->{username} =~ /\./ and return gettext('illegal_username');
1064 if ( $username_nounderscore ) {
1065 $recref->{username} =~ /_/ and return gettext('illegal_username');
1067 if ( $username_nodash ) {
1068 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1070 unless ( $username_ampersand ) {
1071 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1073 unless ( $username_percent ) {
1074 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1076 unless ( $username_colon ) {
1077 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1080 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1081 $recref->{popnum} = $1;
1082 return "Unknown popnum" unless
1083 ! $recref->{popnum} ||
1084 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1086 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1088 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1089 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1091 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1092 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1093 #not all systems use gid=uid
1094 #you can set a fixed gid in part_svc
1096 return "Only root can have uid 0"
1097 if $recref->{uid} == 0
1098 && $recref->{username} !~ /^(root|toor|smtp)$/;
1100 unless ( $recref->{username} eq 'sync' ) {
1101 if ( grep $_ eq $recref->{shell}, @shells ) {
1102 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1104 return "Illegal shell \`". $self->shell. "\'; ".
1105 "shells configuration value contains: @shells";
1108 $recref->{shell} = '/bin/sync';
1112 $recref->{gid} ne '' ?
1113 return "Can't have gid without uid" : ( $recref->{gid}='' );
1114 #$recref->{dir} ne '' ?
1115 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1116 $recref->{shell} ne '' ?
1117 return "Can't have shell without uid" : ( $recref->{shell}='' );
1120 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1122 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1123 or return "Illegal directory: ". $recref->{dir};
1124 $recref->{dir} = $1;
1125 return "Illegal directory"
1126 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1127 return "Illegal directory"
1128 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1129 unless ( $recref->{dir} ) {
1130 $recref->{dir} = $dir_prefix . '/';
1131 if ( $dirhash > 0 ) {
1132 for my $h ( 1 .. $dirhash ) {
1133 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1135 } elsif ( $dirhash < 0 ) {
1136 for my $h ( reverse $dirhash .. -1 ) {
1137 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1140 $recref->{dir} .= $recref->{username};
1146 # $error = $self->ut_textn('finger');
1147 # return $error if $error;
1148 if ( $self->getfield('finger') eq '' ) {
1149 my $cust_pkg = $self->svcnum
1150 ? $self->cust_svc->cust_pkg
1151 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1153 my $cust_main = $cust_pkg->cust_main;
1154 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1157 $self->getfield('finger') =~
1158 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1159 or return "Illegal finger: ". $self->getfield('finger');
1160 $self->setfield('finger', $1);
1162 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1163 $recref->{quota} = $1;
1165 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1166 if ( $recref->{slipip} eq '' ) {
1167 $recref->{slipip} = '';
1168 } elsif ( $recref->{slipip} eq '0e0' ) {
1169 $recref->{slipip} = '0e0';
1171 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1172 or return "Illegal slipip: ". $self->slipip;
1173 $recref->{slipip} = $1;
1178 #arbitrary RADIUS stuff; allow ut_textn for now
1179 foreach ( grep /^radius_/, fields('svc_acct') ) {
1180 $self->ut_textn($_);
1183 if ( $recref->{_password_encoding} eq 'ldap' ) {
1185 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1186 $recref->{_password} = uc($1).$2;
1188 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1191 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1193 if ( $recref->{_password} =~
1194 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1195 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1198 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1201 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1204 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1206 #generate a password if it is blank
1207 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1208 unless length( $recref->{_password} );
1210 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1211 $recref->{_password} = $1;
1213 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1214 FS::Msgcat::_gettext('illegal_password_characters').
1215 ": ". $recref->{_password};
1218 if ( $password_noampersand ) {
1219 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1221 if ( $password_noexclamation ) {
1222 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1227 #carp "warning: _password_encoding unspecified\n";
1229 #generate a password if it is blank
1230 unless ( length($recref->{_password}) || ! $passwordmin ) {
1232 $recref->{_password} =
1233 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1234 $recref->{_password_encoding} = 'plain';
1238 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1239 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1240 $recref->{_password} = $1.$3;
1241 $recref->{_password_encoding} = 'plain';
1242 } elsif ( $recref->{_password} =~
1243 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1245 $recref->{_password} = $1.$3;
1246 $recref->{_password_encoding} = 'crypt';
1247 } elsif ( $recref->{_password} eq '*' ) {
1248 $recref->{_password} = '*';
1249 $recref->{_password_encoding} = 'crypt';
1250 } elsif ( $recref->{_password} eq '!' ) {
1251 $recref->{_password_encoding} = 'crypt';
1252 $recref->{_password} = '!';
1253 } elsif ( $recref->{_password} eq '!!' ) {
1254 $recref->{_password} = '!!';
1255 $recref->{_password_encoding} = 'crypt';
1257 #return "Illegal password";
1258 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1259 FS::Msgcat::_gettext('illegal_password_characters').
1260 ": ". $recref->{_password};
1267 $self->SUPER::check;
1273 Internal function to check the username against the list of system usernames
1274 from the I<system_usernames> configuration value. Returns true if the username
1275 is listed on the system username list.
1281 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1282 $conf->config('system_usernames')
1286 =item _check_duplicate
1288 Internal method to check for duplicates usernames, username@domain pairs and
1291 If the I<global_unique-username> configuration value is set to B<username> or
1292 B<username@domain>, enforces global username or username@domain uniqueness.
1294 In all cases, check for duplicate uids and usernames or username@domain pairs
1295 per export and with identical I<svcpart> values.
1299 sub _check_duplicate {
1302 my $global_unique = $conf->config('global_unique-username') || 'none';
1303 return '' if $global_unique eq 'disabled';
1307 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1308 unless ( $part_svc ) {
1309 return 'unknown svcpart '. $self->svcpart;
1312 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1313 qsearch( 'svc_acct', { 'username' => $self->username } );
1314 return gettext('username_in_use')
1315 if $global_unique eq 'username' && @dup_user;
1317 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1318 qsearch( 'svc_acct', { 'username' => $self->username,
1319 'domsvc' => $self->domsvc } );
1320 return gettext('username_in_use')
1321 if $global_unique eq 'username@domain' && @dup_userdomain;
1324 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1325 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1326 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1327 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1332 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1333 my $exports = FS::part_export::export_info('svc_acct');
1334 my %conflict_user_svcpart;
1335 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1337 foreach my $part_export ( $part_svc->part_export ) {
1339 #this will catch to the same exact export
1340 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1342 #this will catch to exports w/same exporthost+type ???
1343 #my @other_part_export = qsearch('part_export', {
1344 # 'machine' => $part_export->machine,
1345 # 'exporttype' => $part_export->exporttype,
1347 #foreach my $other_part_export ( @other_part_export ) {
1348 # push @svcparts, map { $_->svcpart }
1349 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1352 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1353 #silly kludge to avoid uninitialized value errors
1354 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1355 ? $exports->{$part_export->exporttype}{'nodomain'}
1357 if ( $nodomain =~ /^Y/i ) {
1358 $conflict_user_svcpart{$_} = $part_export->exportnum
1361 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1366 foreach my $dup_user ( @dup_user ) {
1367 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1368 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1369 return "duplicate username ". $self->username.
1370 ": conflicts with svcnum ". $dup_user->svcnum.
1371 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1375 foreach my $dup_userdomain ( @dup_userdomain ) {
1376 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1377 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1378 return "duplicate username\@domain ". $self->email.
1379 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1380 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1384 foreach my $dup_uid ( @dup_uid ) {
1385 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1386 if ( exists($conflict_user_svcpart{$dup_svcpart})
1387 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1388 return "duplicate uid ". $self->uid.
1389 ": conflicts with svcnum ". $dup_uid->svcnum.
1391 ( $conflict_user_svcpart{$dup_svcpart}
1392 || $conflict_userdomain_svcpart{$dup_svcpart} );
1404 Depriciated, use radius_reply instead.
1409 carp "FS::svc_acct::radius depriciated, use radius_reply";
1410 $_[0]->radius_reply;
1415 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1416 reply attributes of this record.
1418 Note that this is now the preferred method for reading RADIUS attributes -
1419 accessing the columns directly is discouraged, as the column names are
1420 expected to change in the future.
1427 return %{ $self->{'radius_reply'} }
1428 if exists $self->{'radius_reply'};
1433 my($column, $attrib) = ($1, $2);
1434 #$attrib =~ s/_/\-/g;
1435 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1436 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1438 if ( $self->slipip && $self->slipip ne '0e0' ) {
1439 $reply{$radius_ip} = $self->slipip;
1442 if ( $self->seconds !~ /^$/ ) {
1443 $reply{'Session-Timeout'} = $self->seconds;
1446 if ( $conf->exists('radius-chillispot-max') ) {
1447 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1449 #hmm. just because sqlradius.pm says so?
1456 foreach my $what (qw( input output total )) {
1457 my $is = $whatis{$what}.'bytes';
1458 if ( $self->$is() =~ /\d/ ) {
1459 my $big = new Math::BigInt $self->$is();
1460 $big = new Math::BigInt '0' if $big->is_neg();
1461 my $att = "Chillispot-Max-\u$what";
1462 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1463 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1474 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1475 check attributes of this record.
1477 Note that this is now the preferred method for reading RADIUS attributes -
1478 accessing the columns directly is discouraged, as the column names are
1479 expected to change in the future.
1486 return %{ $self->{'radius_check'} }
1487 if exists $self->{'radius_check'};
1492 my($column, $attrib) = ($1, $2);
1493 #$attrib =~ s/_/\-/g;
1494 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1495 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1498 my($pw_attrib, $password) = $self->radius_password;
1499 $check{$pw_attrib} = $password;
1501 my $cust_svc = $self->cust_svc;
1503 my $cust_pkg = $cust_svc->cust_pkg;
1504 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1505 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1508 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1509 "; can't set Expiration\n"
1517 =item radius_password
1519 Returns a key/value pair containing the RADIUS attribute name and value
1524 sub radius_password {
1527 my($pw_attrib, $password);
1528 if ( $self->_password_encoding eq 'ldap' ) {
1530 $pw_attrib = 'Password-With-Header';
1531 $password = $self->_password;
1533 } elsif ( $self->_password_encoding eq 'crypt' ) {
1535 $pw_attrib = 'Crypt-Password';
1536 $password = $self->_password;
1538 } elsif ( $self->_password_encoding eq 'plain' ) {
1540 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1541 $password = $self->_password;
1545 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1546 $password = $self->_password;
1550 ($pw_attrib, $password);
1556 This method instructs the object to "snapshot" or freeze RADIUS check and
1557 reply attributes to the current values.
1561 #bah, my english is too broken this morning
1562 #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
1563 #the FS::cust_pkg's replace method to trigger the correct export updates when
1564 #package dates change)
1569 $self->{$_} = { $self->$_() }
1570 foreach qw( radius_reply radius_check );
1574 =item forget_snapshot
1576 This methos instructs the object to forget any previously snapshotted
1577 RADIUS check and reply attributes.
1581 sub forget_snapshot {
1585 foreach qw( radius_reply radius_check );
1589 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1591 Returns the domain associated with this account.
1593 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1600 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1601 my $svc_domain = $self->svc_domain(@_)
1602 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1603 $svc_domain->domain;
1608 Returns the FS::svc_domain record for this account's domain (see
1613 # FS::h_svc_acct has a history-aware svc_domain override
1618 ? $self->{'_domsvc'}
1619 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1624 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1628 #inherited from svc_Common
1630 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1632 Returns an email address associated with the account.
1634 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1641 $self->username. '@'. $self->domain(@_);
1646 Returns an array of FS::acct_snarf records associated with the account.
1647 If the acct_snarf table does not exist or there are no associated records,
1648 an empty list is returned
1654 return () unless dbdef->table('acct_snarf');
1655 eval "use FS::acct_snarf;";
1657 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1660 =item decrement_upbytes OCTETS
1662 Decrements the I<upbytes> field of this record by the given amount. If there
1663 is an error, returns the error, otherwise returns false.
1667 sub decrement_upbytes {
1668 shift->_op_usage('-', 'upbytes', @_);
1671 =item increment_upbytes OCTETS
1673 Increments the I<upbytes> field of this record by the given amount. If there
1674 is an error, returns the error, otherwise returns false.
1678 sub increment_upbytes {
1679 shift->_op_usage('+', 'upbytes', @_);
1682 =item decrement_downbytes OCTETS
1684 Decrements the I<downbytes> field of this record by the given amount. If there
1685 is an error, returns the error, otherwise returns false.
1689 sub decrement_downbytes {
1690 shift->_op_usage('-', 'downbytes', @_);
1693 =item increment_downbytes OCTETS
1695 Increments the I<downbytes> field of this record by the given amount. If there
1696 is an error, returns the error, otherwise returns false.
1700 sub increment_downbytes {
1701 shift->_op_usage('+', 'downbytes', @_);
1704 =item decrement_totalbytes OCTETS
1706 Decrements the I<totalbytes> field of this record by the given amount. If there
1707 is an error, returns the error, otherwise returns false.
1711 sub decrement_totalbytes {
1712 shift->_op_usage('-', 'totalbytes', @_);
1715 =item increment_totalbytes OCTETS
1717 Increments the I<totalbytes> field of this record by the given amount. If there
1718 is an error, returns the error, otherwise returns false.
1722 sub increment_totalbytes {
1723 shift->_op_usage('+', 'totalbytes', @_);
1726 =item decrement_seconds SECONDS
1728 Decrements the I<seconds> field of this record by the given amount. If there
1729 is an error, returns the error, otherwise returns false.
1733 sub decrement_seconds {
1734 shift->_op_usage('-', 'seconds', @_);
1737 =item increment_seconds SECONDS
1739 Increments the I<seconds> field of this record by the given amount. If there
1740 is an error, returns the error, otherwise returns false.
1744 sub increment_seconds {
1745 shift->_op_usage('+', 'seconds', @_);
1753 my %op2condition = (
1754 '-' => sub { my($self, $column, $amount) = @_;
1755 $self->$column - $amount <= 0;
1757 '+' => sub { my($self, $column, $amount) = @_;
1758 ($self->$column || 0) + $amount > 0;
1761 my %op2warncondition = (
1762 '-' => sub { my($self, $column, $amount) = @_;
1763 my $threshold = $column . '_threshold';
1764 $self->$column - $amount <= $self->$threshold + 0;
1766 '+' => sub { my($self, $column, $amount) = @_;
1767 ($self->$column || 0) + $amount > 0;
1772 my( $self, $op, $column, $amount ) = @_;
1774 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1775 ' ('. $self->email. "): $op $amount\n"
1778 return '' unless $amount;
1780 local $SIG{HUP} = 'IGNORE';
1781 local $SIG{INT} = 'IGNORE';
1782 local $SIG{QUIT} = 'IGNORE';
1783 local $SIG{TERM} = 'IGNORE';
1784 local $SIG{TSTP} = 'IGNORE';
1785 local $SIG{PIPE} = 'IGNORE';
1787 my $oldAutoCommit = $FS::UID::AutoCommit;
1788 local $FS::UID::AutoCommit = 0;
1791 my $sql = "UPDATE svc_acct SET $column = ".
1792 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1793 " $op ? WHERE svcnum = ?";
1797 my $sth = $dbh->prepare( $sql )
1798 or die "Error preparing $sql: ". $dbh->errstr;
1799 my $rv = $sth->execute($amount, $self->svcnum);
1800 die "Error executing $sql: ". $sth->errstr
1801 unless defined($rv);
1802 die "Can't update $column for svcnum". $self->svcnum
1805 #$self->snapshot; #not necessary, we retain the old values
1806 #create an object with the updated usage values
1807 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1809 my $error = $new->replace($self);
1811 $dbh->rollback if $oldAutoCommit;
1812 return "Error replacing: $error";
1815 #overlimit_action eq 'cancel' handling
1816 my $cust_pkg = $self->cust_svc->cust_pkg;
1818 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1819 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1823 my $error = $cust_pkg->cancel; #XXX should have a reason
1825 $dbh->rollback if $oldAutoCommit;
1826 return "Error cancelling: $error";
1829 #nothing else is relevant if we're cancelling, so commit & return success
1830 warn "$me update successful; committing\n"
1832 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1837 my $action = $op2action{$op};
1839 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1840 ( $action eq 'suspend' && !$self->overlimit
1841 || $action eq 'unsuspend' && $self->overlimit )
1844 my $error = $self->_op_overlimit($action);
1846 $dbh->rollback if $oldAutoCommit;
1852 if ( $conf->exists("svc_acct-usage_$action")
1853 && &{$op2condition{$op}}($self, $column, $amount) ) {
1854 #my $error = $self->$action();
1855 my $error = $self->cust_svc->cust_pkg->$action();
1856 # $error ||= $self->overlimit($action);
1858 $dbh->rollback if $oldAutoCommit;
1859 return "Error ${action}ing: $error";
1863 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1864 my $wqueue = new FS::queue {
1865 'svcnum' => $self->svcnum,
1866 'job' => 'FS::svc_acct::reached_threshold',
1871 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1875 my $error = $wqueue->insert(
1876 'svcnum' => $self->svcnum,
1878 'column' => $column,
1882 $dbh->rollback if $oldAutoCommit;
1883 return "Error queuing threshold activity: $error";
1887 warn "$me update successful; committing\n"
1889 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1895 my( $self, $action ) = @_;
1897 local $SIG{HUP} = 'IGNORE';
1898 local $SIG{INT} = 'IGNORE';
1899 local $SIG{QUIT} = 'IGNORE';
1900 local $SIG{TERM} = 'IGNORE';
1901 local $SIG{TSTP} = 'IGNORE';
1902 local $SIG{PIPE} = 'IGNORE';
1904 my $oldAutoCommit = $FS::UID::AutoCommit;
1905 local $FS::UID::AutoCommit = 0;
1908 my $cust_pkg = $self->cust_svc->cust_pkg;
1910 my $conf_overlimit =
1912 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
1913 : $conf->config('overlimit_groups');
1915 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1917 my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
1918 next unless $groups;
1920 my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
1922 my $other = new FS::svc_acct $self->hashref;
1923 $other->usergroup( $gref );
1926 if ($action eq 'suspend') {
1929 } else { # $action eq 'unsuspend'
1934 my $error = $part_export->export_replace($new, $old)
1935 || $self->overlimit($action);
1938 $dbh->rollback if $oldAutoCommit;
1939 return "Error replacing radius groups: $error";
1944 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1950 my( $self, $valueref, %options ) = @_;
1952 warn "$me set_usage called for svcnum ". $self->svcnum.
1953 ' ('. $self->email. "): ".
1954 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1957 local $SIG{HUP} = 'IGNORE';
1958 local $SIG{INT} = 'IGNORE';
1959 local $SIG{QUIT} = 'IGNORE';
1960 local $SIG{TERM} = 'IGNORE';
1961 local $SIG{TSTP} = 'IGNORE';
1962 local $SIG{PIPE} = 'IGNORE';
1964 local $FS::svc_Common::noexport_hack = 1;
1965 my $oldAutoCommit = $FS::UID::AutoCommit;
1966 local $FS::UID::AutoCommit = 0;
1971 if ( $options{null} ) {
1972 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
1973 qw( seconds upbytes downbytes totalbytes )
1976 foreach my $field (keys %$valueref){
1977 $reset = 1 if $valueref->{$field};
1978 $self->setfield($field, $valueref->{$field});
1979 $self->setfield( $field.'_threshold',
1980 int($self->getfield($field)
1981 * ( $conf->exists('svc_acct-usage_threshold')
1982 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1987 $handyhash{$field} = $self->getfield($field);
1988 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1990 #my $error = $self->replace; #NO! we avoid the call to ->check for
1991 #die $error if $error; #services not explicity changed via the UI
1993 my $sql = "UPDATE svc_acct SET " .
1994 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
1995 " WHERE svcnum = ". $self->svcnum;
2000 if (scalar(keys %handyhash)) {
2001 my $sth = $dbh->prepare( $sql )
2002 or die "Error preparing $sql: ". $dbh->errstr;
2003 my $rv = $sth->execute();
2004 die "Error executing $sql: ". $sth->errstr
2005 unless defined($rv);
2006 die "Can't update usage for svcnum ". $self->svcnum
2010 #$self->snapshot; #not necessary, we retain the old values
2011 #create an object with the updated usage values
2012 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2014 my $error = $new->replace($self);
2016 $dbh->rollback if $oldAutoCommit;
2017 return "Error replacing: $error";
2024 $error = $self->_op_overlimit('unsuspend')
2025 if $self->overlimit;;
2027 $error ||= $self->cust_svc->cust_pkg->unsuspend
2028 if $conf->exists("svc_acct-usage_unsuspend");
2031 $dbh->rollback if $oldAutoCommit;
2032 return "Error unsuspending: $error";
2037 warn "$me update successful; committing\n"
2039 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2045 =item recharge HASHREF
2047 Increments usage columns by the amount specified in HASHREF as
2048 column=>amount pairs.
2053 my ($self, $vhash) = @_;
2056 warn "[$me] recharge called on $self: ". Dumper($self).
2057 "\nwith vhash: ". Dumper($vhash);
2060 my $oldAutoCommit = $FS::UID::AutoCommit;
2061 local $FS::UID::AutoCommit = 0;
2065 foreach my $column (keys %$vhash){
2066 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2070 $dbh->rollback if $oldAutoCommit;
2072 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2077 =item is_rechargeable
2079 Returns true if this svc_account can be "recharged" and false otherwise.
2083 sub is_rechargable {
2085 $self->seconds ne ''
2086 || $self->upbytes ne ''
2087 || $self->downbytes ne ''
2088 || $self->totalbytes ne '';
2091 =item seconds_since TIMESTAMP
2093 Returns the number of seconds this account has been online since TIMESTAMP,
2094 according to the session monitor (see L<FS::Session>).
2096 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2097 L<Time::Local> and L<Date::Parse> for conversion functions.
2101 #note: POD here, implementation in FS::cust_svc
2104 $self->cust_svc->seconds_since(@_);
2107 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2109 Returns the numbers of seconds this account has been online between
2110 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2111 external SQL radacct table, specified via sqlradius export. Sessions which
2112 started in the specified range but are still open are counted from session
2113 start to the end of the range (unless they are over 1 day old, in which case
2114 they are presumed missing their stop record and not counted). Also, sessions
2115 which end in the range but started earlier are counted from the start of the
2116 range to session end. Finally, sessions which start before the range but end
2117 after are counted for the entire range.
2119 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2120 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2125 #note: POD here, implementation in FS::cust_svc
2126 sub seconds_since_sqlradacct {
2128 $self->cust_svc->seconds_since_sqlradacct(@_);
2131 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2133 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2134 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2135 TIMESTAMP_END (exclusive).
2137 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2138 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2143 #note: POD here, implementation in FS::cust_svc
2144 sub attribute_since_sqlradacct {
2146 $self->cust_svc->attribute_since_sqlradacct(@_);
2149 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2151 Returns an array of hash references of this customers login history for the
2152 given time range. (document this better)
2156 sub get_session_history {
2158 $self->cust_svc->get_session_history(@_);
2161 =item last_login_text
2163 Returns text describing the time of last login.
2167 sub last_login_text {
2169 $self->last_login ? ctime($self->last_login) : 'unknown';
2172 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2177 my($self, $start, $end, %opt ) = @_;
2179 my $did = $self->username; #yup
2181 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2183 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2185 #SELECT $for_update * FROM cdr
2186 # WHERE calldate >= $start #need a conversion
2187 # AND calldate < $end #ditto
2188 # AND ( charged_party = "$did"
2189 # OR charged_party = "$prefix$did" #if length($prefix);
2190 # OR ( ( charged_party IS NULL OR charged_party = '' )
2192 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2195 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2198 if ( length($prefix) ) {
2200 " AND ( charged_party = '$did'
2201 OR charged_party = '$prefix$did'
2202 OR ( ( charged_party IS NULL OR charged_party = '' )
2204 ( src = '$did' OR src = '$prefix$did' )
2210 " AND ( charged_party = '$did'
2211 OR ( ( charged_party IS NULL OR charged_party = '' )
2221 'select' => "$for_update *",
2224 #( freesidestatus IS NULL OR freesidestatus = '' )
2225 'freesidestatus' => '',
2227 'extra_sql' => $charged_or_src,
2235 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2241 if ( $self->usergroup ) {
2242 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2243 unless ref($self->usergroup) eq 'ARRAY';
2244 #when provisioning records, export callback runs in svc_Common.pm before
2245 #radius_usergroup records can be inserted...
2246 @{$self->usergroup};
2248 map { $_->groupname }
2249 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2253 =item clone_suspended
2255 Constructor used by FS::part_export::_export_suspend fallback. Document
2260 sub clone_suspended {
2262 my %hash = $self->hash;
2263 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2264 new FS::svc_acct \%hash;
2267 =item clone_kludge_unsuspend
2269 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2274 sub clone_kludge_unsuspend {
2276 my %hash = $self->hash;
2277 $hash{_password} = '';
2278 new FS::svc_acct \%hash;
2281 =item check_password
2283 Checks the supplied password against the (possibly encrypted) password in the
2284 database. Returns true for a successful authentication, false for no match.
2286 Currently supported encryptions are: classic DES crypt() and MD5
2290 sub check_password {
2291 my($self, $check_password) = @_;
2293 #remove old-style SUSPENDED kludge, they should be allowed to login to
2294 #self-service and pay up
2295 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2297 if ( $self->_password_encoding eq 'ldap' ) {
2299 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2300 return $auth->match($check_password);
2302 } elsif ( $self->_password_encoding eq 'crypt' ) {
2304 my $auth = from_crypt Authen::Passphrase $self->_password;
2305 return $auth->match($check_password);
2307 } elsif ( $self->_password_encoding eq 'plain' ) {
2309 return $check_password eq $password;
2313 #XXX this could be replaced with Authen::Passphrase stuff
2315 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2317 } elsif ( length($password) < 13 ) { #plaintext
2318 $check_password eq $password;
2319 } elsif ( length($password) == 13 ) { #traditional DES crypt
2320 crypt($check_password, $password) eq $password;
2321 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2322 unix_md5_crypt($check_password, $password) eq $password;
2323 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2324 warn "Can't check password: Blowfish encryption not yet supported, ".
2325 "svcnum ". $self->svcnum. "\n";
2328 warn "Can't check password: Unrecognized encryption for svcnum ".
2329 $self->svcnum. "\n";
2337 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2339 Returns an encrypted password, either by passing through an encrypted password
2340 in the database or by encrypting a plaintext password from the database.
2342 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2343 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2344 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2345 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2346 encryption type is only used if the password is not already encrypted in the
2351 sub crypt_password {
2354 if ( $self->_password_encoding eq 'ldap' ) {
2356 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2359 #XXX this could be replaced with Authen::Passphrase stuff
2361 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2362 if ( $encryption eq 'crypt' ) {
2365 $saltset[int(rand(64))].$saltset[int(rand(64))]
2367 } elsif ( $encryption eq 'md5' ) {
2368 unix_md5_crypt( $self->_password );
2369 } elsif ( $encryption eq 'blowfish' ) {
2370 croak "unknown encryption method $encryption";
2372 croak "unknown encryption method $encryption";
2375 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2379 } elsif ( $self->_password_encoding eq 'crypt' ) {
2381 return $self->_password;
2383 } elsif ( $self->_password_encoding eq 'plain' ) {
2385 #XXX this could be replaced with Authen::Passphrase stuff
2387 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2388 if ( $encryption eq 'crypt' ) {
2391 $saltset[int(rand(64))].$saltset[int(rand(64))]
2393 } elsif ( $encryption eq 'md5' ) {
2394 unix_md5_crypt( $self->_password );
2395 } elsif ( $encryption eq 'blowfish' ) {
2396 croak "unknown encryption method $encryption";
2398 croak "unknown encryption method $encryption";
2403 if ( length($self->_password) == 13
2404 || $self->_password =~ /^\$(1|2a?)\$/
2405 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2411 #XXX this could be replaced with Authen::Passphrase stuff
2413 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2414 if ( $encryption eq 'crypt' ) {
2417 $saltset[int(rand(64))].$saltset[int(rand(64))]
2419 } elsif ( $encryption eq 'md5' ) {
2420 unix_md5_crypt( $self->_password );
2421 } elsif ( $encryption eq 'blowfish' ) {
2422 croak "unknown encryption method $encryption";
2424 croak "unknown encryption method $encryption";
2433 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2435 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2436 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2437 "{MD5}5426824942db4253f87a1009fd5d2d4".
2439 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2440 to work the same as the B</crypt_password> method.
2446 #eventually should check a "password-encoding" field
2448 if ( $self->_password_encoding eq 'ldap' ) {
2450 return $self->_password;
2452 } elsif ( $self->_password_encoding eq 'crypt' ) {
2454 if ( length($self->_password) == 13 ) { #crypt
2455 return '{CRYPT}'. $self->_password;
2456 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2458 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2459 # die "Blowfish encryption not supported in this context, svcnum ".
2460 # $self->svcnum. "\n";
2462 warn "encryption method not (yet?) supported in LDAP context";
2463 return '{CRYPT}*'; #unsupported, should not auth
2466 } elsif ( $self->_password_encoding eq 'plain' ) {
2468 return '{PLAIN}'. $self->_password;
2470 #return '{CLEARTEXT}'. $self->_password; #?
2474 if ( length($self->_password) == 13 ) { #crypt
2475 return '{CRYPT}'. $self->_password;
2476 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2478 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2479 warn "Blowfish encryption not supported in this context, svcnum ".
2480 $self->svcnum. "\n";
2483 #are these two necessary anymore?
2484 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2485 return '{SSHA}'. $1;
2486 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2487 return '{NS-MTA-MD5}'. $1;
2490 return '{PLAIN}'. $self->_password;
2492 #return '{CLEARTEXT}'. $self->_password; #?
2494 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2495 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2496 #if ( $encryption eq 'crypt' ) {
2497 # return '{CRYPT}'. crypt(
2499 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2501 #} elsif ( $encryption eq 'md5' ) {
2502 # unix_md5_crypt( $self->_password );
2503 #} elsif ( $encryption eq 'blowfish' ) {
2504 # croak "unknown encryption method $encryption";
2506 # croak "unknown encryption method $encryption";
2514 =item domain_slash_username
2516 Returns $domain/$username/
2520 sub domain_slash_username {
2522 $self->domain. '/'. $self->username. '/';
2525 =item virtual_maildir
2527 Returns $domain/maildirs/$username/
2531 sub virtual_maildir {
2533 $self->domain. '/maildirs/'. $self->username. '/';
2538 =head1 CLASS METHODS
2542 =item search HASHREF
2544 Class method which returns a qsearch hash expression to search for parameters
2545 specified in HASHREF. Valid parameters are
2559 Arrayref of pkgparts
2565 Arrayref of additional WHERE clauses, will be ANDed together.
2576 my ($class, $params) = @_;
2581 if ( $params->{'domain'} ) {
2582 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2583 #preserve previous behavior & bubble up an error if $svc_domain not found?
2584 push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2588 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2589 push @where, "domsvc = $1";
2593 push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2596 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2597 push @where, "agentnum = $1";
2601 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2602 push @where, "custnum = $1";
2606 if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2607 #XXX untaint or sql quote
2609 'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2613 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2614 push @where, "popnum = $1";
2618 if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2619 push @where, "svcpart = $1";
2623 # here is the agent virtualization
2624 #if ($params->{CurrentUser}) {
2626 # qsearchs('access_user', { username => $params->{CurrentUser} });
2628 # if ($access_user) {
2629 # push @where, $access_user->agentnums_sql('table'=>'cust_main');
2631 # push @where, "1=0";
2634 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2635 'table' => 'cust_main',
2636 'null_right' => 'View/link unlinked services',
2640 push @where, @{ $params->{'where'} } if $params->{'where'};
2642 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2644 my $addl_from = ' LEFT JOIN cust_svc USING ( svcnum ) '.
2645 ' LEFT JOIN part_svc USING ( svcpart ) '.
2646 ' LEFT JOIN cust_pkg USING ( pkgnum ) '.
2647 ' LEFT JOIN cust_main USING ( custnum ) ';
2649 my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2650 #if ( keys %svc_acct ) {
2651 # $count_query .= ' WHERE '.
2652 # join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2658 'table' => 'svc_acct',
2659 'hashref' => {}, # \%svc_acct,
2660 'select' => join(', ',
2663 'cust_main.custnum',
2664 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2666 'addl_from' => $addl_from,
2667 'extra_sql' => $extra_sql,
2668 'order_by' => $params->{'order_by'},
2669 'count_query' => $count_query,
2682 This is the FS::svc_acct job-queue-able version. It still uses
2683 FS::Misc::send_email under-the-hood.
2690 eval "use FS::Misc qw(send_email)";
2693 $opt{mimetype} ||= 'text/plain';
2694 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2696 my $error = send_email(
2697 'from' => $opt{from},
2699 'subject' => $opt{subject},
2700 'content-type' => $opt{mimetype},
2701 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2703 die $error if $error;
2706 =item check_and_rebuild_fuzzyfiles
2710 sub check_and_rebuild_fuzzyfiles {
2711 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2712 -e "$dir/svc_acct.username"
2713 or &rebuild_fuzzyfiles;
2716 =item rebuild_fuzzyfiles
2720 sub rebuild_fuzzyfiles {
2722 use Fcntl qw(:flock);
2724 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2728 open(USERNAMELOCK,">>$dir/svc_acct.username")
2729 or die "can't open $dir/svc_acct.username: $!";
2730 flock(USERNAMELOCK,LOCK_EX)
2731 or die "can't lock $dir/svc_acct.username: $!";
2733 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2735 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2736 or die "can't open $dir/svc_acct.username.tmp: $!";
2737 print USERNAMECACHE join("\n", @all_username), "\n";
2738 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2740 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2750 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2751 open(USERNAMECACHE,"<$dir/svc_acct.username")
2752 or die "can't open $dir/svc_acct.username: $!";
2753 my @array = map { chomp; $_; } <USERNAMECACHE>;
2754 close USERNAMECACHE;
2758 =item append_fuzzyfiles USERNAME
2762 sub append_fuzzyfiles {
2763 my $username = shift;
2765 &check_and_rebuild_fuzzyfiles;
2767 use Fcntl qw(:flock);
2769 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2771 open(USERNAME,">>$dir/svc_acct.username")
2772 or die "can't open $dir/svc_acct.username: $!";
2773 flock(USERNAME,LOCK_EX)
2774 or die "can't lock $dir/svc_acct.username: $!";
2776 print USERNAME "$username\n";
2778 flock(USERNAME,LOCK_UN)
2779 or die "can't unlock $dir/svc_acct.username: $!";
2787 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2791 sub radius_usergroup_selector {
2792 my $sel_groups = shift;
2793 my %sel_groups = map { $_=>1 } @$sel_groups;
2795 my $selectname = shift || 'radius_usergroup';
2798 my $sth = $dbh->prepare(
2799 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2800 ) or die $dbh->errstr;
2801 $sth->execute() or die $sth->errstr;
2802 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2806 function ${selectname}_doadd(object) {
2807 var myvalue = object.${selectname}_add.value;
2808 var optionName = new Option(myvalue,myvalue,false,true);
2809 var length = object.$selectname.length;
2810 object.$selectname.options[length] = optionName;
2811 object.${selectname}_add.value = "";
2814 <SELECT MULTIPLE NAME="$selectname">
2817 foreach my $group ( @all_groups ) {
2818 $html .= qq(<OPTION VALUE="$group");
2819 if ( $sel_groups{$group} ) {
2820 $html .= ' SELECTED';
2821 $sel_groups{$group} = 0;
2823 $html .= ">$group</OPTION>\n";
2825 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2826 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2828 $html .= '</SELECT>';
2830 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2831 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2836 =item reached_threshold
2838 Performs some activities when svc_acct thresholds (such as number of seconds
2839 remaining) are reached.
2843 sub reached_threshold {
2846 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2847 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2849 if ( $opt{'op'} eq '+' ){
2850 $svc_acct->setfield( $opt{'column'}.'_threshold',
2851 int($svc_acct->getfield($opt{'column'})
2852 * ( $conf->exists('svc_acct-usage_threshold')
2853 ? $conf->config('svc_acct-usage_threshold')/100
2858 my $error = $svc_acct->replace;
2859 die $error if $error;
2860 }elsif ( $opt{'op'} eq '-' ){
2862 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2863 return '' if ($threshold eq '' );
2865 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2866 my $error = $svc_acct->replace;
2867 die $error if $error; # email next time, i guess
2869 if ( $warning_template ) {
2870 eval "use FS::Misc qw(send_email)";
2873 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2874 my $cust_main = $cust_pkg->cust_main;
2876 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2877 $cust_main->invoicing_list,
2878 ($opt{'to'} ? $opt{'to'} : ())
2881 my $mimetype = $warning_mimetype;
2882 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2884 my $body = $warning_template->fill_in( HASH => {
2885 'custnum' => $cust_main->custnum,
2886 'username' => $svc_acct->username,
2887 'password' => $svc_acct->_password,
2888 'first' => $cust_main->first,
2889 'last' => $cust_main->getfield('last'),
2890 'pkg' => $cust_pkg->part_pkg->pkg,
2891 'column' => $opt{'column'},
2892 'amount' => $opt{'column'} =~/bytes/
2893 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2894 : $svc_acct->getfield($opt{'column'}),
2895 'threshold' => $opt{'column'} =~/bytes/
2896 ? FS::UI::bytecount::display_bytecount($threshold)
2901 my $error = send_email(
2902 'from' => $warning_from,
2904 'subject' => $warning_subject,
2905 'content-type' => $mimetype,
2906 'body' => [ map "$_\n", split("\n", $body) ],
2908 die $error if $error;
2911 die "unknown op: " . $opt{'op'};
2919 The $recref stuff in sub check should be cleaned up.
2921 The suspend, unsuspend and cancel methods update the database, but not the
2922 current object. This is probably a bug as it's unexpected and
2925 radius_usergroup_selector? putting web ui components in here? they should
2926 probably live somewhere else...
2928 insertion of RADIUS group stuff in insert could be done with child_objects now
2929 (would probably clean up export of them too)
2931 _op_usage and set_usage bypass the history... maybe they shouldn't
2935 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2936 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2937 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2938 L<freeside-queued>), L<FS::svc_acct_pop>,
2939 schema.html from the base documentation.
2943 =item domain_select_hash %OPTIONS
2945 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2946 may at present purchase.
2948 Currently available options are: I<pkgnum> I<svcpart>
2952 sub domain_select_hash {
2953 my ($self, %options) = @_;
2959 $part_svc = $self->part_svc;
2960 $cust_pkg = $self->cust_svc->cust_pkg
2964 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2965 if $options{'svcpart'};
2967 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2968 if $options{'pkgnum'};
2970 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2971 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2972 %domains = map { $_->svcnum => $_->domain }
2973 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2974 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2975 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2976 %domains = map { $_->svcnum => $_->domain }
2977 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2978 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2979 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2981 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2984 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2985 my $svc_domain = qsearchs('svc_domain',
2986 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2987 if ( $svc_domain ) {
2988 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2990 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2991 $part_svc->part_svc_column('domsvc')->columnvalue;