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 )
1951 my $error = $self->_op_overlimit($action);
1953 $dbh->rollback if $oldAutoCommit;
1959 if ( $conf->exists("svc_acct-usage_$action")
1960 && &{$op2condition{$op}}($self, $column, $amount) ) {
1961 #my $error = $self->$action();
1962 my $error = $self->cust_svc->cust_pkg->$action();
1963 # $error ||= $self->overlimit($action);
1965 $dbh->rollback if $oldAutoCommit;
1966 return "Error ${action}ing: $error";
1970 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1971 my $wqueue = new FS::queue {
1972 'svcnum' => $self->svcnum,
1973 'job' => 'FS::svc_acct::reached_threshold',
1978 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1982 my $error = $wqueue->insert(
1983 'svcnum' => $self->svcnum,
1985 'column' => $column,
1989 $dbh->rollback if $oldAutoCommit;
1990 return "Error queuing threshold activity: $error";
1994 warn "$me update successful; committing\n"
1996 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2002 my( $self, $action ) = @_;
2004 local $SIG{HUP} = 'IGNORE';
2005 local $SIG{INT} = 'IGNORE';
2006 local $SIG{QUIT} = 'IGNORE';
2007 local $SIG{TERM} = 'IGNORE';
2008 local $SIG{TSTP} = 'IGNORE';
2009 local $SIG{PIPE} = 'IGNORE';
2011 my $oldAutoCommit = $FS::UID::AutoCommit;
2012 local $FS::UID::AutoCommit = 0;
2015 my $cust_pkg = $self->cust_svc->cust_pkg;
2017 my $agent_overlimit =
2019 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2022 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2024 my $groups = $agent_overlimit || $part_export->option('overlimit_groups');
2025 next unless $groups;
2027 my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2029 my $other = new FS::svc_acct $self->hashref;
2030 $other->usergroup( $gref );
2033 if ($action eq 'suspend') {
2036 } else { # $action eq 'unsuspend'
2041 my $error = $part_export->export_replace($new, $old)
2042 || $self->overlimit($action);
2045 $dbh->rollback if $oldAutoCommit;
2046 return "Error replacing radius groups: $error";
2051 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2057 my( $self, $valueref, %options ) = @_;
2059 warn "$me set_usage called for svcnum ". $self->svcnum.
2060 ' ('. $self->email. "): ".
2061 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2064 local $SIG{HUP} = 'IGNORE';
2065 local $SIG{INT} = 'IGNORE';
2066 local $SIG{QUIT} = 'IGNORE';
2067 local $SIG{TERM} = 'IGNORE';
2068 local $SIG{TSTP} = 'IGNORE';
2069 local $SIG{PIPE} = 'IGNORE';
2071 local $FS::svc_Common::noexport_hack = 1;
2072 my $oldAutoCommit = $FS::UID::AutoCommit;
2073 local $FS::UID::AutoCommit = 0;
2078 if ( $options{null} ) {
2079 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2080 qw( seconds upbytes downbytes totalbytes )
2083 foreach my $field (keys %$valueref){
2084 $reset = 1 if $valueref->{$field};
2085 $self->setfield($field, $valueref->{$field});
2086 $self->setfield( $field.'_threshold',
2087 int($self->getfield($field)
2088 * ( $conf->exists('svc_acct-usage_threshold')
2089 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2094 $handyhash{$field} = $self->getfield($field);
2095 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2097 #my $error = $self->replace; #NO! we avoid the call to ->check for
2098 #die $error if $error; #services not explicity changed via the UI
2100 my $sql = "UPDATE svc_acct SET " .
2101 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
2102 " WHERE svcnum = ". $self->svcnum;
2107 if (scalar(keys %handyhash)) {
2108 my $sth = $dbh->prepare( $sql )
2109 or die "Error preparing $sql: ". $dbh->errstr;
2110 my $rv = $sth->execute();
2111 die "Error executing $sql: ". $sth->errstr
2112 unless defined($rv);
2113 die "Can't update usage for svcnum ". $self->svcnum
2117 #$self->snapshot; #not necessary, we retain the old values
2118 #create an object with the updated usage values
2119 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2121 my $error = $new->replace($self);
2123 $dbh->rollback if $oldAutoCommit;
2124 return "Error replacing: $error";
2131 $error = $self->_op_overlimit('unsuspend')
2132 if $self->overlimit;;
2134 $error ||= $self->cust_svc->cust_pkg->unsuspend
2135 if $conf->exists("svc_acct-usage_unsuspend");
2138 $dbh->rollback if $oldAutoCommit;
2139 return "Error unsuspending: $error";
2144 warn "$me update successful; committing\n"
2146 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2152 =item recharge HASHREF
2154 Increments usage columns by the amount specified in HASHREF as
2155 column=>amount pairs.
2160 my ($self, $vhash) = @_;
2163 warn "[$me] recharge called on $self: ". Dumper($self).
2164 "\nwith vhash: ". Dumper($vhash);
2167 my $oldAutoCommit = $FS::UID::AutoCommit;
2168 local $FS::UID::AutoCommit = 0;
2172 foreach my $column (keys %$vhash){
2173 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2177 $dbh->rollback if $oldAutoCommit;
2179 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2184 =item is_rechargeable
2186 Returns true if this svc_account can be "recharged" and false otherwise.
2190 sub is_rechargable {
2192 $self->seconds ne ''
2193 || $self->upbytes ne ''
2194 || $self->downbytes ne ''
2195 || $self->totalbytes ne '';
2198 =item seconds_since TIMESTAMP
2200 Returns the number of seconds this account has been online since TIMESTAMP,
2201 according to the session monitor (see L<FS::Session>).
2203 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2204 L<Time::Local> and L<Date::Parse> for conversion functions.
2208 #note: POD here, implementation in FS::cust_svc
2211 $self->cust_svc->seconds_since(@_);
2214 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2216 Returns the numbers of seconds this account has been online between
2217 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2218 external SQL radacct table, specified via sqlradius export. Sessions which
2219 started in the specified range but are still open are counted from session
2220 start to the end of the range (unless they are over 1 day old, in which case
2221 they are presumed missing their stop record and not counted). Also, sessions
2222 which end in the range but started earlier are counted from the start of the
2223 range to session end. Finally, sessions which start before the range but end
2224 after are counted for the entire range.
2226 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2227 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2232 #note: POD here, implementation in FS::cust_svc
2233 sub seconds_since_sqlradacct {
2235 $self->cust_svc->seconds_since_sqlradacct(@_);
2238 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2240 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2241 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2242 TIMESTAMP_END (exclusive).
2244 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2245 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2250 #note: POD here, implementation in FS::cust_svc
2251 sub attribute_since_sqlradacct {
2253 $self->cust_svc->attribute_since_sqlradacct(@_);
2256 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2258 Returns an array of hash references of this customers login history for the
2259 given time range. (document this better)
2263 sub get_session_history {
2265 $self->cust_svc->get_session_history(@_);
2268 =item last_login_text
2270 Returns text describing the time of last login.
2274 sub last_login_text {
2276 $self->last_login ? ctime($self->last_login) : 'unknown';
2279 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2284 my($self, $start, $end, %opt ) = @_;
2286 my $did = $self->username; #yup
2288 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2290 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2292 #SELECT $for_update * FROM cdr
2293 # WHERE calldate >= $start #need a conversion
2294 # AND calldate < $end #ditto
2295 # AND ( charged_party = "$did"
2296 # OR charged_party = "$prefix$did" #if length($prefix);
2297 # OR ( ( charged_party IS NULL OR charged_party = '' )
2299 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2302 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2305 if ( length($prefix) ) {
2307 " AND ( charged_party = '$did'
2308 OR charged_party = '$prefix$did'
2309 OR ( ( charged_party IS NULL OR charged_party = '' )
2311 ( src = '$did' OR src = '$prefix$did' )
2317 " AND ( charged_party = '$did'
2318 OR ( ( charged_party IS NULL OR charged_party = '' )
2328 'select' => "$for_update *",
2331 #( freesidestatus IS NULL OR freesidestatus = '' )
2332 'freesidestatus' => '',
2334 'extra_sql' => $charged_or_src,
2342 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2348 if ( $self->usergroup ) {
2349 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2350 unless ref($self->usergroup) eq 'ARRAY';
2351 #when provisioning records, export callback runs in svc_Common.pm before
2352 #radius_usergroup records can be inserted...
2353 @{$self->usergroup};
2355 map { $_->groupname }
2356 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2360 =item clone_suspended
2362 Constructor used by FS::part_export::_export_suspend fallback. Document
2367 sub clone_suspended {
2369 my %hash = $self->hash;
2370 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2371 new FS::svc_acct \%hash;
2374 =item clone_kludge_unsuspend
2376 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2381 sub clone_kludge_unsuspend {
2383 my %hash = $self->hash;
2384 $hash{_password} = '';
2385 new FS::svc_acct \%hash;
2388 =item check_password
2390 Checks the supplied password against the (possibly encrypted) password in the
2391 database. Returns true for a successful authentication, false for no match.
2393 Currently supported encryptions are: classic DES crypt() and MD5
2397 sub check_password {
2398 my($self, $check_password) = @_;
2400 #remove old-style SUSPENDED kludge, they should be allowed to login to
2401 #self-service and pay up
2402 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2404 if ( $self->_password_encoding eq 'ldap' ) {
2406 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2407 return $auth->match($check_password);
2409 } elsif ( $self->_password_encoding eq 'crypt' ) {
2411 my $auth = from_crypt Authen::Passphrase $self->_password;
2412 return $auth->match($check_password);
2414 } elsif ( $self->_password_encoding eq 'plain' ) {
2416 return $check_password eq $password;
2420 #XXX this could be replaced with Authen::Passphrase stuff
2422 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2424 } elsif ( length($password) < 13 ) { #plaintext
2425 $check_password eq $password;
2426 } elsif ( length($password) == 13 ) { #traditional DES crypt
2427 crypt($check_password, $password) eq $password;
2428 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2429 unix_md5_crypt($check_password, $password) eq $password;
2430 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2431 warn "Can't check password: Blowfish encryption not yet supported, ".
2432 "svcnum ". $self->svcnum. "\n";
2435 warn "Can't check password: Unrecognized encryption for svcnum ".
2436 $self->svcnum. "\n";
2444 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2446 Returns an encrypted password, either by passing through an encrypted password
2447 in the database or by encrypting a plaintext password from the database.
2449 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2450 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2451 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2452 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2453 encryption type is only used if the password is not already encrypted in the
2458 sub crypt_password {
2461 if ( $self->_password_encoding eq 'ldap' ) {
2463 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2466 #XXX this could be replaced with Authen::Passphrase stuff
2468 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2469 if ( $encryption eq 'crypt' ) {
2472 $saltset[int(rand(64))].$saltset[int(rand(64))]
2474 } elsif ( $encryption eq 'md5' ) {
2475 unix_md5_crypt( $self->_password );
2476 } elsif ( $encryption eq 'blowfish' ) {
2477 croak "unknown encryption method $encryption";
2479 croak "unknown encryption method $encryption";
2482 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2486 } elsif ( $self->_password_encoding eq 'crypt' ) {
2488 return $self->_password;
2490 } elsif ( $self->_password_encoding eq 'plain' ) {
2492 #XXX this could be replaced with Authen::Passphrase stuff
2494 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2495 if ( $encryption eq 'crypt' ) {
2498 $saltset[int(rand(64))].$saltset[int(rand(64))]
2500 } elsif ( $encryption eq 'md5' ) {
2501 unix_md5_crypt( $self->_password );
2502 } elsif ( $encryption eq 'blowfish' ) {
2503 croak "unknown encryption method $encryption";
2505 croak "unknown encryption method $encryption";
2510 if ( length($self->_password) == 13
2511 || $self->_password =~ /^\$(1|2a?)\$/
2512 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2518 #XXX this could be replaced with Authen::Passphrase stuff
2520 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2521 if ( $encryption eq 'crypt' ) {
2524 $saltset[int(rand(64))].$saltset[int(rand(64))]
2526 } elsif ( $encryption eq 'md5' ) {
2527 unix_md5_crypt( $self->_password );
2528 } elsif ( $encryption eq 'blowfish' ) {
2529 croak "unknown encryption method $encryption";
2531 croak "unknown encryption method $encryption";
2540 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2542 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2543 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2544 "{MD5}5426824942db4253f87a1009fd5d2d4".
2546 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2547 to work the same as the B</crypt_password> method.
2553 #eventually should check a "password-encoding" field
2555 if ( $self->_password_encoding eq 'ldap' ) {
2557 return $self->_password;
2559 } elsif ( $self->_password_encoding eq 'crypt' ) {
2561 if ( length($self->_password) == 13 ) { #crypt
2562 return '{CRYPT}'. $self->_password;
2563 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2565 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2566 # die "Blowfish encryption not supported in this context, svcnum ".
2567 # $self->svcnum. "\n";
2569 warn "encryption method not (yet?) supported in LDAP context";
2570 return '{CRYPT}*'; #unsupported, should not auth
2573 } elsif ( $self->_password_encoding eq 'plain' ) {
2575 return '{PLAIN}'. $self->_password;
2577 #return '{CLEARTEXT}'. $self->_password; #?
2581 if ( length($self->_password) == 13 ) { #crypt
2582 return '{CRYPT}'. $self->_password;
2583 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2585 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2586 warn "Blowfish encryption not supported in this context, svcnum ".
2587 $self->svcnum. "\n";
2590 #are these two necessary anymore?
2591 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2592 return '{SSHA}'. $1;
2593 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2594 return '{NS-MTA-MD5}'. $1;
2597 return '{PLAIN}'. $self->_password;
2599 #return '{CLEARTEXT}'. $self->_password; #?
2601 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2602 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2603 #if ( $encryption eq 'crypt' ) {
2604 # return '{CRYPT}'. crypt(
2606 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2608 #} elsif ( $encryption eq 'md5' ) {
2609 # unix_md5_crypt( $self->_password );
2610 #} elsif ( $encryption eq 'blowfish' ) {
2611 # croak "unknown encryption method $encryption";
2613 # croak "unknown encryption method $encryption";
2621 =item domain_slash_username
2623 Returns $domain/$username/
2627 sub domain_slash_username {
2629 $self->domain. '/'. $self->username. '/';
2632 =item virtual_maildir
2634 Returns $domain/maildirs/$username/
2638 sub virtual_maildir {
2640 $self->domain. '/maildirs/'. $self->username. '/';
2645 =head1 CLASS METHODS
2649 =item search HASHREF
2651 Class method which returns a qsearch hash expression to search for parameters
2652 specified in HASHREF. Valid parameters are
2666 Arrayref of pkgparts
2672 Arrayref of additional WHERE clauses, will be ANDed together.
2683 my ($class, $params) = @_;
2688 if ( $params->{'domain'} ) {
2689 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2690 #preserve previous behavior & bubble up an error if $svc_domain not found?
2691 push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2695 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2696 push @where, "domsvc = $1";
2700 push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2703 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2704 push @where, "agentnum = $1";
2708 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2709 push @where, "custnum = $1";
2713 if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2714 #XXX untaint or sql quote
2716 'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2720 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2721 push @where, "popnum = $1";
2725 if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2726 push @where, "svcpart = $1";
2730 # here is the agent virtualization
2731 #if ($params->{CurrentUser}) {
2733 # qsearchs('access_user', { username => $params->{CurrentUser} });
2735 # if ($access_user) {
2736 # push @where, $access_user->agentnums_sql('table'=>'cust_main');
2738 # push @where, "1=0";
2741 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2742 'table' => 'cust_main',
2743 'null_right' => 'View/link unlinked services',
2747 push @where, @{ $params->{'where'} } if $params->{'where'};
2749 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2751 my $addl_from = ' LEFT JOIN cust_svc USING ( svcnum ) '.
2752 ' LEFT JOIN part_svc USING ( svcpart ) '.
2753 ' LEFT JOIN cust_pkg USING ( pkgnum ) '.
2754 ' LEFT JOIN cust_main USING ( custnum ) ';
2756 my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2757 #if ( keys %svc_acct ) {
2758 # $count_query .= ' WHERE '.
2759 # join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2765 'table' => 'svc_acct',
2766 'hashref' => {}, # \%svc_acct,
2767 'select' => join(', ',
2770 'cust_main.custnum',
2771 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2773 'addl_from' => $addl_from,
2774 'extra_sql' => $extra_sql,
2775 'order_by' => $params->{'order_by'},
2776 'count_query' => $count_query,
2789 This is the FS::svc_acct job-queue-able version. It still uses
2790 FS::Misc::send_email under-the-hood.
2797 eval "use FS::Misc qw(send_email)";
2800 $opt{mimetype} ||= 'text/plain';
2801 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2803 my $error = send_email(
2804 'from' => $opt{from},
2806 'subject' => $opt{subject},
2807 'content-type' => $opt{mimetype},
2808 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2810 die $error if $error;
2813 =item check_and_rebuild_fuzzyfiles
2817 sub check_and_rebuild_fuzzyfiles {
2818 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2819 -e "$dir/svc_acct.username"
2820 or &rebuild_fuzzyfiles;
2823 =item rebuild_fuzzyfiles
2827 sub rebuild_fuzzyfiles {
2829 use Fcntl qw(:flock);
2831 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2835 open(USERNAMELOCK,">>$dir/svc_acct.username")
2836 or die "can't open $dir/svc_acct.username: $!";
2837 flock(USERNAMELOCK,LOCK_EX)
2838 or die "can't lock $dir/svc_acct.username: $!";
2840 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2842 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2843 or die "can't open $dir/svc_acct.username.tmp: $!";
2844 print USERNAMECACHE join("\n", @all_username), "\n";
2845 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2847 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2857 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2858 open(USERNAMECACHE,"<$dir/svc_acct.username")
2859 or die "can't open $dir/svc_acct.username: $!";
2860 my @array = map { chomp; $_; } <USERNAMECACHE>;
2861 close USERNAMECACHE;
2865 =item append_fuzzyfiles USERNAME
2869 sub append_fuzzyfiles {
2870 my $username = shift;
2872 &check_and_rebuild_fuzzyfiles;
2874 use Fcntl qw(:flock);
2876 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2878 open(USERNAME,">>$dir/svc_acct.username")
2879 or die "can't open $dir/svc_acct.username: $!";
2880 flock(USERNAME,LOCK_EX)
2881 or die "can't lock $dir/svc_acct.username: $!";
2883 print USERNAME "$username\n";
2885 flock(USERNAME,LOCK_UN)
2886 or die "can't unlock $dir/svc_acct.username: $!";
2894 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2898 sub radius_usergroup_selector {
2899 my $sel_groups = shift;
2900 my %sel_groups = map { $_=>1 } @$sel_groups;
2902 my $selectname = shift || 'radius_usergroup';
2905 my $sth = $dbh->prepare(
2906 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2907 ) or die $dbh->errstr;
2908 $sth->execute() or die $sth->errstr;
2909 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2913 function ${selectname}_doadd(object) {
2914 var myvalue = object.${selectname}_add.value;
2915 var optionName = new Option(myvalue,myvalue,false,true);
2916 var length = object.$selectname.length;
2917 object.$selectname.options[length] = optionName;
2918 object.${selectname}_add.value = "";
2921 <SELECT MULTIPLE NAME="$selectname">
2924 foreach my $group ( @all_groups ) {
2925 $html .= qq(<OPTION VALUE="$group");
2926 if ( $sel_groups{$group} ) {
2927 $html .= ' SELECTED';
2928 $sel_groups{$group} = 0;
2930 $html .= ">$group</OPTION>\n";
2932 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2933 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2935 $html .= '</SELECT>';
2937 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2938 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2943 =item reached_threshold
2945 Performs some activities when svc_acct thresholds (such as number of seconds
2946 remaining) are reached.
2950 sub reached_threshold {
2953 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2954 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2956 if ( $opt{'op'} eq '+' ){
2957 $svc_acct->setfield( $opt{'column'}.'_threshold',
2958 int($svc_acct->getfield($opt{'column'})
2959 * ( $conf->exists('svc_acct-usage_threshold')
2960 ? $conf->config('svc_acct-usage_threshold')/100
2965 my $error = $svc_acct->replace;
2966 die $error if $error;
2967 }elsif ( $opt{'op'} eq '-' ){
2969 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2970 return '' if ($threshold eq '' );
2972 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2973 my $error = $svc_acct->replace;
2974 die $error if $error; # email next time, i guess
2976 if ( $warning_template ) {
2977 eval "use FS::Misc qw(send_email)";
2980 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2981 my $cust_main = $cust_pkg->cust_main;
2983 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2984 $cust_main->invoicing_list,
2985 ($opt{'to'} ? $opt{'to'} : ())
2988 my $mimetype = $warning_mimetype;
2989 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2991 my $body = $warning_template->fill_in( HASH => {
2992 'custnum' => $cust_main->custnum,
2993 'username' => $svc_acct->username,
2994 'password' => $svc_acct->_password,
2995 'first' => $cust_main->first,
2996 'last' => $cust_main->getfield('last'),
2997 'pkg' => $cust_pkg->part_pkg->pkg,
2998 'column' => $opt{'column'},
2999 'amount' => $opt{'column'} =~/bytes/
3000 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3001 : $svc_acct->getfield($opt{'column'}),
3002 'threshold' => $opt{'column'} =~/bytes/
3003 ? FS::UI::bytecount::display_bytecount($threshold)
3008 my $error = send_email(
3009 'from' => $warning_from,
3011 'subject' => $warning_subject,
3012 'content-type' => $mimetype,
3013 'body' => [ map "$_\n", split("\n", $body) ],
3015 die $error if $error;
3018 die "unknown op: " . $opt{'op'};
3026 The $recref stuff in sub check should be cleaned up.
3028 The suspend, unsuspend and cancel methods update the database, but not the
3029 current object. This is probably a bug as it's unexpected and
3032 radius_usergroup_selector? putting web ui components in here? they should
3033 probably live somewhere else...
3035 insertion of RADIUS group stuff in insert could be done with child_objects now
3036 (would probably clean up export of them too)
3038 _op_usage and set_usage bypass the history... maybe they shouldn't
3042 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3043 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3044 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3045 L<freeside-queued>), L<FS::svc_acct_pop>,
3046 schema.html from the base documentation.
3050 =item domain_select_hash %OPTIONS
3052 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
3053 may at present purchase.
3055 Currently available options are: I<pkgnum> I<svcpart>
3059 sub domain_select_hash {
3060 my ($self, %options) = @_;
3066 $part_svc = $self->part_svc;
3067 $cust_pkg = $self->cust_svc->cust_pkg
3071 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
3072 if $options{'svcpart'};
3074 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
3075 if $options{'pkgnum'};
3077 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
3078 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
3079 %domains = map { $_->svcnum => $_->domain }
3080 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
3081 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
3082 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
3083 %domains = map { $_->svcnum => $_->domain }
3084 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
3085 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
3086 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
3088 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
3091 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
3092 my $svc_domain = qsearchs('svc_domain',
3093 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
3094 if ( $svc_domain ) {
3095 $domains{$svc_domain->svcnum} = $svc_domain->domain;
3097 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
3098 $part_svc->part_svc_column('domsvc')->columnvalue;