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;
23 use Digest::SHA1 'sha1_base64';
24 use Digest::MD5 'md5_base64';
27 use Authen::Passphrase;
28 use FS::UID qw( datasrc driver_name );
30 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
31 use FS::Msgcat qw(gettext);
32 use FS::UI::bytecount;
39 use FS::cust_main_invoice;
43 use FS::radius_usergroup;
50 @ISA = qw( FS::svc_Common );
53 $me = '[FS::svc_acct]';
55 #ask FS::UID to run this stuff for us later
56 FS::UID->install_callback( sub {
58 $dir_prefix = $conf->config('home');
59 @shells = $conf->config('shells');
60 $usernamemin = $conf->config('usernamemin') || 2;
61 $usernamemax = $conf->config('usernamemax');
62 $passwordmin = $conf->config('passwordmin'); # || 6;
64 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
67 $passwordmax = $conf->config('passwordmax') || 8;
68 $username_letter = $conf->exists('username-letter');
69 $username_letterfirst = $conf->exists('username-letterfirst');
70 $username_noperiod = $conf->exists('username-noperiod');
71 $username_nounderscore = $conf->exists('username-nounderscore');
72 $username_nodash = $conf->exists('username-nodash');
73 $username_uppercase = $conf->exists('username-uppercase');
74 $username_ampersand = $conf->exists('username-ampersand');
75 $username_percent = $conf->exists('username-percent');
76 $username_colon = $conf->exists('username-colon');
77 $password_noampersand = $conf->exists('password-noexclamation');
78 $password_noexclamation = $conf->exists('password-noexclamation');
79 $dirhash = $conf->config('dirhash') || 0;
80 if ( $conf->exists('warning_email') ) {
81 $warning_template = new Text::Template (
83 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
84 ) or warn "can't create warning email template: $Text::Template::ERROR";
85 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
86 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
87 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
88 $warning_cc = $conf->config('warning_email-cc');
90 $warning_template = '';
92 $warning_subject = '';
93 $warning_mimetype = '';
96 $smtpmachine = $conf->config('smtpmachine');
97 $radius_password = $conf->config('radius-password') || 'Password';
98 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
99 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
103 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
104 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
108 my ( $hashref, $cache ) = @_;
109 if ( $hashref->{'svc_acct_svcnum'} ) {
110 $self->{'_domsvc'} = FS::svc_domain->new( {
111 'svcnum' => $hashref->{'domsvc'},
112 'domain' => $hashref->{'svc_acct_domain'},
113 'catchall' => $hashref->{'svc_acct_catchall'},
120 FS::svc_acct - Object methods for svc_acct records
126 $record = new FS::svc_acct \%hash;
127 $record = new FS::svc_acct { 'column' => 'value' };
129 $error = $record->insert;
131 $error = $new_record->replace($old_record);
133 $error = $record->delete;
135 $error = $record->check;
137 $error = $record->suspend;
139 $error = $record->unsuspend;
141 $error = $record->cancel;
143 %hash = $record->radius;
145 %hash = $record->radius_reply;
147 %hash = $record->radius_check;
149 $domain = $record->domain;
151 $svc_domain = $record->svc_domain;
153 $email = $record->email;
155 $seconds_since = $record->seconds_since($timestamp);
159 An FS::svc_acct object represents an account. FS::svc_acct inherits from
160 FS::svc_Common. The following fields are currently supported:
164 =item svcnum - primary key (assigned automatcially for new accounts)
168 =item _password - generated if blank
170 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
172 =item sec_phrase - security phrase
174 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
182 =item dir - set automatically if blank (and uid is not)
186 =item quota - (unimplementd)
188 =item slipip - IP address
198 =item domsvc - svcnum from svc_domain
200 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
202 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
212 Creates a new account. To add the account to the database, see L<"insert">.
219 'longname_plural' => 'Access accounts and mailboxes',
220 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
221 'display_weight' => 10,
222 'cancel_weight' => 50,
224 'dir' => 'Home directory',
227 def_info => 'set to fixed and blank for no UIDs',
230 'slipip' => 'IP address',
231 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
233 label => 'Access number',
235 select_table => 'svc_acct_pop',
236 select_key => 'popnum',
237 select_label => 'city',
243 disable_default => 1,
250 disable_inventory => 1,
253 '_password' => 'Password',
256 def_info => 'when blank, defaults to UID',
261 def_info => 'set to blank for no shell tracking',
263 #select_list => [ $conf->config('shells') ],
264 select_list => [ $conf ? $conf->config('shells') : () ],
265 disable_inventory => 1,
268 'finger' => 'Real name', # (GECOS)',
272 select_table => 'svc_domain',
273 select_key => 'svcnum',
274 select_label => 'domain',
275 disable_inventory => 1,
279 label => 'RADIUS groups',
280 type => 'radius_usergroup_selector',
281 disable_inventory => 1,
284 'seconds' => { label => 'Seconds',
285 label_sort => 'with Time Remaining',
287 disable_inventory => 1,
289 disable_part_svc_column => 1,
291 'upbytes' => { label => 'Upload',
293 disable_inventory => 1,
295 'format' => \&FS::UI::bytecount::display_bytecount,
296 'parse' => \&FS::UI::bytecount::parse_bytecount,
297 disable_part_svc_column => 1,
299 'downbytes' => { label => 'Download',
301 disable_inventory => 1,
303 'format' => \&FS::UI::bytecount::display_bytecount,
304 'parse' => \&FS::UI::bytecount::parse_bytecount,
305 disable_part_svc_column => 1,
307 'totalbytes'=> { label => 'Total up and download',
309 disable_inventory => 1,
311 'format' => \&FS::UI::bytecount::display_bytecount,
312 'parse' => \&FS::UI::bytecount::parse_bytecount,
313 disable_part_svc_column => 1,
315 'seconds_threshold' => { label => 'Seconds threshold',
317 disable_inventory => 1,
319 disable_part_svc_column => 1,
321 'upbytes_threshold' => { label => 'Upload threshold',
323 disable_inventory => 1,
325 'format' => \&FS::UI::bytecount::display_bytecount,
326 'parse' => \&FS::UI::bytecount::parse_bytecount,
327 disable_part_svc_column => 1,
329 'downbytes_threshold' => { label => 'Download threshold',
331 disable_inventory => 1,
333 'format' => \&FS::UI::bytecount::display_bytecount,
334 'parse' => \&FS::UI::bytecount::parse_bytecount,
335 disable_part_svc_column => 1,
337 'totalbytes_threshold'=> { label => 'Total up and download threshold',
339 disable_inventory => 1,
341 'format' => \&FS::UI::bytecount::display_bytecount,
342 'parse' => \&FS::UI::bytecount::parse_bytecount,
343 disable_part_svc_column => 1,
346 label => 'Last login',
350 label => 'Last logout',
357 sub table { 'svc_acct'; }
359 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
363 #false laziness with edit/svc_acct.cgi
365 my( $self, $groups ) = @_;
366 if ( ref($groups) eq 'ARRAY' ) {
368 } elsif ( length($groups) ) {
369 [ split(/\s*,\s*/, $groups) ];
378 shift->_lastlog('in', @_);
382 shift->_lastlog('out', @_);
386 my( $self, $op, $time ) = @_;
388 if ( defined($time) ) {
389 warn "$me last_log$op called on svcnum ". $self->svcnum.
390 ' ('. $self->email. "): $time\n"
395 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
399 my $sth = $dbh->prepare( $sql )
400 or die "Error preparing $sql: ". $dbh->errstr;
401 my $rv = $sth->execute($time, $self->svcnum);
402 die "Error executing $sql: ". $sth->errstr
404 die "Can't update last_log$op for svcnum". $self->svcnum
407 $self->{'Hash'}->{"last_log$op"} = $time;
409 $self->getfield("last_log$op");
413 =item search_sql STRING
415 Class method which returns an SQL fragment to search for the given string.
420 my( $class, $string ) = @_;
421 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
422 my( $username, $domain ) = ( $1, $2 );
423 my $q_username = dbh->quote($username);
424 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
426 "svc_acct.username = $q_username AND ( ".
427 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
432 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
434 $class->search_sql_field('slipip', $string ).
436 $class->search_sql_field('username', $string ).
440 $class->search_sql_field('username', $string).
442 ? 'OR '. $class->search_sql_field('svcnum', $string)
449 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
451 Returns the "username@domain" string for this account.
453 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
463 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
465 Returns a longer string label for this acccount ("Real Name <username@domain>"
466 if available, or "username@domain").
468 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
475 my $label = $self->label(@_);
476 my $finger = $self->finger;
477 return $label unless $finger =~ /\S/;
478 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
479 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
483 =item insert [ , OPTION => VALUE ... ]
485 Adds this account to the database. If there is an error, returns the error,
486 otherwise returns false.
488 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
489 defined. An FS::cust_svc record will be created and inserted.
491 The additional field I<usergroup> can optionally be defined; if so it should
492 contain an arrayref of group names. See L<FS::radius_usergroup>.
494 The additional field I<child_objects> can optionally be defined; if so it
495 should contain an arrayref of FS::tablename objects. They will have their
496 svcnum fields set and will be inserted after this record, but before any
497 exports are run. Each element of the array can also optionally be a
498 two-element array reference containing the child object and the name of an
499 alternate field to be filled in with the newly-inserted svcnum, for example
500 C<[ $svc_forward, 'srcsvc' ]>
502 Currently available options are: I<depend_jobnum>
504 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
505 jobnums), all provisioning jobs will have a dependancy on the supplied
506 jobnum(s) (they will not run until the specific job(s) complete(s)).
508 (TODOC: L<FS::queue> and L<freeside-queued>)
510 (TODOC: new exports!)
519 warn "[$me] insert called on $self: ". Dumper($self).
520 "\nwith options: ". Dumper(%options);
523 local $SIG{HUP} = 'IGNORE';
524 local $SIG{INT} = 'IGNORE';
525 local $SIG{QUIT} = 'IGNORE';
526 local $SIG{TERM} = 'IGNORE';
527 local $SIG{TSTP} = 'IGNORE';
528 local $SIG{PIPE} = 'IGNORE';
530 my $oldAutoCommit = $FS::UID::AutoCommit;
531 local $FS::UID::AutoCommit = 0;
535 my $error = $self->SUPER::insert(
536 'jobnums' => \@jobnums,
537 'child_objects' => $self->child_objects,
541 $dbh->rollback if $oldAutoCommit;
545 if ( $self->usergroup ) {
546 foreach my $groupname ( @{$self->usergroup} ) {
547 my $radius_usergroup = new FS::radius_usergroup ( {
548 svcnum => $self->svcnum,
549 groupname => $groupname,
551 my $error = $radius_usergroup->insert;
553 $dbh->rollback if $oldAutoCommit;
559 unless ( $skip_fuzzyfiles ) {
560 $error = $self->queue_fuzzyfiles_update;
562 $dbh->rollback if $oldAutoCommit;
563 return "updating fuzzy search cache: $error";
567 my $cust_pkg = $self->cust_svc->cust_pkg;
570 my $cust_main = $cust_pkg->cust_main;
571 my $agentnum = $cust_main->agentnum;
573 if ( $conf->exists('emailinvoiceautoalways')
574 || $conf->exists('emailinvoiceauto')
575 && ! $cust_main->invoicing_list_emailonly
577 my @invoicing_list = $cust_main->invoicing_list;
578 push @invoicing_list, $self->email;
579 $cust_main->invoicing_list(\@invoicing_list);
583 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
584 = ('','','','','','');
586 if ( $conf->exists('welcome_email', $agentnum) ) {
587 $welcome_template = new Text::Template (
589 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
590 ) or warn "can't create welcome email template: $Text::Template::ERROR";
591 $welcome_from = $conf->config('welcome_email-from', $agentnum);
592 # || 'your-isp-is-dum'
593 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
595 $welcome_subject_template = new Text::Template (
597 SOURCE => $welcome_subject,
598 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
599 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
602 if ( $welcome_template && $cust_pkg ) {
603 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
607 'custnum' => $self->custnum,
608 'username' => $self->username,
609 'password' => $self->_password,
610 'first' => $cust_main->first,
611 'last' => $cust_main->getfield('last'),
612 'pkg' => $cust_pkg->part_pkg->pkg,
614 my $wqueue = new FS::queue {
615 'svcnum' => $self->svcnum,
616 'job' => 'FS::svc_acct::send_email'
618 my $error = $wqueue->insert(
620 'from' => $welcome_from,
621 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
622 'mimetype' => $welcome_mimetype,
623 'body' => $welcome_template->fill_in( HASH => \%hash, ),
626 $dbh->rollback if $oldAutoCommit;
627 return "error queuing welcome email: $error";
630 if ( $options{'depend_jobnum'} ) {
631 warn "$me depend_jobnum found; adding to welcome email dependancies"
633 if ( ref($options{'depend_jobnum'}) ) {
634 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
635 "to welcome email dependancies"
637 push @jobnums, @{ $options{'depend_jobnum'} };
639 warn "$me adding job $options{'depend_jobnum'} ".
640 "to welcome email dependancies"
642 push @jobnums, $options{'depend_jobnum'};
646 foreach my $jobnum ( @jobnums ) {
647 my $error = $wqueue->depend_insert($jobnum);
649 $dbh->rollback if $oldAutoCommit;
650 return "error queuing welcome email job dependancy: $error";
660 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
664 # set usage fields and thresholds if unset but set in a package def
665 sub preinsert_hook_first {
668 return '' unless $self->pkgnum;
670 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
671 my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
672 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
674 my %values = $part_pkg->usage_valuehash;
675 my $multiplier = $conf->exists('svc_acct-usage_threshold')
676 ? 1 - $conf->config('svc_acct-usage_threshold')/100
677 : 0.20; #doesn't matter
679 foreach ( keys %values ) {
680 next if $self->getfield($_);
681 $self->setfield( $_, $values{$_} );
682 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
683 if $conf->exists('svc_acct-usage_threshold');
691 Deletes this account from the database. If there is an error, returns the
692 error, otherwise returns false.
694 The corresponding FS::cust_svc record will be deleted as well.
696 (TODOC: new exports!)
703 return "can't delete system account" if $self->_check_system;
705 return "Can't delete an account which is a (svc_forward) source!"
706 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
708 return "Can't delete an account which is a (svc_forward) destination!"
709 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
711 return "Can't delete an account with (svc_www) web service!"
712 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
714 # what about records in session ? (they should refer to history table)
716 local $SIG{HUP} = 'IGNORE';
717 local $SIG{INT} = 'IGNORE';
718 local $SIG{QUIT} = 'IGNORE';
719 local $SIG{TERM} = 'IGNORE';
720 local $SIG{TSTP} = 'IGNORE';
721 local $SIG{PIPE} = 'IGNORE';
723 my $oldAutoCommit = $FS::UID::AutoCommit;
724 local $FS::UID::AutoCommit = 0;
727 foreach my $cust_main_invoice (
728 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
730 unless ( defined($cust_main_invoice) ) {
731 warn "WARNING: something's wrong with qsearch";
734 my %hash = $cust_main_invoice->hash;
735 $hash{'dest'} = $self->email;
736 my $new = new FS::cust_main_invoice \%hash;
737 my $error = $new->replace($cust_main_invoice);
739 $dbh->rollback if $oldAutoCommit;
744 foreach my $svc_domain (
745 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
747 my %hash = new FS::svc_domain->hash;
748 $hash{'catchall'} = '';
749 my $new = new FS::svc_domain \%hash;
750 my $error = $new->replace($svc_domain);
752 $dbh->rollback if $oldAutoCommit;
757 my $error = $self->SUPER::delete;
759 $dbh->rollback if $oldAutoCommit;
763 foreach my $radius_usergroup (
764 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
766 my $error = $radius_usergroup->delete;
768 $dbh->rollback if $oldAutoCommit;
773 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
777 =item replace OLD_RECORD
779 Replaces OLD_RECORD with this one in the database. If there is an error,
780 returns the error, otherwise returns false.
782 The additional field I<usergroup> can optionally be defined; if so it should
783 contain an arrayref of group names. See L<FS::radius_usergroup>.
791 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
795 warn "$me replacing $old with $new\n" if $DEBUG;
799 return "can't modify system account" if $old->_check_system;
802 #no warnings 'numeric'; #alas, a 5.006-ism
805 foreach my $xid (qw( uid gid )) {
807 return "Can't change $xid!"
808 if ! $conf->exists("svc_acct-edit_$xid")
809 && $old->$xid() != $new->$xid()
810 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
815 #change homdir when we change username
816 $new->setfield('dir', '') if $old->username ne $new->username;
818 local $SIG{HUP} = 'IGNORE';
819 local $SIG{INT} = 'IGNORE';
820 local $SIG{QUIT} = 'IGNORE';
821 local $SIG{TERM} = 'IGNORE';
822 local $SIG{TSTP} = 'IGNORE';
823 local $SIG{PIPE} = 'IGNORE';
825 my $oldAutoCommit = $FS::UID::AutoCommit;
826 local $FS::UID::AutoCommit = 0;
829 # redundant, but so $new->usergroup gets set
830 $error = $new->check;
831 return $error if $error;
833 $old->usergroup( [ $old->radius_groups ] );
835 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
836 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
838 if ( $new->usergroup ) {
839 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
840 my @newgroups = @{$new->usergroup};
841 foreach my $oldgroup ( @{$old->usergroup} ) {
842 if ( grep { $oldgroup eq $_ } @newgroups ) {
843 @newgroups = grep { $oldgroup ne $_ } @newgroups;
846 my $radius_usergroup = qsearchs('radius_usergroup', {
847 svcnum => $old->svcnum,
848 groupname => $oldgroup,
850 my $error = $radius_usergroup->delete;
852 $dbh->rollback if $oldAutoCommit;
853 return "error deleting radius_usergroup $oldgroup: $error";
857 foreach my $newgroup ( @newgroups ) {
858 my $radius_usergroup = new FS::radius_usergroup ( {
859 svcnum => $new->svcnum,
860 groupname => $newgroup,
862 my $error = $radius_usergroup->insert;
864 $dbh->rollback if $oldAutoCommit;
865 return "error adding radius_usergroup $newgroup: $error";
871 $error = $new->SUPER::replace($old, @_);
873 $dbh->rollback if $oldAutoCommit;
874 return $error if $error;
877 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
878 $error = $new->queue_fuzzyfiles_update;
880 $dbh->rollback if $oldAutoCommit;
881 return "updating fuzzy search cache: $error";
885 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
889 =item queue_fuzzyfiles_update
891 Used by insert & replace to update the fuzzy search cache
895 sub queue_fuzzyfiles_update {
898 local $SIG{HUP} = 'IGNORE';
899 local $SIG{INT} = 'IGNORE';
900 local $SIG{QUIT} = 'IGNORE';
901 local $SIG{TERM} = 'IGNORE';
902 local $SIG{TSTP} = 'IGNORE';
903 local $SIG{PIPE} = 'IGNORE';
905 my $oldAutoCommit = $FS::UID::AutoCommit;
906 local $FS::UID::AutoCommit = 0;
909 my $queue = new FS::queue {
910 'svcnum' => $self->svcnum,
911 'job' => 'FS::svc_acct::append_fuzzyfiles'
913 my $error = $queue->insert($self->username);
915 $dbh->rollback if $oldAutoCommit;
916 return "queueing job (transaction rolled back): $error";
919 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
927 Suspends this account by calling export-specific suspend hooks. If there is
928 an error, returns the error, otherwise returns false.
930 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
936 return "can't suspend system account" if $self->_check_system;
937 $self->SUPER::suspend(@_);
942 Unsuspends this account by by calling export-specific suspend hooks. If there
943 is an error, returns the error, otherwise returns false.
945 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
951 my %hash = $self->hash;
952 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
953 $hash{_password} = $1;
954 my $new = new FS::svc_acct ( \%hash );
955 my $error = $new->replace($self);
956 return $error if $error;
959 $self->SUPER::unsuspend(@_);
964 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
966 If the B<auto_unset_catchall> configuration option is set, this method will
967 automatically remove any references to the canceled service in the catchall
968 field of svc_domain. This allows packages that contain both a svc_domain and
969 its catchall svc_acct to be canceled in one step.
974 # Only one thing to do at this level
976 foreach my $svc_domain (
977 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
978 if($conf->exists('auto_unset_catchall')) {
979 my %hash = $svc_domain->hash;
980 $hash{catchall} = '';
981 my $new = new FS::svc_domain ( \%hash );
982 my $error = $new->replace($svc_domain);
983 return $error if $error;
985 return "cannot unprovision svc_acct #".$self->svcnum.
986 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
990 $self->SUPER::cancel(@_);
996 Checks all fields to make sure this is a valid service. If there is an error,
997 returns the error, otherwise returns false. Called by the insert and replace
1000 Sets any fixed values; see L<FS::part_svc>.
1007 my($recref) = $self->hashref;
1009 my $x = $self->setfixed( $self->_fieldhandlers );
1010 return $x unless ref($x);
1013 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1015 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1018 my $error = $self->ut_numbern('svcnum')
1019 #|| $self->ut_number('domsvc')
1020 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1021 || $self->ut_textn('sec_phrase')
1022 || $self->ut_snumbern('seconds')
1023 || $self->ut_snumbern('upbytes')
1024 || $self->ut_snumbern('downbytes')
1025 || $self->ut_snumbern('totalbytes')
1026 || $self->ut_enum( '_password_encoding',
1027 [ '', qw( plain crypt ldap ) ]
1030 return $error if $error;
1033 local $username_letter = $username_letter;
1034 if ($self->svcnum) {
1035 my $cust_svc = $self->cust_svc
1036 or return "no cust_svc record found for svcnum ". $self->svcnum;
1037 my $cust_pkg = $cust_svc->cust_pkg;
1039 if ($self->pkgnum) {
1040 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1044 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1047 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1048 if ( $username_uppercase ) {
1049 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1050 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1051 $recref->{username} = $1;
1053 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1054 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1055 $recref->{username} = $1;
1058 if ( $username_letterfirst ) {
1059 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1060 } elsif ( $username_letter ) {
1061 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1063 if ( $username_noperiod ) {
1064 $recref->{username} =~ /\./ and return gettext('illegal_username');
1066 if ( $username_nounderscore ) {
1067 $recref->{username} =~ /_/ and return gettext('illegal_username');
1069 if ( $username_nodash ) {
1070 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1072 unless ( $username_ampersand ) {
1073 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1075 unless ( $username_percent ) {
1076 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1078 unless ( $username_colon ) {
1079 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1082 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1083 $recref->{popnum} = $1;
1084 return "Unknown popnum" unless
1085 ! $recref->{popnum} ||
1086 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1088 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1090 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1091 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1093 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1094 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1095 #not all systems use gid=uid
1096 #you can set a fixed gid in part_svc
1098 return "Only root can have uid 0"
1099 if $recref->{uid} == 0
1100 && $recref->{username} !~ /^(root|toor|smtp)$/;
1102 unless ( $recref->{username} eq 'sync' ) {
1103 if ( grep $_ eq $recref->{shell}, @shells ) {
1104 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1106 return "Illegal shell \`". $self->shell. "\'; ".
1107 "shells configuration value contains: @shells";
1110 $recref->{shell} = '/bin/sync';
1114 $recref->{gid} ne '' ?
1115 return "Can't have gid without uid" : ( $recref->{gid}='' );
1116 #$recref->{dir} ne '' ?
1117 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1118 $recref->{shell} ne '' ?
1119 return "Can't have shell without uid" : ( $recref->{shell}='' );
1122 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1124 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1125 or return "Illegal directory: ". $recref->{dir};
1126 $recref->{dir} = $1;
1127 return "Illegal directory"
1128 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1129 return "Illegal directory"
1130 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1131 unless ( $recref->{dir} ) {
1132 $recref->{dir} = $dir_prefix . '/';
1133 if ( $dirhash > 0 ) {
1134 for my $h ( 1 .. $dirhash ) {
1135 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1137 } elsif ( $dirhash < 0 ) {
1138 for my $h ( reverse $dirhash .. -1 ) {
1139 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1142 $recref->{dir} .= $recref->{username};
1148 # $error = $self->ut_textn('finger');
1149 # return $error if $error;
1150 if ( $self->getfield('finger') eq '' ) {
1151 my $cust_pkg = $self->svcnum
1152 ? $self->cust_svc->cust_pkg
1153 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1155 my $cust_main = $cust_pkg->cust_main;
1156 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1159 $self->getfield('finger') =~
1160 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1161 or return "Illegal finger: ". $self->getfield('finger');
1162 $self->setfield('finger', $1);
1164 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1165 $recref->{quota} = $1;
1167 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1168 if ( $recref->{slipip} eq '' ) {
1169 $recref->{slipip} = '';
1170 } elsif ( $recref->{slipip} eq '0e0' ) {
1171 $recref->{slipip} = '0e0';
1173 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1174 or return "Illegal slipip: ". $self->slipip;
1175 $recref->{slipip} = $1;
1180 #arbitrary RADIUS stuff; allow ut_textn for now
1181 foreach ( grep /^radius_/, fields('svc_acct') ) {
1182 $self->ut_textn($_);
1185 # First, if _password is blank, generate one and set default encoding.
1186 if ( ! $recref->{_password} ) {
1187 $self->set_password('');
1189 # But if there's a _password but no encoding, assume it's plaintext and
1190 # set it to default encoding.
1191 elsif ( ! $recref->{_password_encoding} ) {
1192 $self->set_password($recref->{_password});
1195 # Next, check _password to ensure compliance with the encoding.
1196 if ( $recref->{_password_encoding} eq 'ldap' ) {
1198 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1199 $recref->{_password} = uc($1).$2;
1201 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1204 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1206 if ( $recref->{_password} =~
1207 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1208 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1211 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1214 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1217 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1218 # Password randomization is now in set_password.
1219 # Strip whitespace characters, check length requirements, etc.
1220 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1221 $recref->{_password} = $1;
1223 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1224 FS::Msgcat::_gettext('illegal_password_characters').
1225 ": ". $recref->{_password};
1228 if ( $password_noampersand ) {
1229 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1231 if ( $password_noexclamation ) {
1232 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1235 elsif ( $recref->{_password_encoding} eq 'legacy' ) {
1236 # this happens when set_password fails
1237 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1238 FS::Msgcat::_gettext('illegal_password_characters').
1239 ": ". $recref->{_password};
1241 $self->SUPER::check;
1246 sub _password_encryption {
1248 my $encoding = lc($self->_password_encoding);
1249 return if !$encoding;
1250 return 'plain' if $encoding eq 'plain';
1251 if($encoding eq 'crypt') {
1252 my $pass = $self->_password;
1253 $pass =~ s/^\*SUSPENDED\* //;
1255 return 'md5' if $pass =~ /^\$1\$/;
1256 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1257 return 'des' if length($pass) == 13;
1260 if($encoding eq 'ldap') {
1261 uc($self->_password) =~ /^\{([\w-]+)\}/;
1262 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1263 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1264 return 'md5' if $1 eq 'MD5';
1265 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1272 sub get_cleartext_password {
1274 if($self->_password_encryption eq 'plain') {
1275 if($self->_password_encoding eq 'ldap') {
1276 $self->_password =~ /\{\w+\}(.*)$/;
1280 return $self->_password;
1289 Set the cleartext password for the account. If _password_encoding is set, the
1290 new password will be encoded according to the existing method (including
1291 encryption mode, if it can be determined). Otherwise,
1292 config('default-password-encoding') is used.
1294 If no password is supplied (or a zero-length password when minimum password length
1295 is >0), one will be generated randomly.
1302 my ($encoding, $encryption);
1305 if($self->_password_encoding) {
1306 $encoding = $self->_password_encoding;
1307 # identify existing encryption method, try to use it.
1308 $encryption = $self->_password_encryption;
1310 # use the system default
1316 # set encoding to system default
1317 ($encoding, $encryption) = split(/-/, lc($conf->config('default-password-encoding')));
1318 $encoding ||= 'legacy';
1319 $self->_password_encoding($encoding);
1322 if($encoding eq 'legacy') {
1323 # The legacy behavior from check():
1324 # If the password is blank, randomize it and set encoding to 'plain'.
1325 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1326 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1327 $self->_password_encoding('plain');
1330 # Prefix + valid-length password
1331 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1333 $self->_password_encoding('plain');
1335 # Prefix + crypt string
1336 elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1338 $self->_password_encoding('crypt');
1340 # Various disabled crypt passwords
1341 elsif ( $pass eq '*' or
1344 $self->_password_encoding('crypt');
1347 # do nothing; check() will recognize this as an error
1351 elsif($encoding eq 'crypt') {
1352 if($encryption eq 'md5') {
1353 $pass = unix_md5_crypt($pass);
1355 elsif($encryption eq 'des') {
1356 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1359 elsif($encoding eq 'ldap') {
1360 if($encryption eq 'md5') {
1361 $pass = md5_base64($pass);
1363 elsif($encryption eq 'sha1') {
1364 $pass = sha1_base64($pass);
1366 elsif($encryption eq 'crypt') {
1367 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1369 # else $encryption eq 'plain', do nothing
1370 $pass = '{'.uc($encryption).'}'.$pass;
1372 # else encoding eq 'plain'
1374 $self->_password($pass);
1380 Internal function to check the username against the list of system usernames
1381 from the I<system_usernames> configuration value. Returns true if the username
1382 is listed on the system username list.
1388 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1389 $conf->config('system_usernames')
1393 =item _check_duplicate
1395 Internal method to check for duplicates usernames, username@domain pairs and
1398 If the I<global_unique-username> configuration value is set to B<username> or
1399 B<username@domain>, enforces global username or username@domain uniqueness.
1401 In all cases, check for duplicate uids and usernames or username@domain pairs
1402 per export and with identical I<svcpart> values.
1406 sub _check_duplicate {
1409 my $global_unique = $conf->config('global_unique-username') || 'none';
1410 return '' if $global_unique eq 'disabled';
1414 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1415 unless ( $part_svc ) {
1416 return 'unknown svcpart '. $self->svcpart;
1419 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1420 qsearch( 'svc_acct', { 'username' => $self->username } );
1421 return gettext('username_in_use')
1422 if $global_unique eq 'username' && @dup_user;
1424 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1425 qsearch( 'svc_acct', { 'username' => $self->username,
1426 'domsvc' => $self->domsvc } );
1427 return gettext('username_in_use')
1428 if $global_unique eq 'username@domain' && @dup_userdomain;
1431 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1432 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1433 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1434 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1439 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1440 my $exports = FS::part_export::export_info('svc_acct');
1441 my %conflict_user_svcpart;
1442 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1444 foreach my $part_export ( $part_svc->part_export ) {
1446 #this will catch to the same exact export
1447 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1449 #this will catch to exports w/same exporthost+type ???
1450 #my @other_part_export = qsearch('part_export', {
1451 # 'machine' => $part_export->machine,
1452 # 'exporttype' => $part_export->exporttype,
1454 #foreach my $other_part_export ( @other_part_export ) {
1455 # push @svcparts, map { $_->svcpart }
1456 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1459 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1460 #silly kludge to avoid uninitialized value errors
1461 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1462 ? $exports->{$part_export->exporttype}{'nodomain'}
1464 if ( $nodomain =~ /^Y/i ) {
1465 $conflict_user_svcpart{$_} = $part_export->exportnum
1468 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1473 foreach my $dup_user ( @dup_user ) {
1474 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1475 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1476 return "duplicate username ". $self->username.
1477 ": conflicts with svcnum ". $dup_user->svcnum.
1478 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1482 foreach my $dup_userdomain ( @dup_userdomain ) {
1483 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1484 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1485 return "duplicate username\@domain ". $self->email.
1486 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1487 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1491 foreach my $dup_uid ( @dup_uid ) {
1492 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1493 if ( exists($conflict_user_svcpart{$dup_svcpart})
1494 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1495 return "duplicate uid ". $self->uid.
1496 ": conflicts with svcnum ". $dup_uid->svcnum.
1498 ( $conflict_user_svcpart{$dup_svcpart}
1499 || $conflict_userdomain_svcpart{$dup_svcpart} );
1511 Depriciated, use radius_reply instead.
1516 carp "FS::svc_acct::radius depriciated, use radius_reply";
1517 $_[0]->radius_reply;
1522 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1523 reply attributes of this record.
1525 Note that this is now the preferred method for reading RADIUS attributes -
1526 accessing the columns directly is discouraged, as the column names are
1527 expected to change in the future.
1534 return %{ $self->{'radius_reply'} }
1535 if exists $self->{'radius_reply'};
1540 my($column, $attrib) = ($1, $2);
1541 #$attrib =~ s/_/\-/g;
1542 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1543 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1545 if ( $self->slipip && $self->slipip ne '0e0' ) {
1546 $reply{$radius_ip} = $self->slipip;
1549 if ( $self->seconds !~ /^$/ ) {
1550 $reply{'Session-Timeout'} = $self->seconds;
1553 if ( $conf->exists('radius-chillispot-max') ) {
1554 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1556 #hmm. just because sqlradius.pm says so?
1563 foreach my $what (qw( input output total )) {
1564 my $is = $whatis{$what}.'bytes';
1565 if ( $self->$is() =~ /\d/ ) {
1566 my $big = new Math::BigInt $self->$is();
1567 $big = new Math::BigInt '0' if $big->is_neg();
1568 my $att = "Chillispot-Max-\u$what";
1569 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1570 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1581 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1582 check attributes of this record.
1584 Note that this is now the preferred method for reading RADIUS attributes -
1585 accessing the columns directly is discouraged, as the column names are
1586 expected to change in the future.
1593 return %{ $self->{'radius_check'} }
1594 if exists $self->{'radius_check'};
1599 my($column, $attrib) = ($1, $2);
1600 #$attrib =~ s/_/\-/g;
1601 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1602 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1605 my($pw_attrib, $password) = $self->radius_password;
1606 $check{$pw_attrib} = $password;
1608 my $cust_svc = $self->cust_svc;
1610 my $cust_pkg = $cust_svc->cust_pkg;
1611 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1612 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1615 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1616 "; can't set Expiration\n"
1624 =item radius_password
1626 Returns a key/value pair containing the RADIUS attribute name and value
1631 sub radius_password {
1634 my($pw_attrib, $password);
1635 if ( $self->_password_encoding eq 'ldap' ) {
1637 $pw_attrib = 'Password-With-Header';
1638 $password = $self->_password;
1640 } elsif ( $self->_password_encoding eq 'crypt' ) {
1642 $pw_attrib = 'Crypt-Password';
1643 $password = $self->_password;
1645 } elsif ( $self->_password_encoding eq 'plain' ) {
1647 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1648 $password = $self->_password;
1652 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1653 $password = $self->_password;
1657 ($pw_attrib, $password);
1663 This method instructs the object to "snapshot" or freeze RADIUS check and
1664 reply attributes to the current values.
1668 #bah, my english is too broken this morning
1669 #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
1670 #the FS::cust_pkg's replace method to trigger the correct export updates when
1671 #package dates change)
1676 $self->{$_} = { $self->$_() }
1677 foreach qw( radius_reply radius_check );
1681 =item forget_snapshot
1683 This methos instructs the object to forget any previously snapshotted
1684 RADIUS check and reply attributes.
1688 sub forget_snapshot {
1692 foreach qw( radius_reply radius_check );
1696 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1698 Returns the domain associated with this account.
1700 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1707 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1708 my $svc_domain = $self->svc_domain(@_)
1709 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1710 $svc_domain->domain;
1715 Returns the FS::svc_domain record for this account's domain (see
1720 # FS::h_svc_acct has a history-aware svc_domain override
1725 ? $self->{'_domsvc'}
1726 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1731 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1735 #inherited from svc_Common
1737 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1739 Returns an email address associated with the account.
1741 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1748 $self->username. '@'. $self->domain(@_);
1753 Returns an array of FS::acct_snarf records associated with the account.
1754 If the acct_snarf table does not exist or there are no associated records,
1755 an empty list is returned
1761 return () unless dbdef->table('acct_snarf');
1762 eval "use FS::acct_snarf;";
1764 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1767 =item decrement_upbytes OCTETS
1769 Decrements the I<upbytes> field of this record by the given amount. If there
1770 is an error, returns the error, otherwise returns false.
1774 sub decrement_upbytes {
1775 shift->_op_usage('-', 'upbytes', @_);
1778 =item increment_upbytes OCTETS
1780 Increments the I<upbytes> field of this record by the given amount. If there
1781 is an error, returns the error, otherwise returns false.
1785 sub increment_upbytes {
1786 shift->_op_usage('+', 'upbytes', @_);
1789 =item decrement_downbytes OCTETS
1791 Decrements the I<downbytes> field of this record by the given amount. If there
1792 is an error, returns the error, otherwise returns false.
1796 sub decrement_downbytes {
1797 shift->_op_usage('-', 'downbytes', @_);
1800 =item increment_downbytes OCTETS
1802 Increments the I<downbytes> field of this record by the given amount. If there
1803 is an error, returns the error, otherwise returns false.
1807 sub increment_downbytes {
1808 shift->_op_usage('+', 'downbytes', @_);
1811 =item decrement_totalbytes OCTETS
1813 Decrements the I<totalbytes> field of this record by the given amount. If there
1814 is an error, returns the error, otherwise returns false.
1818 sub decrement_totalbytes {
1819 shift->_op_usage('-', 'totalbytes', @_);
1822 =item increment_totalbytes OCTETS
1824 Increments the I<totalbytes> field of this record by the given amount. If there
1825 is an error, returns the error, otherwise returns false.
1829 sub increment_totalbytes {
1830 shift->_op_usage('+', 'totalbytes', @_);
1833 =item decrement_seconds SECONDS
1835 Decrements the I<seconds> field of this record by the given amount. If there
1836 is an error, returns the error, otherwise returns false.
1840 sub decrement_seconds {
1841 shift->_op_usage('-', 'seconds', @_);
1844 =item increment_seconds SECONDS
1846 Increments the I<seconds> field of this record by the given amount. If there
1847 is an error, returns the error, otherwise returns false.
1851 sub increment_seconds {
1852 shift->_op_usage('+', 'seconds', @_);
1860 my %op2condition = (
1861 '-' => sub { my($self, $column, $amount) = @_;
1862 $self->$column - $amount <= 0;
1864 '+' => sub { my($self, $column, $amount) = @_;
1865 ($self->$column || 0) + $amount > 0;
1868 my %op2warncondition = (
1869 '-' => sub { my($self, $column, $amount) = @_;
1870 my $threshold = $column . '_threshold';
1871 $self->$column - $amount <= $self->$threshold + 0;
1873 '+' => sub { my($self, $column, $amount) = @_;
1874 ($self->$column || 0) + $amount > 0;
1879 my( $self, $op, $column, $amount ) = @_;
1881 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1882 ' ('. $self->email. "): $op $amount\n"
1885 return '' unless $amount;
1887 local $SIG{HUP} = 'IGNORE';
1888 local $SIG{INT} = 'IGNORE';
1889 local $SIG{QUIT} = 'IGNORE';
1890 local $SIG{TERM} = 'IGNORE';
1891 local $SIG{TSTP} = 'IGNORE';
1892 local $SIG{PIPE} = 'IGNORE';
1894 my $oldAutoCommit = $FS::UID::AutoCommit;
1895 local $FS::UID::AutoCommit = 0;
1898 my $sql = "UPDATE svc_acct SET $column = ".
1899 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1900 " $op ? WHERE svcnum = ?";
1904 my $sth = $dbh->prepare( $sql )
1905 or die "Error preparing $sql: ". $dbh->errstr;
1906 my $rv = $sth->execute($amount, $self->svcnum);
1907 die "Error executing $sql: ". $sth->errstr
1908 unless defined($rv);
1909 die "Can't update $column for svcnum". $self->svcnum
1912 #$self->snapshot; #not necessary, we retain the old values
1913 #create an object with the updated usage values
1914 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1916 my $error = $new->replace($self);
1918 $dbh->rollback if $oldAutoCommit;
1919 return "Error replacing: $error";
1922 #overlimit_action eq 'cancel' handling
1923 my $cust_pkg = $self->cust_svc->cust_pkg;
1925 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1926 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1930 my $error = $cust_pkg->cancel; #XXX should have a reason
1932 $dbh->rollback if $oldAutoCommit;
1933 return "Error cancelling: $error";
1936 #nothing else is relevant if we're cancelling, so commit & return success
1937 warn "$me update successful; committing\n"
1939 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1944 my $action = $op2action{$op};
1946 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1947 ( $action eq 'suspend' && !$self->overlimit
1948 || $action eq 'unsuspend' && $self->overlimit )
1950 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1951 if ($part_export->option('overlimit_groups')) {
1953 my $other = new FS::svc_acct $self->hashref;
1954 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1955 ($self, $part_export->option('overlimit_groups'));
1956 $other->usergroup( $groups );
1957 if ($action eq 'suspend'){
1958 $new = $other; $old = $self;
1960 $new = $self; $old = $other;
1962 my $error = $part_export->export_replace($new, $old);
1963 $error ||= $self->overlimit($action);
1965 $dbh->rollback if $oldAutoCommit;
1966 return "Error replacing radius groups in export, ${op}: $error";
1972 if ( $conf->exists("svc_acct-usage_$action")
1973 && &{$op2condition{$op}}($self, $column, $amount) ) {
1974 #my $error = $self->$action();
1975 my $error = $self->cust_svc->cust_pkg->$action();
1976 # $error ||= $self->overlimit($action);
1978 $dbh->rollback if $oldAutoCommit;
1979 return "Error ${action}ing: $error";
1983 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1984 my $wqueue = new FS::queue {
1985 'svcnum' => $self->svcnum,
1986 'job' => 'FS::svc_acct::reached_threshold',
1991 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1995 my $error = $wqueue->insert(
1996 'svcnum' => $self->svcnum,
1998 'column' => $column,
2002 $dbh->rollback if $oldAutoCommit;
2003 return "Error queuing threshold activity: $error";
2007 warn "$me update successful; committing\n"
2009 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2015 my( $self, $valueref, %options ) = @_;
2017 warn "$me set_usage called for svcnum ". $self->svcnum.
2018 ' ('. $self->email. "): ".
2019 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2022 local $SIG{HUP} = 'IGNORE';
2023 local $SIG{INT} = 'IGNORE';
2024 local $SIG{QUIT} = 'IGNORE';
2025 local $SIG{TERM} = 'IGNORE';
2026 local $SIG{TSTP} = 'IGNORE';
2027 local $SIG{PIPE} = 'IGNORE';
2029 local $FS::svc_Common::noexport_hack = 1;
2030 my $oldAutoCommit = $FS::UID::AutoCommit;
2031 local $FS::UID::AutoCommit = 0;
2036 if ( $options{null} ) {
2037 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2038 qw( seconds upbytes downbytes totalbytes )
2041 foreach my $field (keys %$valueref){
2042 $reset = 1 if $valueref->{$field};
2043 $self->setfield($field, $valueref->{$field});
2044 $self->setfield( $field.'_threshold',
2045 int($self->getfield($field)
2046 * ( $conf->exists('svc_acct-usage_threshold')
2047 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2052 $handyhash{$field} = $self->getfield($field);
2053 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2055 #my $error = $self->replace; #NO! we avoid the call to ->check for
2056 #die $error if $error; #services not explicity changed via the UI
2058 my $sql = "UPDATE svc_acct SET " .
2059 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
2060 " WHERE svcnum = ". $self->svcnum;
2065 if (scalar(keys %handyhash)) {
2066 my $sth = $dbh->prepare( $sql )
2067 or die "Error preparing $sql: ". $dbh->errstr;
2068 my $rv = $sth->execute();
2069 die "Error executing $sql: ". $sth->errstr
2070 unless defined($rv);
2071 die "Can't update usage for svcnum ". $self->svcnum
2075 #$self->snapshot; #not necessary, we retain the old values
2076 #create an object with the updated usage values
2077 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2079 my $error = $new->replace($self);
2081 $dbh->rollback if $oldAutoCommit;
2082 return "Error replacing: $error";
2088 if ($self->overlimit) {
2089 $error = $self->overlimit('unsuspend');
2090 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2091 if ($part_export->option('overlimit_groups')) {
2092 my $old = new FS::svc_acct $self->hashref;
2093 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
2094 ($self, $part_export->option('overlimit_groups'));
2095 $old->usergroup( $groups );
2096 $error ||= $part_export->export_replace($self, $old);
2101 if ( $conf->exists("svc_acct-usage_unsuspend")) {
2102 $error ||= $self->cust_svc->cust_pkg->unsuspend;
2105 $dbh->rollback if $oldAutoCommit;
2106 return "Error unsuspending: $error";
2110 warn "$me update successful; committing\n"
2112 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2118 =item recharge HASHREF
2120 Increments usage columns by the amount specified in HASHREF as
2121 column=>amount pairs.
2126 my ($self, $vhash) = @_;
2129 warn "[$me] recharge called on $self: ". Dumper($self).
2130 "\nwith vhash: ". Dumper($vhash);
2133 my $oldAutoCommit = $FS::UID::AutoCommit;
2134 local $FS::UID::AutoCommit = 0;
2138 foreach my $column (keys %$vhash){
2139 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2143 $dbh->rollback if $oldAutoCommit;
2145 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2150 =item is_rechargeable
2152 Returns true if this svc_account can be "recharged" and false otherwise.
2156 sub is_rechargable {
2158 $self->seconds ne ''
2159 || $self->upbytes ne ''
2160 || $self->downbytes ne ''
2161 || $self->totalbytes ne '';
2164 =item seconds_since TIMESTAMP
2166 Returns the number of seconds this account has been online since TIMESTAMP,
2167 according to the session monitor (see L<FS::Session>).
2169 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2170 L<Time::Local> and L<Date::Parse> for conversion functions.
2174 #note: POD here, implementation in FS::cust_svc
2177 $self->cust_svc->seconds_since(@_);
2180 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2182 Returns the numbers of seconds this account has been online between
2183 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2184 external SQL radacct table, specified via sqlradius export. Sessions which
2185 started in the specified range but are still open are counted from session
2186 start to the end of the range (unless they are over 1 day old, in which case
2187 they are presumed missing their stop record and not counted). Also, sessions
2188 which end in the range but started earlier are counted from the start of the
2189 range to session end. Finally, sessions which start before the range but end
2190 after are counted for the entire range.
2192 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2193 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2198 #note: POD here, implementation in FS::cust_svc
2199 sub seconds_since_sqlradacct {
2201 $self->cust_svc->seconds_since_sqlradacct(@_);
2204 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2206 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2207 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2208 TIMESTAMP_END (exclusive).
2210 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2211 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2216 #note: POD here, implementation in FS::cust_svc
2217 sub attribute_since_sqlradacct {
2219 $self->cust_svc->attribute_since_sqlradacct(@_);
2222 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2224 Returns an array of hash references of this customers login history for the
2225 given time range. (document this better)
2229 sub get_session_history {
2231 $self->cust_svc->get_session_history(@_);
2234 =item last_login_text
2236 Returns text describing the time of last login.
2240 sub last_login_text {
2242 $self->last_login ? ctime($self->last_login) : 'unknown';
2245 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2250 my($self, $start, $end, %opt ) = @_;
2252 my $did = $self->username; #yup
2254 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2256 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2258 #SELECT $for_update * FROM cdr
2259 # WHERE calldate >= $start #need a conversion
2260 # AND calldate < $end #ditto
2261 # AND ( charged_party = "$did"
2262 # OR charged_party = "$prefix$did" #if length($prefix);
2263 # OR ( ( charged_party IS NULL OR charged_party = '' )
2265 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2268 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2271 if ( length($prefix) ) {
2273 " AND ( charged_party = '$did'
2274 OR charged_party = '$prefix$did'
2275 OR ( ( charged_party IS NULL OR charged_party = '' )
2277 ( src = '$did' OR src = '$prefix$did' )
2283 " AND ( charged_party = '$did'
2284 OR ( ( charged_party IS NULL OR charged_party = '' )
2294 'select' => "$for_update *",
2297 #( freesidestatus IS NULL OR freesidestatus = '' )
2298 'freesidestatus' => '',
2300 'extra_sql' => $charged_or_src,
2308 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2314 if ( $self->usergroup ) {
2315 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2316 unless ref($self->usergroup) eq 'ARRAY';
2317 #when provisioning records, export callback runs in svc_Common.pm before
2318 #radius_usergroup records can be inserted...
2319 @{$self->usergroup};
2321 map { $_->groupname }
2322 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2326 =item clone_suspended
2328 Constructor used by FS::part_export::_export_suspend fallback. Document
2333 sub clone_suspended {
2335 my %hash = $self->hash;
2336 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2337 new FS::svc_acct \%hash;
2340 =item clone_kludge_unsuspend
2342 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2347 sub clone_kludge_unsuspend {
2349 my %hash = $self->hash;
2350 $hash{_password} = '';
2351 new FS::svc_acct \%hash;
2354 =item check_password
2356 Checks the supplied password against the (possibly encrypted) password in the
2357 database. Returns true for a successful authentication, false for no match.
2359 Currently supported encryptions are: classic DES crypt() and MD5
2363 sub check_password {
2364 my($self, $check_password) = @_;
2366 #remove old-style SUSPENDED kludge, they should be allowed to login to
2367 #self-service and pay up
2368 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2370 if ( $self->_password_encoding eq 'ldap' ) {
2372 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2373 return $auth->match($check_password);
2375 } elsif ( $self->_password_encoding eq 'crypt' ) {
2377 my $auth = from_crypt Authen::Passphrase $self->_password;
2378 return $auth->match($check_password);
2380 } elsif ( $self->_password_encoding eq 'plain' ) {
2382 return $check_password eq $password;
2386 #XXX this could be replaced with Authen::Passphrase stuff
2388 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2390 } elsif ( length($password) < 13 ) { #plaintext
2391 $check_password eq $password;
2392 } elsif ( length($password) == 13 ) { #traditional DES crypt
2393 crypt($check_password, $password) eq $password;
2394 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2395 unix_md5_crypt($check_password, $password) eq $password;
2396 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2397 warn "Can't check password: Blowfish encryption not yet supported, ".
2398 "svcnum ". $self->svcnum. "\n";
2401 warn "Can't check password: Unrecognized encryption for svcnum ".
2402 $self->svcnum. "\n";
2410 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2412 Returns an encrypted password, either by passing through an encrypted password
2413 in the database or by encrypting a plaintext password from the database.
2415 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2416 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2417 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2418 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2419 encryption type is only used if the password is not already encrypted in the
2424 sub crypt_password {
2427 if ( $self->_password_encoding eq 'ldap' ) {
2429 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2432 #XXX this could be replaced with Authen::Passphrase stuff
2434 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2435 if ( $encryption eq 'crypt' ) {
2438 $saltset[int(rand(64))].$saltset[int(rand(64))]
2440 } elsif ( $encryption eq 'md5' ) {
2441 unix_md5_crypt( $self->_password );
2442 } elsif ( $encryption eq 'blowfish' ) {
2443 croak "unknown encryption method $encryption";
2445 croak "unknown encryption method $encryption";
2448 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2452 } elsif ( $self->_password_encoding eq 'crypt' ) {
2454 return $self->_password;
2456 } elsif ( $self->_password_encoding eq 'plain' ) {
2458 #XXX this could be replaced with Authen::Passphrase stuff
2460 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2461 if ( $encryption eq 'crypt' ) {
2464 $saltset[int(rand(64))].$saltset[int(rand(64))]
2466 } elsif ( $encryption eq 'md5' ) {
2467 unix_md5_crypt( $self->_password );
2468 } elsif ( $encryption eq 'blowfish' ) {
2469 croak "unknown encryption method $encryption";
2471 croak "unknown encryption method $encryption";
2476 if ( length($self->_password) == 13
2477 || $self->_password =~ /^\$(1|2a?)\$/
2478 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2484 #XXX this could be replaced with Authen::Passphrase stuff
2486 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2487 if ( $encryption eq 'crypt' ) {
2490 $saltset[int(rand(64))].$saltset[int(rand(64))]
2492 } elsif ( $encryption eq 'md5' ) {
2493 unix_md5_crypt( $self->_password );
2494 } elsif ( $encryption eq 'blowfish' ) {
2495 croak "unknown encryption method $encryption";
2497 croak "unknown encryption method $encryption";
2506 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2508 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2509 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2510 "{MD5}5426824942db4253f87a1009fd5d2d4".
2512 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2513 to work the same as the B</crypt_password> method.
2519 #eventually should check a "password-encoding" field
2521 if ( $self->_password_encoding eq 'ldap' ) {
2523 return $self->_password;
2525 } elsif ( $self->_password_encoding eq 'crypt' ) {
2527 if ( length($self->_password) == 13 ) { #crypt
2528 return '{CRYPT}'. $self->_password;
2529 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2531 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2532 # die "Blowfish encryption not supported in this context, svcnum ".
2533 # $self->svcnum. "\n";
2535 warn "encryption method not (yet?) supported in LDAP context";
2536 return '{CRYPT}*'; #unsupported, should not auth
2539 } elsif ( $self->_password_encoding eq 'plain' ) {
2541 return '{PLAIN}'. $self->_password;
2543 #return '{CLEARTEXT}'. $self->_password; #?
2547 if ( length($self->_password) == 13 ) { #crypt
2548 return '{CRYPT}'. $self->_password;
2549 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2551 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2552 warn "Blowfish encryption not supported in this context, svcnum ".
2553 $self->svcnum. "\n";
2556 #are these two necessary anymore?
2557 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2558 return '{SSHA}'. $1;
2559 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2560 return '{NS-MTA-MD5}'. $1;
2563 return '{PLAIN}'. $self->_password;
2565 #return '{CLEARTEXT}'. $self->_password; #?
2567 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2568 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2569 #if ( $encryption eq 'crypt' ) {
2570 # return '{CRYPT}'. crypt(
2572 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2574 #} elsif ( $encryption eq 'md5' ) {
2575 # unix_md5_crypt( $self->_password );
2576 #} elsif ( $encryption eq 'blowfish' ) {
2577 # croak "unknown encryption method $encryption";
2579 # croak "unknown encryption method $encryption";
2587 =item domain_slash_username
2589 Returns $domain/$username/
2593 sub domain_slash_username {
2595 $self->domain. '/'. $self->username. '/';
2598 =item virtual_maildir
2600 Returns $domain/maildirs/$username/
2604 sub virtual_maildir {
2606 $self->domain. '/maildirs/'. $self->username. '/';
2611 =head1 CLASS METHODS
2615 =item search HASHREF
2617 Class method which returns a qsearch hash expression to search for parameters
2618 specified in HASHREF. Valid parameters are
2632 Arrayref of pkgparts
2638 Arrayref of additional WHERE clauses, will be ANDed together.
2649 my ($class, $params) = @_;
2654 if ( $params->{'domain'} ) {
2655 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2656 #preserve previous behavior & bubble up an error if $svc_domain not found?
2657 push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2661 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2662 push @where, "domsvc = $1";
2666 push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2669 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2670 push @where, "agentnum = $1";
2674 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2675 push @where, "custnum = $1";
2679 if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2680 #XXX untaint or sql quote
2682 'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2686 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2687 push @where, "popnum = $1";
2691 if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2692 push @where, "svcpart = $1";
2696 # here is the agent virtualization
2697 #if ($params->{CurrentUser}) {
2699 # qsearchs('access_user', { username => $params->{CurrentUser} });
2701 # if ($access_user) {
2702 # push @where, $access_user->agentnums_sql('table'=>'cust_main');
2704 # push @where, "1=0";
2707 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2708 'table' => 'cust_main',
2709 'null_right' => 'View/link unlinked services',
2713 push @where, @{ $params->{'where'} } if $params->{'where'};
2715 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2717 my $addl_from = ' LEFT JOIN cust_svc USING ( svcnum ) '.
2718 ' LEFT JOIN part_svc USING ( svcpart ) '.
2719 ' LEFT JOIN cust_pkg USING ( pkgnum ) '.
2720 ' LEFT JOIN cust_main USING ( custnum ) ';
2722 my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2723 #if ( keys %svc_acct ) {
2724 # $count_query .= ' WHERE '.
2725 # join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2731 'table' => 'svc_acct',
2732 'hashref' => {}, # \%svc_acct,
2733 'select' => join(', ',
2736 'cust_main.custnum',
2737 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2739 'addl_from' => $addl_from,
2740 'extra_sql' => $extra_sql,
2741 'order_by' => $params->{'order_by'},
2742 'count_query' => $count_query,
2755 This is the FS::svc_acct job-queue-able version. It still uses
2756 FS::Misc::send_email under-the-hood.
2763 eval "use FS::Misc qw(send_email)";
2766 $opt{mimetype} ||= 'text/plain';
2767 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2769 my $error = send_email(
2770 'from' => $opt{from},
2772 'subject' => $opt{subject},
2773 'content-type' => $opt{mimetype},
2774 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2776 die $error if $error;
2779 =item check_and_rebuild_fuzzyfiles
2783 sub check_and_rebuild_fuzzyfiles {
2784 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2785 -e "$dir/svc_acct.username"
2786 or &rebuild_fuzzyfiles;
2789 =item rebuild_fuzzyfiles
2793 sub rebuild_fuzzyfiles {
2795 use Fcntl qw(:flock);
2797 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2801 open(USERNAMELOCK,">>$dir/svc_acct.username")
2802 or die "can't open $dir/svc_acct.username: $!";
2803 flock(USERNAMELOCK,LOCK_EX)
2804 or die "can't lock $dir/svc_acct.username: $!";
2806 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2808 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2809 or die "can't open $dir/svc_acct.username.tmp: $!";
2810 print USERNAMECACHE join("\n", @all_username), "\n";
2811 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2813 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2823 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2824 open(USERNAMECACHE,"<$dir/svc_acct.username")
2825 or die "can't open $dir/svc_acct.username: $!";
2826 my @array = map { chomp; $_; } <USERNAMECACHE>;
2827 close USERNAMECACHE;
2831 =item append_fuzzyfiles USERNAME
2835 sub append_fuzzyfiles {
2836 my $username = shift;
2838 &check_and_rebuild_fuzzyfiles;
2840 use Fcntl qw(:flock);
2842 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2844 open(USERNAME,">>$dir/svc_acct.username")
2845 or die "can't open $dir/svc_acct.username: $!";
2846 flock(USERNAME,LOCK_EX)
2847 or die "can't lock $dir/svc_acct.username: $!";
2849 print USERNAME "$username\n";
2851 flock(USERNAME,LOCK_UN)
2852 or die "can't unlock $dir/svc_acct.username: $!";
2860 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2864 sub radius_usergroup_selector {
2865 my $sel_groups = shift;
2866 my %sel_groups = map { $_=>1 } @$sel_groups;
2868 my $selectname = shift || 'radius_usergroup';
2871 my $sth = $dbh->prepare(
2872 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2873 ) or die $dbh->errstr;
2874 $sth->execute() or die $sth->errstr;
2875 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2879 function ${selectname}_doadd(object) {
2880 var myvalue = object.${selectname}_add.value;
2881 var optionName = new Option(myvalue,myvalue,false,true);
2882 var length = object.$selectname.length;
2883 object.$selectname.options[length] = optionName;
2884 object.${selectname}_add.value = "";
2887 <SELECT MULTIPLE NAME="$selectname">
2890 foreach my $group ( @all_groups ) {
2891 $html .= qq(<OPTION VALUE="$group");
2892 if ( $sel_groups{$group} ) {
2893 $html .= ' SELECTED';
2894 $sel_groups{$group} = 0;
2896 $html .= ">$group</OPTION>\n";
2898 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2899 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2901 $html .= '</SELECT>';
2903 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2904 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2909 =item reached_threshold
2911 Performs some activities when svc_acct thresholds (such as number of seconds
2912 remaining) are reached.
2916 sub reached_threshold {
2919 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2920 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2922 if ( $opt{'op'} eq '+' ){
2923 $svc_acct->setfield( $opt{'column'}.'_threshold',
2924 int($svc_acct->getfield($opt{'column'})
2925 * ( $conf->exists('svc_acct-usage_threshold')
2926 ? $conf->config('svc_acct-usage_threshold')/100
2931 my $error = $svc_acct->replace;
2932 die $error if $error;
2933 }elsif ( $opt{'op'} eq '-' ){
2935 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2936 return '' if ($threshold eq '' );
2938 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2939 my $error = $svc_acct->replace;
2940 die $error if $error; # email next time, i guess
2942 if ( $warning_template ) {
2943 eval "use FS::Misc qw(send_email)";
2946 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2947 my $cust_main = $cust_pkg->cust_main;
2949 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2950 $cust_main->invoicing_list,
2951 ($opt{'to'} ? $opt{'to'} : ())
2954 my $mimetype = $warning_mimetype;
2955 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2957 my $body = $warning_template->fill_in( HASH => {
2958 'custnum' => $cust_main->custnum,
2959 'username' => $svc_acct->username,
2960 'password' => $svc_acct->_password,
2961 'first' => $cust_main->first,
2962 'last' => $cust_main->getfield('last'),
2963 'pkg' => $cust_pkg->part_pkg->pkg,
2964 'column' => $opt{'column'},
2965 'amount' => $opt{'column'} =~/bytes/
2966 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2967 : $svc_acct->getfield($opt{'column'}),
2968 'threshold' => $opt{'column'} =~/bytes/
2969 ? FS::UI::bytecount::display_bytecount($threshold)
2974 my $error = send_email(
2975 'from' => $warning_from,
2977 'subject' => $warning_subject,
2978 'content-type' => $mimetype,
2979 'body' => [ map "$_\n", split("\n", $body) ],
2981 die $error if $error;
2984 die "unknown op: " . $opt{'op'};
2992 The $recref stuff in sub check should be cleaned up.
2994 The suspend, unsuspend and cancel methods update the database, but not the
2995 current object. This is probably a bug as it's unexpected and
2998 radius_usergroup_selector? putting web ui components in here? they should
2999 probably live somewhere else...
3001 insertion of RADIUS group stuff in insert could be done with child_objects now
3002 (would probably clean up export of them too)
3004 _op_usage and set_usage bypass the history... maybe they shouldn't
3008 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3009 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3010 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3011 L<freeside-queued>), L<FS::svc_acct_pop>,
3012 schema.html from the base documentation.
3016 =item domain_select_hash %OPTIONS
3018 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
3019 may at present purchase.
3021 Currently available options are: I<pkgnum> I<svcpart>
3025 sub domain_select_hash {
3026 my ($self, %options) = @_;
3032 $part_svc = $self->part_svc;
3033 $cust_pkg = $self->cust_svc->cust_pkg
3037 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
3038 if $options{'svcpart'};
3040 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
3041 if $options{'pkgnum'};
3043 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
3044 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
3045 %domains = map { $_->svcnum => $_->domain }
3046 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
3047 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
3048 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
3049 %domains = map { $_->svcnum => $_->domain }
3050 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
3051 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
3052 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
3054 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
3057 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
3058 my $svc_domain = qsearchs('svc_domain',
3059 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
3060 if ( $svc_domain ) {
3061 $domains{$svc_domain->svcnum} = $svc_domain->domain;
3063 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
3064 $part_svc->part_svc_column('domsvc')->columnvalue;