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 $error = $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 $error = $self->set_password($recref->{_password});
1194 return $error if $error;
1196 # Next, check _password to ensure compliance with the encoding.
1197 if ( $recref->{_password_encoding} eq 'ldap' ) {
1199 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1200 $recref->{_password} = uc($1).$2;
1202 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1205 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1207 if ( $recref->{_password} =~
1208 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1209 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1212 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1215 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1218 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1219 # Password randomization is now in set_password.
1220 # Strip whitespace characters, check length requirements, etc.
1221 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1222 $recref->{_password} = $1;
1224 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1225 FS::Msgcat::_gettext('illegal_password_characters').
1226 ": ". $recref->{_password};
1229 if ( $password_noampersand ) {
1230 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1232 if ( $password_noexclamation ) {
1233 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1237 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1239 $self->SUPER::check;
1244 sub _password_encryption {
1246 my $encoding = lc($self->_password_encoding);
1247 return if !$encoding;
1248 return 'plain' if $encoding eq 'plain';
1249 if($encoding eq 'crypt') {
1250 my $pass = $self->_password;
1251 $pass =~ s/^\*SUSPENDED\* //;
1253 return 'md5' if $pass =~ /^\$1\$/;
1254 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1255 return 'des' if length($pass) == 13;
1258 if($encoding eq 'ldap') {
1259 uc($self->_password) =~ /^\{([\w-]+)\}/;
1260 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1261 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1262 return 'md5' if $1 eq 'MD5';
1263 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1270 sub get_cleartext_password {
1272 if($self->_password_encryption eq 'plain') {
1273 if($self->_password_encoding eq 'ldap') {
1274 $self->_password =~ /\{\w+\}(.*)$/;
1278 return $self->_password;
1287 Set the cleartext password for the account. If _password_encoding is set, the
1288 new password will be encoded according to the existing method (including
1289 encryption mode, if it can be determined). Otherwise,
1290 config('default-password-encoding') is used.
1292 If no password is supplied (or a zero-length password when minimum password length
1293 is >0), one will be generated randomly.
1300 my ($encoding, $encryption);
1301 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1302 FS::Msgcat::_gettext('illegal_password_characters').
1305 if(($passwordmin and length($pass) < $passwordmin) or
1306 ($passwordmax and length($pass) > $passwordmax)) {
1310 if($self->_password_encoding) {
1311 $encoding = $self->_password_encoding;
1312 # identify existing encryption method, try to use it.
1313 $encryption = $self->_password_encryption;
1315 # use the system default
1321 # set encoding to system default
1322 ($encoding, $encryption) = split(/-/, lc($conf->config('default-password-encoding')));
1323 $encoding ||= 'legacy';
1324 $self->_password_encoding($encoding);
1327 if($encoding eq 'legacy') {
1328 # The legacy behavior from check():
1329 # If the password is blank, randomize it and set encoding to 'plain'.
1330 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1331 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1332 $self->_password_encoding('plain');
1335 # Prefix + valid-length password
1336 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1338 $self->_password_encoding('plain');
1340 # Prefix + crypt string
1341 elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1343 $self->_password_encoding('crypt');
1345 # Various disabled crypt passwords
1346 elsif ( $pass eq '*' or
1349 $self->_password_encoding('crypt');
1356 elsif($encoding eq 'crypt') {
1357 if($encryption eq 'md5') {
1358 $pass = unix_md5_crypt($pass);
1360 elsif($encryption eq 'des') {
1361 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1364 elsif($encoding eq 'ldap') {
1365 if($encryption eq 'md5') {
1366 $pass = md5_base64($pass);
1368 elsif($encryption eq 'sha1') {
1369 $pass = sha1_base64($pass);
1371 elsif($encryption eq 'crypt') {
1372 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1374 # else $encryption eq 'plain', do nothing
1375 $pass = '{'.uc($encryption).'}'.$pass;
1377 # else encoding eq 'plain'
1379 $self->_password($pass);
1385 Internal function to check the username against the list of system usernames
1386 from the I<system_usernames> configuration value. Returns true if the username
1387 is listed on the system username list.
1393 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1394 $conf->config('system_usernames')
1398 =item _check_duplicate
1400 Internal method to check for duplicates usernames, username@domain pairs and
1403 If the I<global_unique-username> configuration value is set to B<username> or
1404 B<username@domain>, enforces global username or username@domain uniqueness.
1406 In all cases, check for duplicate uids and usernames or username@domain pairs
1407 per export and with identical I<svcpart> values.
1411 sub _check_duplicate {
1414 my $global_unique = $conf->config('global_unique-username') || 'none';
1415 return '' if $global_unique eq 'disabled';
1419 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1420 unless ( $part_svc ) {
1421 return 'unknown svcpart '. $self->svcpart;
1424 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1425 qsearch( 'svc_acct', { 'username' => $self->username } );
1426 return gettext('username_in_use')
1427 if $global_unique eq 'username' && @dup_user;
1429 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1430 qsearch( 'svc_acct', { 'username' => $self->username,
1431 'domsvc' => $self->domsvc } );
1432 return gettext('username_in_use')
1433 if $global_unique eq 'username@domain' && @dup_userdomain;
1436 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1437 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1438 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1439 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1444 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1445 my $exports = FS::part_export::export_info('svc_acct');
1446 my %conflict_user_svcpart;
1447 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1449 foreach my $part_export ( $part_svc->part_export ) {
1451 #this will catch to the same exact export
1452 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1454 #this will catch to exports w/same exporthost+type ???
1455 #my @other_part_export = qsearch('part_export', {
1456 # 'machine' => $part_export->machine,
1457 # 'exporttype' => $part_export->exporttype,
1459 #foreach my $other_part_export ( @other_part_export ) {
1460 # push @svcparts, map { $_->svcpart }
1461 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1464 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1465 #silly kludge to avoid uninitialized value errors
1466 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1467 ? $exports->{$part_export->exporttype}{'nodomain'}
1469 if ( $nodomain =~ /^Y/i ) {
1470 $conflict_user_svcpart{$_} = $part_export->exportnum
1473 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1478 foreach my $dup_user ( @dup_user ) {
1479 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1480 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1481 return "duplicate username ". $self->username.
1482 ": conflicts with svcnum ". $dup_user->svcnum.
1483 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1487 foreach my $dup_userdomain ( @dup_userdomain ) {
1488 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1489 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1490 return "duplicate username\@domain ". $self->email.
1491 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1492 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1496 foreach my $dup_uid ( @dup_uid ) {
1497 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1498 if ( exists($conflict_user_svcpart{$dup_svcpart})
1499 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1500 return "duplicate uid ". $self->uid.
1501 ": conflicts with svcnum ". $dup_uid->svcnum.
1503 ( $conflict_user_svcpart{$dup_svcpart}
1504 || $conflict_userdomain_svcpart{$dup_svcpart} );
1516 Depriciated, use radius_reply instead.
1521 carp "FS::svc_acct::radius depriciated, use radius_reply";
1522 $_[0]->radius_reply;
1527 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1528 reply attributes of this record.
1530 Note that this is now the preferred method for reading RADIUS attributes -
1531 accessing the columns directly is discouraged, as the column names are
1532 expected to change in the future.
1539 return %{ $self->{'radius_reply'} }
1540 if exists $self->{'radius_reply'};
1545 my($column, $attrib) = ($1, $2);
1546 #$attrib =~ s/_/\-/g;
1547 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1548 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1550 if ( $self->slipip && $self->slipip ne '0e0' ) {
1551 $reply{$radius_ip} = $self->slipip;
1554 if ( $self->seconds !~ /^$/ ) {
1555 $reply{'Session-Timeout'} = $self->seconds;
1558 if ( $conf->exists('radius-chillispot-max') ) {
1559 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1561 #hmm. just because sqlradius.pm says so?
1568 foreach my $what (qw( input output total )) {
1569 my $is = $whatis{$what}.'bytes';
1570 if ( $self->$is() =~ /\d/ ) {
1571 my $big = new Math::BigInt $self->$is();
1572 $big = new Math::BigInt '0' if $big->is_neg();
1573 my $att = "Chillispot-Max-\u$what";
1574 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1575 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1586 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1587 check attributes of this record.
1589 Note that this is now the preferred method for reading RADIUS attributes -
1590 accessing the columns directly is discouraged, as the column names are
1591 expected to change in the future.
1598 return %{ $self->{'radius_check'} }
1599 if exists $self->{'radius_check'};
1604 my($column, $attrib) = ($1, $2);
1605 #$attrib =~ s/_/\-/g;
1606 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1607 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1610 my($pw_attrib, $password) = $self->radius_password;
1611 $check{$pw_attrib} = $password;
1613 my $cust_svc = $self->cust_svc;
1615 my $cust_pkg = $cust_svc->cust_pkg;
1616 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1617 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1620 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1621 "; can't set Expiration\n"
1629 =item radius_password
1631 Returns a key/value pair containing the RADIUS attribute name and value
1636 sub radius_password {
1639 my($pw_attrib, $password);
1640 if ( $self->_password_encoding eq 'ldap' ) {
1642 $pw_attrib = 'Password-With-Header';
1643 $password = $self->_password;
1645 } elsif ( $self->_password_encoding eq 'crypt' ) {
1647 $pw_attrib = 'Crypt-Password';
1648 $password = $self->_password;
1650 } elsif ( $self->_password_encoding eq 'plain' ) {
1652 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1653 $password = $self->_password;
1657 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1658 $password = $self->_password;
1662 ($pw_attrib, $password);
1668 This method instructs the object to "snapshot" or freeze RADIUS check and
1669 reply attributes to the current values.
1673 #bah, my english is too broken this morning
1674 #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
1675 #the FS::cust_pkg's replace method to trigger the correct export updates when
1676 #package dates change)
1681 $self->{$_} = { $self->$_() }
1682 foreach qw( radius_reply radius_check );
1686 =item forget_snapshot
1688 This methos instructs the object to forget any previously snapshotted
1689 RADIUS check and reply attributes.
1693 sub forget_snapshot {
1697 foreach qw( radius_reply radius_check );
1701 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1703 Returns the domain associated with this account.
1705 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1712 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1713 my $svc_domain = $self->svc_domain(@_)
1714 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1715 $svc_domain->domain;
1720 Returns the FS::svc_domain record for this account's domain (see
1725 # FS::h_svc_acct has a history-aware svc_domain override
1730 ? $self->{'_domsvc'}
1731 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1736 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1740 #inherited from svc_Common
1742 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1744 Returns an email address associated with the account.
1746 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1753 $self->username. '@'. $self->domain(@_);
1758 Returns an array of FS::acct_snarf records associated with the account.
1759 If the acct_snarf table does not exist or there are no associated records,
1760 an empty list is returned
1766 return () unless dbdef->table('acct_snarf');
1767 eval "use FS::acct_snarf;";
1769 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1772 =item decrement_upbytes OCTETS
1774 Decrements the I<upbytes> field of this record by the given amount. If there
1775 is an error, returns the error, otherwise returns false.
1779 sub decrement_upbytes {
1780 shift->_op_usage('-', 'upbytes', @_);
1783 =item increment_upbytes OCTETS
1785 Increments the I<upbytes> field of this record by the given amount. If there
1786 is an error, returns the error, otherwise returns false.
1790 sub increment_upbytes {
1791 shift->_op_usage('+', 'upbytes', @_);
1794 =item decrement_downbytes OCTETS
1796 Decrements the I<downbytes> field of this record by the given amount. If there
1797 is an error, returns the error, otherwise returns false.
1801 sub decrement_downbytes {
1802 shift->_op_usage('-', 'downbytes', @_);
1805 =item increment_downbytes OCTETS
1807 Increments the I<downbytes> field of this record by the given amount. If there
1808 is an error, returns the error, otherwise returns false.
1812 sub increment_downbytes {
1813 shift->_op_usage('+', 'downbytes', @_);
1816 =item decrement_totalbytes OCTETS
1818 Decrements the I<totalbytes> field of this record by the given amount. If there
1819 is an error, returns the error, otherwise returns false.
1823 sub decrement_totalbytes {
1824 shift->_op_usage('-', 'totalbytes', @_);
1827 =item increment_totalbytes OCTETS
1829 Increments the I<totalbytes> field of this record by the given amount. If there
1830 is an error, returns the error, otherwise returns false.
1834 sub increment_totalbytes {
1835 shift->_op_usage('+', 'totalbytes', @_);
1838 =item decrement_seconds SECONDS
1840 Decrements the I<seconds> field of this record by the given amount. If there
1841 is an error, returns the error, otherwise returns false.
1845 sub decrement_seconds {
1846 shift->_op_usage('-', 'seconds', @_);
1849 =item increment_seconds SECONDS
1851 Increments the I<seconds> field of this record by the given amount. If there
1852 is an error, returns the error, otherwise returns false.
1856 sub increment_seconds {
1857 shift->_op_usage('+', 'seconds', @_);
1865 my %op2condition = (
1866 '-' => sub { my($self, $column, $amount) = @_;
1867 $self->$column - $amount <= 0;
1869 '+' => sub { my($self, $column, $amount) = @_;
1870 ($self->$column || 0) + $amount > 0;
1873 my %op2warncondition = (
1874 '-' => sub { my($self, $column, $amount) = @_;
1875 my $threshold = $column . '_threshold';
1876 $self->$column - $amount <= $self->$threshold + 0;
1878 '+' => sub { my($self, $column, $amount) = @_;
1879 ($self->$column || 0) + $amount > 0;
1884 my( $self, $op, $column, $amount ) = @_;
1886 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1887 ' ('. $self->email. "): $op $amount\n"
1890 return '' unless $amount;
1892 local $SIG{HUP} = 'IGNORE';
1893 local $SIG{INT} = 'IGNORE';
1894 local $SIG{QUIT} = 'IGNORE';
1895 local $SIG{TERM} = 'IGNORE';
1896 local $SIG{TSTP} = 'IGNORE';
1897 local $SIG{PIPE} = 'IGNORE';
1899 my $oldAutoCommit = $FS::UID::AutoCommit;
1900 local $FS::UID::AutoCommit = 0;
1903 my $sql = "UPDATE svc_acct SET $column = ".
1904 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1905 " $op ? WHERE svcnum = ?";
1909 my $sth = $dbh->prepare( $sql )
1910 or die "Error preparing $sql: ". $dbh->errstr;
1911 my $rv = $sth->execute($amount, $self->svcnum);
1912 die "Error executing $sql: ". $sth->errstr
1913 unless defined($rv);
1914 die "Can't update $column for svcnum". $self->svcnum
1917 #$self->snapshot; #not necessary, we retain the old values
1918 #create an object with the updated usage values
1919 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1921 my $error = $new->replace($self);
1923 $dbh->rollback if $oldAutoCommit;
1924 return "Error replacing: $error";
1927 #overlimit_action eq 'cancel' handling
1928 my $cust_pkg = $self->cust_svc->cust_pkg;
1930 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1931 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1935 my $error = $cust_pkg->cancel; #XXX should have a reason
1937 $dbh->rollback if $oldAutoCommit;
1938 return "Error cancelling: $error";
1941 #nothing else is relevant if we're cancelling, so commit & return success
1942 warn "$me update successful; committing\n"
1944 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1949 my $action = $op2action{$op};
1951 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1952 ( $action eq 'suspend' && !$self->overlimit
1953 || $action eq 'unsuspend' && $self->overlimit )
1956 my $error = $self->_op_overlimit($action);
1958 $dbh->rollback if $oldAutoCommit;
1964 if ( $conf->exists("svc_acct-usage_$action")
1965 && &{$op2condition{$op}}($self, $column, $amount) ) {
1966 #my $error = $self->$action();
1967 my $error = $self->cust_svc->cust_pkg->$action();
1968 # $error ||= $self->overlimit($action);
1970 $dbh->rollback if $oldAutoCommit;
1971 return "Error ${action}ing: $error";
1975 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1976 my $wqueue = new FS::queue {
1977 'svcnum' => $self->svcnum,
1978 'job' => 'FS::svc_acct::reached_threshold',
1983 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1987 my $error = $wqueue->insert(
1988 'svcnum' => $self->svcnum,
1990 'column' => $column,
1994 $dbh->rollback if $oldAutoCommit;
1995 return "Error queuing threshold activity: $error";
1999 warn "$me update successful; committing\n"
2001 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2007 my( $self, $action ) = @_;
2009 local $SIG{HUP} = 'IGNORE';
2010 local $SIG{INT} = 'IGNORE';
2011 local $SIG{QUIT} = 'IGNORE';
2012 local $SIG{TERM} = 'IGNORE';
2013 local $SIG{TSTP} = 'IGNORE';
2014 local $SIG{PIPE} = 'IGNORE';
2016 my $oldAutoCommit = $FS::UID::AutoCommit;
2017 local $FS::UID::AutoCommit = 0;
2020 my $cust_pkg = $self->cust_svc->cust_pkg;
2022 my $conf_overlimit =
2024 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2025 : $conf->config('overlimit_groups');
2027 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2029 my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2030 next unless $groups;
2032 my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2034 my $other = new FS::svc_acct $self->hashref;
2035 $other->usergroup( $gref );
2038 if ($action eq 'suspend') {
2041 } else { # $action eq 'unsuspend'
2046 my $error = $part_export->export_replace($new, $old)
2047 || $self->overlimit($action);
2050 $dbh->rollback if $oldAutoCommit;
2051 return "Error replacing radius groups: $error";
2056 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2062 my( $self, $valueref, %options ) = @_;
2064 warn "$me set_usage called for svcnum ". $self->svcnum.
2065 ' ('. $self->email. "): ".
2066 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2069 local $SIG{HUP} = 'IGNORE';
2070 local $SIG{INT} = 'IGNORE';
2071 local $SIG{QUIT} = 'IGNORE';
2072 local $SIG{TERM} = 'IGNORE';
2073 local $SIG{TSTP} = 'IGNORE';
2074 local $SIG{PIPE} = 'IGNORE';
2076 local $FS::svc_Common::noexport_hack = 1;
2077 my $oldAutoCommit = $FS::UID::AutoCommit;
2078 local $FS::UID::AutoCommit = 0;
2083 if ( $options{null} ) {
2084 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2085 qw( seconds upbytes downbytes totalbytes )
2088 foreach my $field (keys %$valueref){
2089 $reset = 1 if $valueref->{$field};
2090 $self->setfield($field, $valueref->{$field});
2091 $self->setfield( $field.'_threshold',
2092 int($self->getfield($field)
2093 * ( $conf->exists('svc_acct-usage_threshold')
2094 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2099 $handyhash{$field} = $self->getfield($field);
2100 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2102 #my $error = $self->replace; #NO! we avoid the call to ->check for
2103 #die $error if $error; #services not explicity changed via the UI
2105 my $sql = "UPDATE svc_acct SET " .
2106 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
2107 " WHERE svcnum = ". $self->svcnum;
2112 if (scalar(keys %handyhash)) {
2113 my $sth = $dbh->prepare( $sql )
2114 or die "Error preparing $sql: ". $dbh->errstr;
2115 my $rv = $sth->execute();
2116 die "Error executing $sql: ". $sth->errstr
2117 unless defined($rv);
2118 die "Can't update usage for svcnum ". $self->svcnum
2122 #$self->snapshot; #not necessary, we retain the old values
2123 #create an object with the updated usage values
2124 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2126 my $error = $new->replace($self);
2128 $dbh->rollback if $oldAutoCommit;
2129 return "Error replacing: $error";
2136 $error = $self->_op_overlimit('unsuspend')
2137 if $self->overlimit;;
2139 $error ||= $self->cust_svc->cust_pkg->unsuspend
2140 if $conf->exists("svc_acct-usage_unsuspend");
2143 $dbh->rollback if $oldAutoCommit;
2144 return "Error unsuspending: $error";
2149 warn "$me update successful; committing\n"
2151 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2157 =item recharge HASHREF
2159 Increments usage columns by the amount specified in HASHREF as
2160 column=>amount pairs.
2165 my ($self, $vhash) = @_;
2168 warn "[$me] recharge called on $self: ". Dumper($self).
2169 "\nwith vhash: ". Dumper($vhash);
2172 my $oldAutoCommit = $FS::UID::AutoCommit;
2173 local $FS::UID::AutoCommit = 0;
2177 foreach my $column (keys %$vhash){
2178 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2182 $dbh->rollback if $oldAutoCommit;
2184 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2189 =item is_rechargeable
2191 Returns true if this svc_account can be "recharged" and false otherwise.
2195 sub is_rechargable {
2197 $self->seconds ne ''
2198 || $self->upbytes ne ''
2199 || $self->downbytes ne ''
2200 || $self->totalbytes ne '';
2203 =item seconds_since TIMESTAMP
2205 Returns the number of seconds this account has been online since TIMESTAMP,
2206 according to the session monitor (see L<FS::Session>).
2208 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2209 L<Time::Local> and L<Date::Parse> for conversion functions.
2213 #note: POD here, implementation in FS::cust_svc
2216 $self->cust_svc->seconds_since(@_);
2219 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2221 Returns the numbers of seconds this account has been online between
2222 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2223 external SQL radacct table, specified via sqlradius export. Sessions which
2224 started in the specified range but are still open are counted from session
2225 start to the end of the range (unless they are over 1 day old, in which case
2226 they are presumed missing their stop record and not counted). Also, sessions
2227 which end in the range but started earlier are counted from the start of the
2228 range to session end. Finally, sessions which start before the range but end
2229 after are counted for the entire range.
2231 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2232 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2237 #note: POD here, implementation in FS::cust_svc
2238 sub seconds_since_sqlradacct {
2240 $self->cust_svc->seconds_since_sqlradacct(@_);
2243 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2245 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2246 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2247 TIMESTAMP_END (exclusive).
2249 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2250 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2255 #note: POD here, implementation in FS::cust_svc
2256 sub attribute_since_sqlradacct {
2258 $self->cust_svc->attribute_since_sqlradacct(@_);
2261 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2263 Returns an array of hash references of this customers login history for the
2264 given time range. (document this better)
2268 sub get_session_history {
2270 $self->cust_svc->get_session_history(@_);
2273 =item last_login_text
2275 Returns text describing the time of last login.
2279 sub last_login_text {
2281 $self->last_login ? ctime($self->last_login) : 'unknown';
2284 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2289 my($self, $start, $end, %opt ) = @_;
2291 my $did = $self->username; #yup
2293 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2295 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2297 #SELECT $for_update * FROM cdr
2298 # WHERE calldate >= $start #need a conversion
2299 # AND calldate < $end #ditto
2300 # AND ( charged_party = "$did"
2301 # OR charged_party = "$prefix$did" #if length($prefix);
2302 # OR ( ( charged_party IS NULL OR charged_party = '' )
2304 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2307 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2310 if ( length($prefix) ) {
2312 " AND ( charged_party = '$did'
2313 OR charged_party = '$prefix$did'
2314 OR ( ( charged_party IS NULL OR charged_party = '' )
2316 ( src = '$did' OR src = '$prefix$did' )
2322 " AND ( charged_party = '$did'
2323 OR ( ( charged_party IS NULL OR charged_party = '' )
2333 'select' => "$for_update *",
2336 #( freesidestatus IS NULL OR freesidestatus = '' )
2337 'freesidestatus' => '',
2339 'extra_sql' => $charged_or_src,
2347 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2353 if ( $self->usergroup ) {
2354 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2355 unless ref($self->usergroup) eq 'ARRAY';
2356 #when provisioning records, export callback runs in svc_Common.pm before
2357 #radius_usergroup records can be inserted...
2358 @{$self->usergroup};
2360 map { $_->groupname }
2361 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2365 =item clone_suspended
2367 Constructor used by FS::part_export::_export_suspend fallback. Document
2372 sub clone_suspended {
2374 my %hash = $self->hash;
2375 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2376 new FS::svc_acct \%hash;
2379 =item clone_kludge_unsuspend
2381 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2386 sub clone_kludge_unsuspend {
2388 my %hash = $self->hash;
2389 $hash{_password} = '';
2390 new FS::svc_acct \%hash;
2393 =item check_password
2395 Checks the supplied password against the (possibly encrypted) password in the
2396 database. Returns true for a successful authentication, false for no match.
2398 Currently supported encryptions are: classic DES crypt() and MD5
2402 sub check_password {
2403 my($self, $check_password) = @_;
2405 #remove old-style SUSPENDED kludge, they should be allowed to login to
2406 #self-service and pay up
2407 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2409 if ( $self->_password_encoding eq 'ldap' ) {
2411 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2412 return $auth->match($check_password);
2414 } elsif ( $self->_password_encoding eq 'crypt' ) {
2416 my $auth = from_crypt Authen::Passphrase $self->_password;
2417 return $auth->match($check_password);
2419 } elsif ( $self->_password_encoding eq 'plain' ) {
2421 return $check_password eq $password;
2425 #XXX this could be replaced with Authen::Passphrase stuff
2427 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2429 } elsif ( length($password) < 13 ) { #plaintext
2430 $check_password eq $password;
2431 } elsif ( length($password) == 13 ) { #traditional DES crypt
2432 crypt($check_password, $password) eq $password;
2433 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2434 unix_md5_crypt($check_password, $password) eq $password;
2435 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2436 warn "Can't check password: Blowfish encryption not yet supported, ".
2437 "svcnum ". $self->svcnum. "\n";
2440 warn "Can't check password: Unrecognized encryption for svcnum ".
2441 $self->svcnum. "\n";
2449 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2451 Returns an encrypted password, either by passing through an encrypted password
2452 in the database or by encrypting a plaintext password from the database.
2454 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2455 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2456 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2457 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2458 encryption type is only used if the password is not already encrypted in the
2463 sub crypt_password {
2466 if ( $self->_password_encoding eq 'ldap' ) {
2468 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2471 #XXX this could be replaced with Authen::Passphrase stuff
2473 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2474 if ( $encryption eq 'crypt' ) {
2477 $saltset[int(rand(64))].$saltset[int(rand(64))]
2479 } elsif ( $encryption eq 'md5' ) {
2480 unix_md5_crypt( $self->_password );
2481 } elsif ( $encryption eq 'blowfish' ) {
2482 croak "unknown encryption method $encryption";
2484 croak "unknown encryption method $encryption";
2487 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2491 } elsif ( $self->_password_encoding eq 'crypt' ) {
2493 return $self->_password;
2495 } elsif ( $self->_password_encoding eq 'plain' ) {
2497 #XXX this could be replaced with Authen::Passphrase stuff
2499 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2500 if ( $encryption eq 'crypt' ) {
2503 $saltset[int(rand(64))].$saltset[int(rand(64))]
2505 } elsif ( $encryption eq 'md5' ) {
2506 unix_md5_crypt( $self->_password );
2507 } elsif ( $encryption eq 'blowfish' ) {
2508 croak "unknown encryption method $encryption";
2510 croak "unknown encryption method $encryption";
2515 if ( length($self->_password) == 13
2516 || $self->_password =~ /^\$(1|2a?)\$/
2517 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2523 #XXX this could be replaced with Authen::Passphrase stuff
2525 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2526 if ( $encryption eq 'crypt' ) {
2529 $saltset[int(rand(64))].$saltset[int(rand(64))]
2531 } elsif ( $encryption eq 'md5' ) {
2532 unix_md5_crypt( $self->_password );
2533 } elsif ( $encryption eq 'blowfish' ) {
2534 croak "unknown encryption method $encryption";
2536 croak "unknown encryption method $encryption";
2545 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2547 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2548 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2549 "{MD5}5426824942db4253f87a1009fd5d2d4".
2551 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2552 to work the same as the B</crypt_password> method.
2558 #eventually should check a "password-encoding" field
2560 if ( $self->_password_encoding eq 'ldap' ) {
2562 return $self->_password;
2564 } elsif ( $self->_password_encoding eq 'crypt' ) {
2566 if ( length($self->_password) == 13 ) { #crypt
2567 return '{CRYPT}'. $self->_password;
2568 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2570 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2571 # die "Blowfish encryption not supported in this context, svcnum ".
2572 # $self->svcnum. "\n";
2574 warn "encryption method not (yet?) supported in LDAP context";
2575 return '{CRYPT}*'; #unsupported, should not auth
2578 } elsif ( $self->_password_encoding eq 'plain' ) {
2580 return '{PLAIN}'. $self->_password;
2582 #return '{CLEARTEXT}'. $self->_password; #?
2586 if ( length($self->_password) == 13 ) { #crypt
2587 return '{CRYPT}'. $self->_password;
2588 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2590 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2591 warn "Blowfish encryption not supported in this context, svcnum ".
2592 $self->svcnum. "\n";
2595 #are these two necessary anymore?
2596 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2597 return '{SSHA}'. $1;
2598 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2599 return '{NS-MTA-MD5}'. $1;
2602 return '{PLAIN}'. $self->_password;
2604 #return '{CLEARTEXT}'. $self->_password; #?
2606 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2607 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2608 #if ( $encryption eq 'crypt' ) {
2609 # return '{CRYPT}'. crypt(
2611 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2613 #} elsif ( $encryption eq 'md5' ) {
2614 # unix_md5_crypt( $self->_password );
2615 #} elsif ( $encryption eq 'blowfish' ) {
2616 # croak "unknown encryption method $encryption";
2618 # croak "unknown encryption method $encryption";
2626 =item domain_slash_username
2628 Returns $domain/$username/
2632 sub domain_slash_username {
2634 $self->domain. '/'. $self->username. '/';
2637 =item virtual_maildir
2639 Returns $domain/maildirs/$username/
2643 sub virtual_maildir {
2645 $self->domain. '/maildirs/'. $self->username. '/';
2650 =head1 CLASS METHODS
2654 =item search HASHREF
2656 Class method which returns a qsearch hash expression to search for parameters
2657 specified in HASHREF. Valid parameters are
2671 Arrayref of pkgparts
2677 Arrayref of additional WHERE clauses, will be ANDed together.
2688 my ($class, $params) = @_;
2693 if ( $params->{'domain'} ) {
2694 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2695 #preserve previous behavior & bubble up an error if $svc_domain not found?
2696 push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2700 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2701 push @where, "domsvc = $1";
2705 push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2708 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2709 push @where, "agentnum = $1";
2713 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2714 push @where, "custnum = $1";
2718 if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2719 #XXX untaint or sql quote
2721 'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2725 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2726 push @where, "popnum = $1";
2730 if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2731 push @where, "svcpart = $1";
2735 # here is the agent virtualization
2736 #if ($params->{CurrentUser}) {
2738 # qsearchs('access_user', { username => $params->{CurrentUser} });
2740 # if ($access_user) {
2741 # push @where, $access_user->agentnums_sql('table'=>'cust_main');
2743 # push @where, "1=0";
2746 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2747 'table' => 'cust_main',
2748 'null_right' => 'View/link unlinked services',
2752 push @where, @{ $params->{'where'} } if $params->{'where'};
2754 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2756 my $addl_from = ' LEFT JOIN cust_svc USING ( svcnum ) '.
2757 ' LEFT JOIN part_svc USING ( svcpart ) '.
2758 ' LEFT JOIN cust_pkg USING ( pkgnum ) '.
2759 ' LEFT JOIN cust_main USING ( custnum ) ';
2761 my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2762 #if ( keys %svc_acct ) {
2763 # $count_query .= ' WHERE '.
2764 # join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2770 'table' => 'svc_acct',
2771 'hashref' => {}, # \%svc_acct,
2772 'select' => join(', ',
2775 'cust_main.custnum',
2776 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2778 'addl_from' => $addl_from,
2779 'extra_sql' => $extra_sql,
2780 'order_by' => $params->{'order_by'},
2781 'count_query' => $count_query,
2794 This is the FS::svc_acct job-queue-able version. It still uses
2795 FS::Misc::send_email under-the-hood.
2802 eval "use FS::Misc qw(send_email)";
2805 $opt{mimetype} ||= 'text/plain';
2806 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2808 my $error = send_email(
2809 'from' => $opt{from},
2811 'subject' => $opt{subject},
2812 'content-type' => $opt{mimetype},
2813 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2815 die $error if $error;
2818 =item check_and_rebuild_fuzzyfiles
2822 sub check_and_rebuild_fuzzyfiles {
2823 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2824 -e "$dir/svc_acct.username"
2825 or &rebuild_fuzzyfiles;
2828 =item rebuild_fuzzyfiles
2832 sub rebuild_fuzzyfiles {
2834 use Fcntl qw(:flock);
2836 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2840 open(USERNAMELOCK,">>$dir/svc_acct.username")
2841 or die "can't open $dir/svc_acct.username: $!";
2842 flock(USERNAMELOCK,LOCK_EX)
2843 or die "can't lock $dir/svc_acct.username: $!";
2845 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2847 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2848 or die "can't open $dir/svc_acct.username.tmp: $!";
2849 print USERNAMECACHE join("\n", @all_username), "\n";
2850 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2852 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2862 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2863 open(USERNAMECACHE,"<$dir/svc_acct.username")
2864 or die "can't open $dir/svc_acct.username: $!";
2865 my @array = map { chomp; $_; } <USERNAMECACHE>;
2866 close USERNAMECACHE;
2870 =item append_fuzzyfiles USERNAME
2874 sub append_fuzzyfiles {
2875 my $username = shift;
2877 &check_and_rebuild_fuzzyfiles;
2879 use Fcntl qw(:flock);
2881 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2883 open(USERNAME,">>$dir/svc_acct.username")
2884 or die "can't open $dir/svc_acct.username: $!";
2885 flock(USERNAME,LOCK_EX)
2886 or die "can't lock $dir/svc_acct.username: $!";
2888 print USERNAME "$username\n";
2890 flock(USERNAME,LOCK_UN)
2891 or die "can't unlock $dir/svc_acct.username: $!";
2899 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2903 sub radius_usergroup_selector {
2904 my $sel_groups = shift;
2905 my %sel_groups = map { $_=>1 } @$sel_groups;
2907 my $selectname = shift || 'radius_usergroup';
2910 my $sth = $dbh->prepare(
2911 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2912 ) or die $dbh->errstr;
2913 $sth->execute() or die $sth->errstr;
2914 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2918 function ${selectname}_doadd(object) {
2919 var myvalue = object.${selectname}_add.value;
2920 var optionName = new Option(myvalue,myvalue,false,true);
2921 var length = object.$selectname.length;
2922 object.$selectname.options[length] = optionName;
2923 object.${selectname}_add.value = "";
2926 <SELECT MULTIPLE NAME="$selectname">
2929 foreach my $group ( @all_groups ) {
2930 $html .= qq(<OPTION VALUE="$group");
2931 if ( $sel_groups{$group} ) {
2932 $html .= ' SELECTED';
2933 $sel_groups{$group} = 0;
2935 $html .= ">$group</OPTION>\n";
2937 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2938 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2940 $html .= '</SELECT>';
2942 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2943 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2948 =item reached_threshold
2950 Performs some activities when svc_acct thresholds (such as number of seconds
2951 remaining) are reached.
2955 sub reached_threshold {
2958 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2959 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2961 if ( $opt{'op'} eq '+' ){
2962 $svc_acct->setfield( $opt{'column'}.'_threshold',
2963 int($svc_acct->getfield($opt{'column'})
2964 * ( $conf->exists('svc_acct-usage_threshold')
2965 ? $conf->config('svc_acct-usage_threshold')/100
2970 my $error = $svc_acct->replace;
2971 die $error if $error;
2972 }elsif ( $opt{'op'} eq '-' ){
2974 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2975 return '' if ($threshold eq '' );
2977 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2978 my $error = $svc_acct->replace;
2979 die $error if $error; # email next time, i guess
2981 if ( $warning_template ) {
2982 eval "use FS::Misc qw(send_email)";
2985 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2986 my $cust_main = $cust_pkg->cust_main;
2988 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2989 $cust_main->invoicing_list,
2990 ($opt{'to'} ? $opt{'to'} : ())
2993 my $mimetype = $warning_mimetype;
2994 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2996 my $body = $warning_template->fill_in( HASH => {
2997 'custnum' => $cust_main->custnum,
2998 'username' => $svc_acct->username,
2999 'password' => $svc_acct->_password,
3000 'first' => $cust_main->first,
3001 'last' => $cust_main->getfield('last'),
3002 'pkg' => $cust_pkg->part_pkg->pkg,
3003 'column' => $opt{'column'},
3004 'amount' => $opt{'column'} =~/bytes/
3005 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3006 : $svc_acct->getfield($opt{'column'}),
3007 'threshold' => $opt{'column'} =~/bytes/
3008 ? FS::UI::bytecount::display_bytecount($threshold)
3013 my $error = send_email(
3014 'from' => $warning_from,
3016 'subject' => $warning_subject,
3017 'content-type' => $mimetype,
3018 'body' => [ map "$_\n", split("\n", $body) ],
3020 die $error if $error;
3023 die "unknown op: " . $opt{'op'};
3031 The $recref stuff in sub check should be cleaned up.
3033 The suspend, unsuspend and cancel methods update the database, but not the
3034 current object. This is probably a bug as it's unexpected and
3037 radius_usergroup_selector? putting web ui components in here? they should
3038 probably live somewhere else...
3040 insertion of RADIUS group stuff in insert could be done with child_objects now
3041 (would probably clean up export of them too)
3043 _op_usage and set_usage bypass the history... maybe they shouldn't
3047 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3048 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3049 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3050 L<freeside-queued>), L<FS::svc_acct_pop>,
3051 schema.html from the base documentation.
3055 =item domain_select_hash %OPTIONS
3057 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
3058 may at present purchase.
3060 Currently available options are: I<pkgnum> I<svcpart>
3064 sub domain_select_hash {
3065 my ($self, %options) = @_;
3071 $part_svc = $self->part_svc;
3072 $cust_pkg = $self->cust_svc->cust_pkg
3076 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
3077 if $options{'svcpart'};
3079 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
3080 if $options{'pkgnum'};
3082 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
3083 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
3084 %domains = map { $_->svcnum => $_->domain }
3085 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
3086 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
3087 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
3088 %domains = map { $_->svcnum => $_->domain }
3089 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
3090 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
3091 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
3093 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
3096 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
3097 my $svc_domain = qsearchs('svc_domain',
3098 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
3099 if ( $svc_domain ) {
3100 $domains{$svc_domain->svcnum} = $svc_domain->domain;
3102 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
3103 $part_svc->part_svc_column('domsvc')->columnvalue;