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 ).
439 $class->search_sql_field('username', $string);
443 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
445 Returns the "username@domain" string for this account.
447 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
457 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
459 Returns a longer string label for this acccount ("Real Name <username@domain>"
460 if available, or "username@domain").
462 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
469 my $label = $self->label(@_);
470 my $finger = $self->finger;
471 return $label unless $finger =~ /\S/;
472 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
473 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
477 =item insert [ , OPTION => VALUE ... ]
479 Adds this account to the database. If there is an error, returns the error,
480 otherwise returns false.
482 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
483 defined. An FS::cust_svc record will be created and inserted.
485 The additional field I<usergroup> can optionally be defined; if so it should
486 contain an arrayref of group names. See L<FS::radius_usergroup>.
488 The additional field I<child_objects> can optionally be defined; if so it
489 should contain an arrayref of FS::tablename objects. They will have their
490 svcnum fields set and will be inserted after this record, but before any
491 exports are run. Each element of the array can also optionally be a
492 two-element array reference containing the child object and the name of an
493 alternate field to be filled in with the newly-inserted svcnum, for example
494 C<[ $svc_forward, 'srcsvc' ]>
496 Currently available options are: I<depend_jobnum>
498 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
499 jobnums), all provisioning jobs will have a dependancy on the supplied
500 jobnum(s) (they will not run until the specific job(s) complete(s)).
502 (TODOC: L<FS::queue> and L<freeside-queued>)
504 (TODOC: new exports!)
513 warn "[$me] insert called on $self: ". Dumper($self).
514 "\nwith options: ". Dumper(%options);
517 local $SIG{HUP} = 'IGNORE';
518 local $SIG{INT} = 'IGNORE';
519 local $SIG{QUIT} = 'IGNORE';
520 local $SIG{TERM} = 'IGNORE';
521 local $SIG{TSTP} = 'IGNORE';
522 local $SIG{PIPE} = 'IGNORE';
524 my $oldAutoCommit = $FS::UID::AutoCommit;
525 local $FS::UID::AutoCommit = 0;
529 my $error = $self->SUPER::insert(
530 'jobnums' => \@jobnums,
531 'child_objects' => $self->child_objects,
535 $dbh->rollback if $oldAutoCommit;
539 if ( $self->usergroup ) {
540 foreach my $groupname ( @{$self->usergroup} ) {
541 my $radius_usergroup = new FS::radius_usergroup ( {
542 svcnum => $self->svcnum,
543 groupname => $groupname,
545 my $error = $radius_usergroup->insert;
547 $dbh->rollback if $oldAutoCommit;
553 unless ( $skip_fuzzyfiles ) {
554 $error = $self->queue_fuzzyfiles_update;
556 $dbh->rollback if $oldAutoCommit;
557 return "updating fuzzy search cache: $error";
561 my $cust_pkg = $self->cust_svc->cust_pkg;
564 my $cust_main = $cust_pkg->cust_main;
565 my $agentnum = $cust_main->agentnum;
567 if ( $conf->exists('emailinvoiceautoalways')
568 || $conf->exists('emailinvoiceauto')
569 && ! $cust_main->invoicing_list_emailonly
571 my @invoicing_list = $cust_main->invoicing_list;
572 push @invoicing_list, $self->email;
573 $cust_main->invoicing_list(\@invoicing_list);
577 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
578 = ('','','','','','');
580 if ( $conf->exists('welcome_email', $agentnum) ) {
581 $welcome_template = new Text::Template (
583 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
584 ) or warn "can't create welcome email template: $Text::Template::ERROR";
585 $welcome_from = $conf->config('welcome_email-from', $agentnum);
586 # || 'your-isp-is-dum'
587 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
589 $welcome_subject_template = new Text::Template (
591 SOURCE => $welcome_subject,
592 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
593 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
596 if ( $welcome_template && $cust_pkg ) {
597 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
601 'custnum' => $self->custnum,
602 'username' => $self->username,
603 'password' => $self->_password,
604 'first' => $cust_main->first,
605 'last' => $cust_main->getfield('last'),
606 'pkg' => $cust_pkg->part_pkg->pkg,
608 my $wqueue = new FS::queue {
609 'svcnum' => $self->svcnum,
610 'job' => 'FS::svc_acct::send_email'
612 my $error = $wqueue->insert(
614 'from' => $welcome_from,
615 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
616 'mimetype' => $welcome_mimetype,
617 'body' => $welcome_template->fill_in( HASH => \%hash, ),
620 $dbh->rollback if $oldAutoCommit;
621 return "error queuing welcome email: $error";
624 if ( $options{'depend_jobnum'} ) {
625 warn "$me depend_jobnum found; adding to welcome email dependancies"
627 if ( ref($options{'depend_jobnum'}) ) {
628 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
629 "to welcome email dependancies"
631 push @jobnums, @{ $options{'depend_jobnum'} };
633 warn "$me adding job $options{'depend_jobnum'} ".
634 "to welcome email dependancies"
636 push @jobnums, $options{'depend_jobnum'};
640 foreach my $jobnum ( @jobnums ) {
641 my $error = $wqueue->depend_insert($jobnum);
643 $dbh->rollback if $oldAutoCommit;
644 return "error queuing welcome email job dependancy: $error";
654 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
658 # set usage fields and thresholds if unset but set in a package def
659 sub preinsert_hook_first {
662 return '' unless $self->pkgnum;
664 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
665 my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
666 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
668 my %values = $part_pkg->usage_valuehash;
669 my $multiplier = $conf->exists('svc_acct-usage_threshold')
670 ? 1 - $conf->config('svc_acct-usage_threshold')/100
671 : 0.20; #doesn't matter
673 foreach ( keys %values ) {
674 next if $self->getfield($_);
675 $self->setfield( $_, $values{$_} );
676 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
677 if $conf->exists('svc_acct-usage_threshold');
685 Deletes this account from the database. If there is an error, returns the
686 error, otherwise returns false.
688 The corresponding FS::cust_svc record will be deleted as well.
690 (TODOC: new exports!)
697 return "can't delete system account" if $self->_check_system;
699 return "Can't delete an account which is a (svc_forward) source!"
700 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
702 return "Can't delete an account which is a (svc_forward) destination!"
703 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
705 return "Can't delete an account with (svc_www) web service!"
706 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
708 # what about records in session ? (they should refer to history table)
710 local $SIG{HUP} = 'IGNORE';
711 local $SIG{INT} = 'IGNORE';
712 local $SIG{QUIT} = 'IGNORE';
713 local $SIG{TERM} = 'IGNORE';
714 local $SIG{TSTP} = 'IGNORE';
715 local $SIG{PIPE} = 'IGNORE';
717 my $oldAutoCommit = $FS::UID::AutoCommit;
718 local $FS::UID::AutoCommit = 0;
721 foreach my $cust_main_invoice (
722 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
724 unless ( defined($cust_main_invoice) ) {
725 warn "WARNING: something's wrong with qsearch";
728 my %hash = $cust_main_invoice->hash;
729 $hash{'dest'} = $self->email;
730 my $new = new FS::cust_main_invoice \%hash;
731 my $error = $new->replace($cust_main_invoice);
733 $dbh->rollback if $oldAutoCommit;
738 foreach my $svc_domain (
739 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
741 my %hash = new FS::svc_domain->hash;
742 $hash{'catchall'} = '';
743 my $new = new FS::svc_domain \%hash;
744 my $error = $new->replace($svc_domain);
746 $dbh->rollback if $oldAutoCommit;
751 my $error = $self->SUPER::delete;
753 $dbh->rollback if $oldAutoCommit;
757 foreach my $radius_usergroup (
758 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
760 my $error = $radius_usergroup->delete;
762 $dbh->rollback if $oldAutoCommit;
767 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
771 =item replace OLD_RECORD
773 Replaces OLD_RECORD with this one in the database. If there is an error,
774 returns the error, otherwise returns false.
776 The additional field I<usergroup> can optionally be defined; if so it should
777 contain an arrayref of group names. See L<FS::radius_usergroup>.
785 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
789 warn "$me replacing $old with $new\n" if $DEBUG;
793 return "can't modify system account" if $old->_check_system;
796 #no warnings 'numeric'; #alas, a 5.006-ism
799 foreach my $xid (qw( uid gid )) {
801 return "Can't change $xid!"
802 if ! $conf->exists("svc_acct-edit_$xid")
803 && $old->$xid() != $new->$xid()
804 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
809 #change homdir when we change username
810 $new->setfield('dir', '') if $old->username ne $new->username;
812 local $SIG{HUP} = 'IGNORE';
813 local $SIG{INT} = 'IGNORE';
814 local $SIG{QUIT} = 'IGNORE';
815 local $SIG{TERM} = 'IGNORE';
816 local $SIG{TSTP} = 'IGNORE';
817 local $SIG{PIPE} = 'IGNORE';
819 my $oldAutoCommit = $FS::UID::AutoCommit;
820 local $FS::UID::AutoCommit = 0;
823 # redundant, but so $new->usergroup gets set
824 $error = $new->check;
825 return $error if $error;
827 $old->usergroup( [ $old->radius_groups ] );
829 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
830 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
832 if ( $new->usergroup ) {
833 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
834 my @newgroups = @{$new->usergroup};
835 foreach my $oldgroup ( @{$old->usergroup} ) {
836 if ( grep { $oldgroup eq $_ } @newgroups ) {
837 @newgroups = grep { $oldgroup ne $_ } @newgroups;
840 my $radius_usergroup = qsearchs('radius_usergroup', {
841 svcnum => $old->svcnum,
842 groupname => $oldgroup,
844 my $error = $radius_usergroup->delete;
846 $dbh->rollback if $oldAutoCommit;
847 return "error deleting radius_usergroup $oldgroup: $error";
851 foreach my $newgroup ( @newgroups ) {
852 my $radius_usergroup = new FS::radius_usergroup ( {
853 svcnum => $new->svcnum,
854 groupname => $newgroup,
856 my $error = $radius_usergroup->insert;
858 $dbh->rollback if $oldAutoCommit;
859 return "error adding radius_usergroup $newgroup: $error";
865 $error = $new->SUPER::replace($old, @_);
867 $dbh->rollback if $oldAutoCommit;
868 return $error if $error;
871 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
872 $error = $new->queue_fuzzyfiles_update;
874 $dbh->rollback if $oldAutoCommit;
875 return "updating fuzzy search cache: $error";
879 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
883 =item queue_fuzzyfiles_update
885 Used by insert & replace to update the fuzzy search cache
889 sub queue_fuzzyfiles_update {
892 local $SIG{HUP} = 'IGNORE';
893 local $SIG{INT} = 'IGNORE';
894 local $SIG{QUIT} = 'IGNORE';
895 local $SIG{TERM} = 'IGNORE';
896 local $SIG{TSTP} = 'IGNORE';
897 local $SIG{PIPE} = 'IGNORE';
899 my $oldAutoCommit = $FS::UID::AutoCommit;
900 local $FS::UID::AutoCommit = 0;
903 my $queue = new FS::queue {
904 'svcnum' => $self->svcnum,
905 'job' => 'FS::svc_acct::append_fuzzyfiles'
907 my $error = $queue->insert($self->username);
909 $dbh->rollback if $oldAutoCommit;
910 return "queueing job (transaction rolled back): $error";
913 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
921 Suspends this account by calling export-specific suspend hooks. If there is
922 an error, returns the error, otherwise returns false.
924 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
930 return "can't suspend system account" if $self->_check_system;
931 $self->SUPER::suspend(@_);
936 Unsuspends this account by by calling export-specific suspend hooks. If there
937 is an error, returns the error, otherwise returns false.
939 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
945 my %hash = $self->hash;
946 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
947 $hash{_password} = $1;
948 my $new = new FS::svc_acct ( \%hash );
949 my $error = $new->replace($self);
950 return $error if $error;
953 $self->SUPER::unsuspend(@_);
958 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
960 If the B<auto_unset_catchall> configuration option is set, this method will
961 automatically remove any references to the canceled service in the catchall
962 field of svc_domain. This allows packages that contain both a svc_domain and
963 its catchall svc_acct to be canceled in one step.
968 # Only one thing to do at this level
970 foreach my $svc_domain (
971 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
972 if($conf->exists('auto_unset_catchall')) {
973 my %hash = $svc_domain->hash;
974 $hash{catchall} = '';
975 my $new = new FS::svc_domain ( \%hash );
976 my $error = $new->replace($svc_domain);
977 return $error if $error;
979 return "cannot unprovision svc_acct #".$self->svcnum.
980 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
984 $self->SUPER::cancel(@_);
990 Checks all fields to make sure this is a valid service. If there is an error,
991 returns the error, otherwise returns false. Called by the insert and replace
994 Sets any fixed values; see L<FS::part_svc>.
1001 my($recref) = $self->hashref;
1003 my $x = $self->setfixed( $self->_fieldhandlers );
1004 return $x unless ref($x);
1007 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1009 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1012 my $error = $self->ut_numbern('svcnum')
1013 #|| $self->ut_number('domsvc')
1014 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1015 || $self->ut_textn('sec_phrase')
1016 || $self->ut_snumbern('seconds')
1017 || $self->ut_snumbern('upbytes')
1018 || $self->ut_snumbern('downbytes')
1019 || $self->ut_snumbern('totalbytes')
1020 || $self->ut_enum( '_password_encoding',
1021 [ '', qw( plain crypt ldap ) ]
1024 return $error if $error;
1027 local $username_letter = $username_letter;
1028 if ($self->svcnum) {
1029 my $cust_svc = $self->cust_svc
1030 or return "no cust_svc record found for svcnum ". $self->svcnum;
1031 my $cust_pkg = $cust_svc->cust_pkg;
1033 if ($self->pkgnum) {
1034 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1038 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1041 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1042 if ( $username_uppercase ) {
1043 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1044 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1045 $recref->{username} = $1;
1047 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1048 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1049 $recref->{username} = $1;
1052 if ( $username_letterfirst ) {
1053 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1054 } elsif ( $username_letter ) {
1055 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1057 if ( $username_noperiod ) {
1058 $recref->{username} =~ /\./ and return gettext('illegal_username');
1060 if ( $username_nounderscore ) {
1061 $recref->{username} =~ /_/ and return gettext('illegal_username');
1063 if ( $username_nodash ) {
1064 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1066 unless ( $username_ampersand ) {
1067 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1069 unless ( $username_percent ) {
1070 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1072 unless ( $username_colon ) {
1073 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1076 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1077 $recref->{popnum} = $1;
1078 return "Unknown popnum" unless
1079 ! $recref->{popnum} ||
1080 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1082 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1084 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1085 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1087 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1088 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1089 #not all systems use gid=uid
1090 #you can set a fixed gid in part_svc
1092 return "Only root can have uid 0"
1093 if $recref->{uid} == 0
1094 && $recref->{username} !~ /^(root|toor|smtp)$/;
1096 unless ( $recref->{username} eq 'sync' ) {
1097 if ( grep $_ eq $recref->{shell}, @shells ) {
1098 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1100 return "Illegal shell \`". $self->shell. "\'; ".
1101 "shells configuration value contains: @shells";
1104 $recref->{shell} = '/bin/sync';
1108 $recref->{gid} ne '' ?
1109 return "Can't have gid without uid" : ( $recref->{gid}='' );
1110 #$recref->{dir} ne '' ?
1111 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1112 $recref->{shell} ne '' ?
1113 return "Can't have shell without uid" : ( $recref->{shell}='' );
1116 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1118 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1119 or return "Illegal directory: ". $recref->{dir};
1120 $recref->{dir} = $1;
1121 return "Illegal directory"
1122 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1123 return "Illegal directory"
1124 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1125 unless ( $recref->{dir} ) {
1126 $recref->{dir} = $dir_prefix . '/';
1127 if ( $dirhash > 0 ) {
1128 for my $h ( 1 .. $dirhash ) {
1129 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1131 } elsif ( $dirhash < 0 ) {
1132 for my $h ( reverse $dirhash .. -1 ) {
1133 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1136 $recref->{dir} .= $recref->{username};
1142 # $error = $self->ut_textn('finger');
1143 # return $error if $error;
1144 if ( $self->getfield('finger') eq '' ) {
1145 my $cust_pkg = $self->svcnum
1146 ? $self->cust_svc->cust_pkg
1147 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1149 my $cust_main = $cust_pkg->cust_main;
1150 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1153 $self->getfield('finger') =~
1154 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1155 or return "Illegal finger: ". $self->getfield('finger');
1156 $self->setfield('finger', $1);
1158 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1159 $recref->{quota} = $1;
1161 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1162 if ( $recref->{slipip} eq '' ) {
1163 $recref->{slipip} = '';
1164 } elsif ( $recref->{slipip} eq '0e0' ) {
1165 $recref->{slipip} = '0e0';
1167 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1168 or return "Illegal slipip: ". $self->slipip;
1169 $recref->{slipip} = $1;
1174 #arbitrary RADIUS stuff; allow ut_textn for now
1175 foreach ( grep /^radius_/, fields('svc_acct') ) {
1176 $self->ut_textn($_);
1179 # First, if _password is blank, generate one and set default encoding.
1180 if ( ! $recref->{_password} ) {
1181 $error = $self->set_password('');
1183 # But if there's a _password but no encoding, assume it's plaintext and
1184 # set it to default encoding.
1185 elsif ( ! $recref->{_password_encoding} ) {
1186 $error = $self->set_password($recref->{_password});
1188 return $error if $error;
1190 # Next, check _password to ensure compliance with the encoding.
1191 if ( $recref->{_password_encoding} eq 'ldap' ) {
1193 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1194 $recref->{_password} = uc($1).$2;
1196 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1199 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1201 if ( $recref->{_password} =~
1202 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1203 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1206 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1209 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1212 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1213 # Password randomization is now in set_password.
1214 # Strip whitespace characters, check length requirements, etc.
1215 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1216 $recref->{_password} = $1;
1218 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1219 FS::Msgcat::_gettext('illegal_password_characters').
1220 ": ". $recref->{_password};
1223 if ( $password_noampersand ) {
1224 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1226 if ( $password_noexclamation ) {
1227 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1231 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1233 $self->SUPER::check;
1238 sub _password_encryption {
1240 my $encoding = lc($self->_password_encoding);
1241 return if !$encoding;
1242 return 'plain' if $encoding eq 'plain';
1243 if($encoding eq 'crypt') {
1244 my $pass = $self->_password;
1245 $pass =~ s/^\*SUSPENDED\* //;
1247 return 'md5' if $pass =~ /^\$1\$/;
1248 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1249 return 'des' if length($pass) == 13;
1252 if($encoding eq 'ldap') {
1253 uc($self->_password) =~ /^\{([\w-]+)\}/;
1254 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1255 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1256 return 'md5' if $1 eq 'MD5';
1257 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1264 sub get_cleartext_password {
1266 if($self->_password_encryption eq 'plain') {
1267 if($self->_password_encoding eq 'ldap') {
1268 $self->_password =~ /\{\w+\}(.*)$/;
1272 return $self->_password;
1281 Set the cleartext password for the account. If _password_encoding is set, the
1282 new password will be encoded according to the existing method (including
1283 encryption mode, if it can be determined). Otherwise,
1284 config('default-password-encoding') is used.
1286 If no password is supplied (or a zero-length password when minimum password length
1287 is >0), one will be generated randomly.
1294 my ($encoding, $encryption);
1295 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1296 FS::Msgcat::_gettext('illegal_password_characters').
1299 if(($passwordmin and length($pass) < $passwordmin) or
1300 ($passwordmax and length($pass) > $passwordmax)) {
1304 if($self->_password_encoding) {
1305 $encoding = $self->_password_encoding;
1306 # identify existing encryption method, try to use it.
1307 $encryption = $self->_password_encryption;
1309 # use the system default
1315 # set encoding to system default
1316 ($encoding, $encryption) = split(/-/, lc($conf->config('default-password-encoding')));
1317 $encoding ||= 'legacy';
1318 $self->_password_encoding($encoding);
1321 if($encoding eq 'legacy') {
1322 # The legacy behavior from check():
1323 # If the password is blank, randomize it and set encoding to 'plain'.
1324 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1325 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1326 $self->_password_encoding('plain');
1329 # Prefix + valid-length password
1330 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1332 $self->_password_encoding('plain');
1334 # Prefix + crypt string
1335 elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1337 $self->_password_encoding('crypt');
1339 # Various disabled crypt passwords
1340 elsif ( $pass eq '*' or
1343 $self->_password_encoding('crypt');
1350 elsif($encoding eq 'crypt') {
1351 if($encryption eq 'md5') {
1352 $pass = unix_md5_crypt($pass);
1354 elsif($encryption eq 'des') {
1355 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1358 elsif($encoding eq 'ldap') {
1359 if($encryption eq 'md5') {
1360 $pass = md5_base64($pass);
1362 elsif($encryption eq 'sha1') {
1363 $pass = sha1_base64($pass);
1365 elsif($encryption eq 'crypt') {
1366 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1368 # else $encryption eq 'plain', do nothing
1369 $pass = '{'.uc($encryption).'}'.$pass;
1371 # else encoding eq 'plain'
1373 $self->_password($pass);
1379 Internal function to check the username against the list of system usernames
1380 from the I<system_usernames> configuration value. Returns true if the username
1381 is listed on the system username list.
1387 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1388 $conf->config('system_usernames')
1392 =item _check_duplicate
1394 Internal method to check for duplicates usernames, username@domain pairs and
1397 If the I<global_unique-username> configuration value is set to B<username> or
1398 B<username@domain>, enforces global username or username@domain uniqueness.
1400 In all cases, check for duplicate uids and usernames or username@domain pairs
1401 per export and with identical I<svcpart> values.
1405 sub _check_duplicate {
1408 my $global_unique = $conf->config('global_unique-username') || 'none';
1409 return '' if $global_unique eq 'disabled';
1413 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1414 unless ( $part_svc ) {
1415 return 'unknown svcpart '. $self->svcpart;
1418 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1419 qsearch( 'svc_acct', { 'username' => $self->username } );
1420 return gettext('username_in_use')
1421 if $global_unique eq 'username' && @dup_user;
1423 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1424 qsearch( 'svc_acct', { 'username' => $self->username,
1425 'domsvc' => $self->domsvc } );
1426 return gettext('username_in_use')
1427 if $global_unique eq 'username@domain' && @dup_userdomain;
1430 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1431 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1432 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1433 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1438 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1439 my $exports = FS::part_export::export_info('svc_acct');
1440 my %conflict_user_svcpart;
1441 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1443 foreach my $part_export ( $part_svc->part_export ) {
1445 #this will catch to the same exact export
1446 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1448 #this will catch to exports w/same exporthost+type ???
1449 #my @other_part_export = qsearch('part_export', {
1450 # 'machine' => $part_export->machine,
1451 # 'exporttype' => $part_export->exporttype,
1453 #foreach my $other_part_export ( @other_part_export ) {
1454 # push @svcparts, map { $_->svcpart }
1455 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1458 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1459 #silly kludge to avoid uninitialized value errors
1460 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1461 ? $exports->{$part_export->exporttype}{'nodomain'}
1463 if ( $nodomain =~ /^Y/i ) {
1464 $conflict_user_svcpart{$_} = $part_export->exportnum
1467 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1472 foreach my $dup_user ( @dup_user ) {
1473 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1474 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1475 return "duplicate username ". $self->username.
1476 ": conflicts with svcnum ". $dup_user->svcnum.
1477 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1481 foreach my $dup_userdomain ( @dup_userdomain ) {
1482 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1483 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1484 return "duplicate username\@domain ". $self->email.
1485 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1486 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1490 foreach my $dup_uid ( @dup_uid ) {
1491 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1492 if ( exists($conflict_user_svcpart{$dup_svcpart})
1493 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1494 return "duplicate uid ". $self->uid.
1495 ": conflicts with svcnum ". $dup_uid->svcnum.
1497 ( $conflict_user_svcpart{$dup_svcpart}
1498 || $conflict_userdomain_svcpart{$dup_svcpart} );
1510 Depriciated, use radius_reply instead.
1515 carp "FS::svc_acct::radius depriciated, use radius_reply";
1516 $_[0]->radius_reply;
1521 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1522 reply attributes of this record.
1524 Note that this is now the preferred method for reading RADIUS attributes -
1525 accessing the columns directly is discouraged, as the column names are
1526 expected to change in the future.
1533 return %{ $self->{'radius_reply'} }
1534 if exists $self->{'radius_reply'};
1539 my($column, $attrib) = ($1, $2);
1540 #$attrib =~ s/_/\-/g;
1541 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1542 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1544 if ( $self->slipip && $self->slipip ne '0e0' ) {
1545 $reply{$radius_ip} = $self->slipip;
1548 if ( $self->seconds !~ /^$/ ) {
1549 $reply{'Session-Timeout'} = $self->seconds;
1552 if ( $conf->exists('radius-chillispot-max') ) {
1553 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1555 #hmm. just because sqlradius.pm says so?
1562 foreach my $what (qw( input output total )) {
1563 my $is = $whatis{$what}.'bytes';
1564 if ( $self->$is() =~ /\d/ ) {
1565 my $big = new Math::BigInt $self->$is();
1566 $big = new Math::BigInt '0' if $big->is_neg();
1567 my $att = "Chillispot-Max-\u$what";
1568 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1569 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1580 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1581 check attributes of this record.
1583 Note that this is now the preferred method for reading RADIUS attributes -
1584 accessing the columns directly is discouraged, as the column names are
1585 expected to change in the future.
1592 return %{ $self->{'radius_check'} }
1593 if exists $self->{'radius_check'};
1598 my($column, $attrib) = ($1, $2);
1599 #$attrib =~ s/_/\-/g;
1600 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1601 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1604 my($pw_attrib, $password) = $self->radius_password;
1605 $check{$pw_attrib} = $password;
1607 my $cust_svc = $self->cust_svc;
1609 my $cust_pkg = $cust_svc->cust_pkg;
1610 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1611 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1614 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1615 "; can't set Expiration\n"
1623 =item radius_password
1625 Returns a key/value pair containing the RADIUS attribute name and value
1630 sub radius_password {
1633 my($pw_attrib, $password);
1634 if ( $self->_password_encoding eq 'ldap' ) {
1636 $pw_attrib = 'Password-With-Header';
1637 $password = $self->_password;
1639 } elsif ( $self->_password_encoding eq 'crypt' ) {
1641 $pw_attrib = 'Crypt-Password';
1642 $password = $self->_password;
1644 } elsif ( $self->_password_encoding eq 'plain' ) {
1646 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1647 $password = $self->_password;
1651 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1652 $password = $self->_password;
1656 ($pw_attrib, $password);
1662 This method instructs the object to "snapshot" or freeze RADIUS check and
1663 reply attributes to the current values.
1667 #bah, my english is too broken this morning
1668 #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
1669 #the FS::cust_pkg's replace method to trigger the correct export updates when
1670 #package dates change)
1675 $self->{$_} = { $self->$_() }
1676 foreach qw( radius_reply radius_check );
1680 =item forget_snapshot
1682 This methos instructs the object to forget any previously snapshotted
1683 RADIUS check and reply attributes.
1687 sub forget_snapshot {
1691 foreach qw( radius_reply radius_check );
1695 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1697 Returns the domain associated with this account.
1699 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1706 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1707 my $svc_domain = $self->svc_domain(@_)
1708 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1709 $svc_domain->domain;
1714 Returns the FS::svc_domain record for this account's domain (see
1719 # FS::h_svc_acct has a history-aware svc_domain override
1724 ? $self->{'_domsvc'}
1725 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1730 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1734 #inherited from svc_Common
1736 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1738 Returns an email address associated with the account.
1740 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1747 $self->username. '@'. $self->domain(@_);
1752 Returns an array of FS::acct_snarf records associated with the account.
1753 If the acct_snarf table does not exist or there are no associated records,
1754 an empty list is returned
1760 return () unless dbdef->table('acct_snarf');
1761 eval "use FS::acct_snarf;";
1763 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1766 =item decrement_upbytes OCTETS
1768 Decrements the I<upbytes> field of this record by the given amount. If there
1769 is an error, returns the error, otherwise returns false.
1773 sub decrement_upbytes {
1774 shift->_op_usage('-', 'upbytes', @_);
1777 =item increment_upbytes OCTETS
1779 Increments the I<upbytes> field of this record by the given amount. If there
1780 is an error, returns the error, otherwise returns false.
1784 sub increment_upbytes {
1785 shift->_op_usage('+', 'upbytes', @_);
1788 =item decrement_downbytes OCTETS
1790 Decrements the I<downbytes> field of this record by the given amount. If there
1791 is an error, returns the error, otherwise returns false.
1795 sub decrement_downbytes {
1796 shift->_op_usage('-', 'downbytes', @_);
1799 =item increment_downbytes OCTETS
1801 Increments the I<downbytes> field of this record by the given amount. If there
1802 is an error, returns the error, otherwise returns false.
1806 sub increment_downbytes {
1807 shift->_op_usage('+', 'downbytes', @_);
1810 =item decrement_totalbytes OCTETS
1812 Decrements the I<totalbytes> field of this record by the given amount. If there
1813 is an error, returns the error, otherwise returns false.
1817 sub decrement_totalbytes {
1818 shift->_op_usage('-', 'totalbytes', @_);
1821 =item increment_totalbytes OCTETS
1823 Increments the I<totalbytes> field of this record by the given amount. If there
1824 is an error, returns the error, otherwise returns false.
1828 sub increment_totalbytes {
1829 shift->_op_usage('+', 'totalbytes', @_);
1832 =item decrement_seconds SECONDS
1834 Decrements the I<seconds> field of this record by the given amount. If there
1835 is an error, returns the error, otherwise returns false.
1839 sub decrement_seconds {
1840 shift->_op_usage('-', 'seconds', @_);
1843 =item increment_seconds SECONDS
1845 Increments the I<seconds> field of this record by the given amount. If there
1846 is an error, returns the error, otherwise returns false.
1850 sub increment_seconds {
1851 shift->_op_usage('+', 'seconds', @_);
1859 my %op2condition = (
1860 '-' => sub { my($self, $column, $amount) = @_;
1861 $self->$column - $amount <= 0;
1863 '+' => sub { my($self, $column, $amount) = @_;
1864 ($self->$column || 0) + $amount > 0;
1867 my %op2warncondition = (
1868 '-' => sub { my($self, $column, $amount) = @_;
1869 my $threshold = $column . '_threshold';
1870 $self->$column - $amount <= $self->$threshold + 0;
1872 '+' => sub { my($self, $column, $amount) = @_;
1873 ($self->$column || 0) + $amount > 0;
1878 my( $self, $op, $column, $amount ) = @_;
1880 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1881 ' ('. $self->email. "): $op $amount\n"
1884 return '' unless $amount;
1886 local $SIG{HUP} = 'IGNORE';
1887 local $SIG{INT} = 'IGNORE';
1888 local $SIG{QUIT} = 'IGNORE';
1889 local $SIG{TERM} = 'IGNORE';
1890 local $SIG{TSTP} = 'IGNORE';
1891 local $SIG{PIPE} = 'IGNORE';
1893 my $oldAutoCommit = $FS::UID::AutoCommit;
1894 local $FS::UID::AutoCommit = 0;
1897 my $sql = "UPDATE svc_acct SET $column = ".
1898 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1899 " $op ? WHERE svcnum = ?";
1903 my $sth = $dbh->prepare( $sql )
1904 or die "Error preparing $sql: ". $dbh->errstr;
1905 my $rv = $sth->execute($amount, $self->svcnum);
1906 die "Error executing $sql: ". $sth->errstr
1907 unless defined($rv);
1908 die "Can't update $column for svcnum". $self->svcnum
1911 #$self->snapshot; #not necessary, we retain the old values
1912 #create an object with the updated usage values
1913 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1915 my $error = $new->replace($self);
1917 $dbh->rollback if $oldAutoCommit;
1918 return "Error replacing: $error";
1921 #overlimit_action eq 'cancel' handling
1922 my $cust_pkg = $self->cust_svc->cust_pkg;
1924 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1925 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1929 my $error = $cust_pkg->cancel; #XXX should have a reason
1931 $dbh->rollback if $oldAutoCommit;
1932 return "Error cancelling: $error";
1935 #nothing else is relevant if we're cancelling, so commit & return success
1936 warn "$me update successful; committing\n"
1938 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1943 my $action = $op2action{$op};
1945 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1946 ( $action eq 'suspend' && !$self->overlimit
1947 || $action eq 'unsuspend' && $self->overlimit )
1950 my $error = $self->_op_overlimit($action);
1952 $dbh->rollback if $oldAutoCommit;
1958 if ( $conf->exists("svc_acct-usage_$action")
1959 && &{$op2condition{$op}}($self, $column, $amount) ) {
1960 #my $error = $self->$action();
1961 my $error = $self->cust_svc->cust_pkg->$action();
1962 # $error ||= $self->overlimit($action);
1964 $dbh->rollback if $oldAutoCommit;
1965 return "Error ${action}ing: $error";
1969 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1970 my $wqueue = new FS::queue {
1971 'svcnum' => $self->svcnum,
1972 'job' => 'FS::svc_acct::reached_threshold',
1977 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1981 my $error = $wqueue->insert(
1982 'svcnum' => $self->svcnum,
1984 'column' => $column,
1988 $dbh->rollback if $oldAutoCommit;
1989 return "Error queuing threshold activity: $error";
1993 warn "$me update successful; committing\n"
1995 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2001 my( $self, $action ) = @_;
2003 local $SIG{HUP} = 'IGNORE';
2004 local $SIG{INT} = 'IGNORE';
2005 local $SIG{QUIT} = 'IGNORE';
2006 local $SIG{TERM} = 'IGNORE';
2007 local $SIG{TSTP} = 'IGNORE';
2008 local $SIG{PIPE} = 'IGNORE';
2010 my $oldAutoCommit = $FS::UID::AutoCommit;
2011 local $FS::UID::AutoCommit = 0;
2014 my $cust_pkg = $self->cust_svc->cust_pkg;
2016 my $conf_overlimit =
2018 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2019 : $conf->config('overlimit_groups');
2021 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2023 my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2024 next unless $groups;
2026 my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2028 my $other = new FS::svc_acct $self->hashref;
2029 $other->usergroup( $gref );
2032 if ($action eq 'suspend') {
2035 } else { # $action eq 'unsuspend'
2040 my $error = $part_export->export_replace($new, $old)
2041 || $self->overlimit($action);
2044 $dbh->rollback if $oldAutoCommit;
2045 return "Error replacing radius groups: $error";
2050 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2056 my( $self, $valueref, %options ) = @_;
2058 warn "$me set_usage called for svcnum ". $self->svcnum.
2059 ' ('. $self->email. "): ".
2060 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2063 local $SIG{HUP} = 'IGNORE';
2064 local $SIG{INT} = 'IGNORE';
2065 local $SIG{QUIT} = 'IGNORE';
2066 local $SIG{TERM} = 'IGNORE';
2067 local $SIG{TSTP} = 'IGNORE';
2068 local $SIG{PIPE} = 'IGNORE';
2070 local $FS::svc_Common::noexport_hack = 1;
2071 my $oldAutoCommit = $FS::UID::AutoCommit;
2072 local $FS::UID::AutoCommit = 0;
2077 if ( $options{null} ) {
2078 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2079 qw( seconds upbytes downbytes totalbytes )
2082 foreach my $field (keys %$valueref){
2083 $reset = 1 if $valueref->{$field};
2084 $self->setfield($field, $valueref->{$field});
2085 $self->setfield( $field.'_threshold',
2086 int($self->getfield($field)
2087 * ( $conf->exists('svc_acct-usage_threshold')
2088 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2093 $handyhash{$field} = $self->getfield($field);
2094 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2096 #my $error = $self->replace; #NO! we avoid the call to ->check for
2097 #die $error if $error; #services not explicity changed via the UI
2099 my $sql = "UPDATE svc_acct SET " .
2100 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
2101 " WHERE svcnum = ". $self->svcnum;
2106 if (scalar(keys %handyhash)) {
2107 my $sth = $dbh->prepare( $sql )
2108 or die "Error preparing $sql: ". $dbh->errstr;
2109 my $rv = $sth->execute();
2110 die "Error executing $sql: ". $sth->errstr
2111 unless defined($rv);
2112 die "Can't update usage for svcnum ". $self->svcnum
2116 #$self->snapshot; #not necessary, we retain the old values
2117 #create an object with the updated usage values
2118 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2119 local($FS::Record::nowarn_identical) = 1;
2120 my $error = $new->replace($self); #call exports
2122 $dbh->rollback if $oldAutoCommit;
2123 return "Error replacing: $error";
2130 $error = $self->_op_overlimit('unsuspend')
2131 if $self->overlimit;;
2133 $error ||= $self->cust_svc->cust_pkg->unsuspend
2134 if $conf->exists("svc_acct-usage_unsuspend");
2137 $dbh->rollback if $oldAutoCommit;
2138 return "Error unsuspending: $error";
2143 warn "$me update successful; committing\n"
2145 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2151 =item recharge HASHREF
2153 Increments usage columns by the amount specified in HASHREF as
2154 column=>amount pairs.
2159 my ($self, $vhash) = @_;
2162 warn "[$me] recharge called on $self: ". Dumper($self).
2163 "\nwith vhash: ". Dumper($vhash);
2166 my $oldAutoCommit = $FS::UID::AutoCommit;
2167 local $FS::UID::AutoCommit = 0;
2171 foreach my $column (keys %$vhash){
2172 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2176 $dbh->rollback if $oldAutoCommit;
2178 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2183 =item is_rechargeable
2185 Returns true if this svc_account can be "recharged" and false otherwise.
2189 sub is_rechargable {
2191 $self->seconds ne ''
2192 || $self->upbytes ne ''
2193 || $self->downbytes ne ''
2194 || $self->totalbytes ne '';
2197 =item seconds_since TIMESTAMP
2199 Returns the number of seconds this account has been online since TIMESTAMP,
2200 according to the session monitor (see L<FS::Session>).
2202 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2203 L<Time::Local> and L<Date::Parse> for conversion functions.
2207 #note: POD here, implementation in FS::cust_svc
2210 $self->cust_svc->seconds_since(@_);
2213 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2215 Returns the numbers of seconds this account has been online between
2216 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2217 external SQL radacct table, specified via sqlradius export. Sessions which
2218 started in the specified range but are still open are counted from session
2219 start to the end of the range (unless they are over 1 day old, in which case
2220 they are presumed missing their stop record and not counted). Also, sessions
2221 which end in the range but started earlier are counted from the start of the
2222 range to session end. Finally, sessions which start before the range but end
2223 after are counted for the entire range.
2225 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2226 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2231 #note: POD here, implementation in FS::cust_svc
2232 sub seconds_since_sqlradacct {
2234 $self->cust_svc->seconds_since_sqlradacct(@_);
2237 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2239 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2240 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2241 TIMESTAMP_END (exclusive).
2243 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2244 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2249 #note: POD here, implementation in FS::cust_svc
2250 sub attribute_since_sqlradacct {
2252 $self->cust_svc->attribute_since_sqlradacct(@_);
2255 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2257 Returns an array of hash references of this customers login history for the
2258 given time range. (document this better)
2262 sub get_session_history {
2264 $self->cust_svc->get_session_history(@_);
2267 =item last_login_text
2269 Returns text describing the time of last login.
2273 sub last_login_text {
2275 $self->last_login ? ctime($self->last_login) : 'unknown';
2278 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2283 my($self, $start, $end, %opt ) = @_;
2285 my $did = $self->username; #yup
2287 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2289 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2291 #SELECT $for_update * FROM cdr
2292 # WHERE calldate >= $start #need a conversion
2293 # AND calldate < $end #ditto
2294 # AND ( charged_party = "$did"
2295 # OR charged_party = "$prefix$did" #if length($prefix);
2296 # OR ( ( charged_party IS NULL OR charged_party = '' )
2298 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2301 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2304 if ( length($prefix) ) {
2306 " AND ( charged_party = '$did'
2307 OR charged_party = '$prefix$did'
2308 OR ( ( charged_party IS NULL OR charged_party = '' )
2310 ( src = '$did' OR src = '$prefix$did' )
2316 " AND ( charged_party = '$did'
2317 OR ( ( charged_party IS NULL OR charged_party = '' )
2327 'select' => "$for_update *",
2330 #( freesidestatus IS NULL OR freesidestatus = '' )
2331 'freesidestatus' => '',
2333 'extra_sql' => $charged_or_src,
2341 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2347 if ( $self->usergroup ) {
2348 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2349 unless ref($self->usergroup) eq 'ARRAY';
2350 #when provisioning records, export callback runs in svc_Common.pm before
2351 #radius_usergroup records can be inserted...
2352 @{$self->usergroup};
2354 map { $_->groupname }
2355 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2359 =item clone_suspended
2361 Constructor used by FS::part_export::_export_suspend fallback. Document
2366 sub clone_suspended {
2368 my %hash = $self->hash;
2369 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2370 new FS::svc_acct \%hash;
2373 =item clone_kludge_unsuspend
2375 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2380 sub clone_kludge_unsuspend {
2382 my %hash = $self->hash;
2383 $hash{_password} = '';
2384 new FS::svc_acct \%hash;
2387 =item check_password
2389 Checks the supplied password against the (possibly encrypted) password in the
2390 database. Returns true for a successful authentication, false for no match.
2392 Currently supported encryptions are: classic DES crypt() and MD5
2396 sub check_password {
2397 my($self, $check_password) = @_;
2399 #remove old-style SUSPENDED kludge, they should be allowed to login to
2400 #self-service and pay up
2401 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2403 if ( $self->_password_encoding eq 'ldap' ) {
2405 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2406 return $auth->match($check_password);
2408 } elsif ( $self->_password_encoding eq 'crypt' ) {
2410 my $auth = from_crypt Authen::Passphrase $self->_password;
2411 return $auth->match($check_password);
2413 } elsif ( $self->_password_encoding eq 'plain' ) {
2415 return $check_password eq $password;
2419 #XXX this could be replaced with Authen::Passphrase stuff
2421 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2423 } elsif ( length($password) < 13 ) { #plaintext
2424 $check_password eq $password;
2425 } elsif ( length($password) == 13 ) { #traditional DES crypt
2426 crypt($check_password, $password) eq $password;
2427 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2428 unix_md5_crypt($check_password, $password) eq $password;
2429 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2430 warn "Can't check password: Blowfish encryption not yet supported, ".
2431 "svcnum ". $self->svcnum. "\n";
2434 warn "Can't check password: Unrecognized encryption for svcnum ".
2435 $self->svcnum. "\n";
2443 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2445 Returns an encrypted password, either by passing through an encrypted password
2446 in the database or by encrypting a plaintext password from the database.
2448 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2449 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2450 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2451 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2452 encryption type is only used if the password is not already encrypted in the
2457 sub crypt_password {
2460 if ( $self->_password_encoding eq 'ldap' ) {
2462 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2465 #XXX this could be replaced with Authen::Passphrase stuff
2467 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2468 if ( $encryption eq 'crypt' ) {
2471 $saltset[int(rand(64))].$saltset[int(rand(64))]
2473 } elsif ( $encryption eq 'md5' ) {
2474 unix_md5_crypt( $self->_password );
2475 } elsif ( $encryption eq 'blowfish' ) {
2476 croak "unknown encryption method $encryption";
2478 croak "unknown encryption method $encryption";
2481 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2485 } elsif ( $self->_password_encoding eq 'crypt' ) {
2487 return $self->_password;
2489 } elsif ( $self->_password_encoding eq 'plain' ) {
2491 #XXX this could be replaced with Authen::Passphrase stuff
2493 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2494 if ( $encryption eq 'crypt' ) {
2497 $saltset[int(rand(64))].$saltset[int(rand(64))]
2499 } elsif ( $encryption eq 'md5' ) {
2500 unix_md5_crypt( $self->_password );
2501 } elsif ( $encryption eq 'blowfish' ) {
2502 croak "unknown encryption method $encryption";
2504 croak "unknown encryption method $encryption";
2509 if ( length($self->_password) == 13
2510 || $self->_password =~ /^\$(1|2a?)\$/
2511 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2517 #XXX this could be replaced with Authen::Passphrase stuff
2519 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2520 if ( $encryption eq 'crypt' ) {
2523 $saltset[int(rand(64))].$saltset[int(rand(64))]
2525 } elsif ( $encryption eq 'md5' ) {
2526 unix_md5_crypt( $self->_password );
2527 } elsif ( $encryption eq 'blowfish' ) {
2528 croak "unknown encryption method $encryption";
2530 croak "unknown encryption method $encryption";
2539 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2541 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2542 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2543 "{MD5}5426824942db4253f87a1009fd5d2d4".
2545 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2546 to work the same as the B</crypt_password> method.
2552 #eventually should check a "password-encoding" field
2554 if ( $self->_password_encoding eq 'ldap' ) {
2556 return $self->_password;
2558 } elsif ( $self->_password_encoding eq 'crypt' ) {
2560 if ( length($self->_password) == 13 ) { #crypt
2561 return '{CRYPT}'. $self->_password;
2562 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2564 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2565 # die "Blowfish encryption not supported in this context, svcnum ".
2566 # $self->svcnum. "\n";
2568 warn "encryption method not (yet?) supported in LDAP context";
2569 return '{CRYPT}*'; #unsupported, should not auth
2572 } elsif ( $self->_password_encoding eq 'plain' ) {
2574 return '{PLAIN}'. $self->_password;
2576 #return '{CLEARTEXT}'. $self->_password; #?
2580 if ( length($self->_password) == 13 ) { #crypt
2581 return '{CRYPT}'. $self->_password;
2582 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2584 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2585 warn "Blowfish encryption not supported in this context, svcnum ".
2586 $self->svcnum. "\n";
2589 #are these two necessary anymore?
2590 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2591 return '{SSHA}'. $1;
2592 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2593 return '{NS-MTA-MD5}'. $1;
2596 return '{PLAIN}'. $self->_password;
2598 #return '{CLEARTEXT}'. $self->_password; #?
2600 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2601 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2602 #if ( $encryption eq 'crypt' ) {
2603 # return '{CRYPT}'. crypt(
2605 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2607 #} elsif ( $encryption eq 'md5' ) {
2608 # unix_md5_crypt( $self->_password );
2609 #} elsif ( $encryption eq 'blowfish' ) {
2610 # croak "unknown encryption method $encryption";
2612 # croak "unknown encryption method $encryption";
2620 =item domain_slash_username
2622 Returns $domain/$username/
2626 sub domain_slash_username {
2628 $self->domain. '/'. $self->username. '/';
2631 =item virtual_maildir
2633 Returns $domain/maildirs/$username/
2637 sub virtual_maildir {
2639 $self->domain. '/maildirs/'. $self->username. '/';
2644 =head1 CLASS METHODS
2648 =item search HASHREF
2650 Class method which returns a qsearch hash expression to search for parameters
2651 specified in HASHREF. Valid parameters are
2665 Arrayref of pkgparts
2671 Arrayref of additional WHERE clauses, will be ANDed together.
2682 my ($class, $params) = @_;
2687 if ( $params->{'domain'} ) {
2688 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2689 #preserve previous behavior & bubble up an error if $svc_domain not found?
2690 push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2694 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2695 push @where, "domsvc = $1";
2699 push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2702 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2703 push @where, "agentnum = $1";
2707 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2708 push @where, "custnum = $1";
2712 if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2713 #XXX untaint or sql quote
2715 'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2719 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2720 push @where, "popnum = $1";
2724 if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2725 push @where, "svcpart = $1";
2729 # here is the agent virtualization
2730 #if ($params->{CurrentUser}) {
2732 # qsearchs('access_user', { username => $params->{CurrentUser} });
2734 # if ($access_user) {
2735 # push @where, $access_user->agentnums_sql('table'=>'cust_main');
2737 # push @where, "1=0";
2740 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2741 'table' => 'cust_main',
2742 'null_right' => 'View/link unlinked services',
2746 push @where, @{ $params->{'where'} } if $params->{'where'};
2748 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2750 my $addl_from = ' LEFT JOIN cust_svc USING ( svcnum ) '.
2751 ' LEFT JOIN part_svc USING ( svcpart ) '.
2752 ' LEFT JOIN cust_pkg USING ( pkgnum ) '.
2753 ' LEFT JOIN cust_main USING ( custnum ) ';
2755 my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2756 #if ( keys %svc_acct ) {
2757 # $count_query .= ' WHERE '.
2758 # join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2764 'table' => 'svc_acct',
2765 'hashref' => {}, # \%svc_acct,
2766 'select' => join(', ',
2769 'cust_main.custnum',
2770 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2772 'addl_from' => $addl_from,
2773 'extra_sql' => $extra_sql,
2774 'order_by' => $params->{'order_by'},
2775 'count_query' => $count_query,
2788 This is the FS::svc_acct job-queue-able version. It still uses
2789 FS::Misc::send_email under-the-hood.
2796 eval "use FS::Misc qw(send_email)";
2799 $opt{mimetype} ||= 'text/plain';
2800 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2802 my $error = send_email(
2803 'from' => $opt{from},
2805 'subject' => $opt{subject},
2806 'content-type' => $opt{mimetype},
2807 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2809 die $error if $error;
2812 =item check_and_rebuild_fuzzyfiles
2816 sub check_and_rebuild_fuzzyfiles {
2817 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2818 -e "$dir/svc_acct.username"
2819 or &rebuild_fuzzyfiles;
2822 =item rebuild_fuzzyfiles
2826 sub rebuild_fuzzyfiles {
2828 use Fcntl qw(:flock);
2830 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2834 open(USERNAMELOCK,">>$dir/svc_acct.username")
2835 or die "can't open $dir/svc_acct.username: $!";
2836 flock(USERNAMELOCK,LOCK_EX)
2837 or die "can't lock $dir/svc_acct.username: $!";
2839 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2841 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2842 or die "can't open $dir/svc_acct.username.tmp: $!";
2843 print USERNAMECACHE join("\n", @all_username), "\n";
2844 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2846 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2856 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2857 open(USERNAMECACHE,"<$dir/svc_acct.username")
2858 or die "can't open $dir/svc_acct.username: $!";
2859 my @array = map { chomp; $_; } <USERNAMECACHE>;
2860 close USERNAMECACHE;
2864 =item append_fuzzyfiles USERNAME
2868 sub append_fuzzyfiles {
2869 my $username = shift;
2871 &check_and_rebuild_fuzzyfiles;
2873 use Fcntl qw(:flock);
2875 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2877 open(USERNAME,">>$dir/svc_acct.username")
2878 or die "can't open $dir/svc_acct.username: $!";
2879 flock(USERNAME,LOCK_EX)
2880 or die "can't lock $dir/svc_acct.username: $!";
2882 print USERNAME "$username\n";
2884 flock(USERNAME,LOCK_UN)
2885 or die "can't unlock $dir/svc_acct.username: $!";
2893 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2897 sub radius_usergroup_selector {
2898 my $sel_groups = shift;
2899 my %sel_groups = map { $_=>1 } @$sel_groups;
2901 my $selectname = shift || 'radius_usergroup';
2904 my $sth = $dbh->prepare(
2905 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2906 ) or die $dbh->errstr;
2907 $sth->execute() or die $sth->errstr;
2908 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2912 function ${selectname}_doadd(object) {
2913 var myvalue = object.${selectname}_add.value;
2914 var optionName = new Option(myvalue,myvalue,false,true);
2915 var length = object.$selectname.length;
2916 object.$selectname.options[length] = optionName;
2917 object.${selectname}_add.value = "";
2920 <SELECT MULTIPLE NAME="$selectname">
2923 foreach my $group ( @all_groups ) {
2924 $html .= qq(<OPTION VALUE="$group");
2925 if ( $sel_groups{$group} ) {
2926 $html .= ' SELECTED';
2927 $sel_groups{$group} = 0;
2929 $html .= ">$group</OPTION>\n";
2931 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2932 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2934 $html .= '</SELECT>';
2936 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2937 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2942 =item reached_threshold
2944 Performs some activities when svc_acct thresholds (such as number of seconds
2945 remaining) are reached.
2949 sub reached_threshold {
2952 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2953 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2955 if ( $opt{'op'} eq '+' ){
2956 $svc_acct->setfield( $opt{'column'}.'_threshold',
2957 int($svc_acct->getfield($opt{'column'})
2958 * ( $conf->exists('svc_acct-usage_threshold')
2959 ? $conf->config('svc_acct-usage_threshold')/100
2964 my $error = $svc_acct->replace;
2965 die $error if $error;
2966 }elsif ( $opt{'op'} eq '-' ){
2968 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2969 return '' if ($threshold eq '' );
2971 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2972 my $error = $svc_acct->replace;
2973 die $error if $error; # email next time, i guess
2975 if ( $warning_template ) {
2976 eval "use FS::Misc qw(send_email)";
2979 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2980 my $cust_main = $cust_pkg->cust_main;
2982 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2983 $cust_main->invoicing_list,
2984 ($opt{'to'} ? $opt{'to'} : ())
2987 my $mimetype = $warning_mimetype;
2988 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2990 my $body = $warning_template->fill_in( HASH => {
2991 'custnum' => $cust_main->custnum,
2992 'username' => $svc_acct->username,
2993 'password' => $svc_acct->_password,
2994 'first' => $cust_main->first,
2995 'last' => $cust_main->getfield('last'),
2996 'pkg' => $cust_pkg->part_pkg->pkg,
2997 'column' => $opt{'column'},
2998 'amount' => $opt{'column'} =~/bytes/
2999 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3000 : $svc_acct->getfield($opt{'column'}),
3001 'threshold' => $opt{'column'} =~/bytes/
3002 ? FS::UI::bytecount::display_bytecount($threshold)
3007 my $error = send_email(
3008 'from' => $warning_from,
3010 'subject' => $warning_subject,
3011 'content-type' => $mimetype,
3012 'body' => [ map "$_\n", split("\n", $body) ],
3014 die $error if $error;
3017 die "unknown op: " . $opt{'op'};
3025 The $recref stuff in sub check should be cleaned up.
3027 The suspend, unsuspend and cancel methods update the database, but not the
3028 current object. This is probably a bug as it's unexpected and
3031 radius_usergroup_selector? putting web ui components in here? they should
3032 probably live somewhere else...
3034 insertion of RADIUS group stuff in insert could be done with child_objects now
3035 (would probably clean up export of them too)
3037 _op_usage and set_usage bypass the history... maybe they shouldn't
3041 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3042 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3043 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3044 L<freeside-queued>), L<FS::svc_acct_pop>,
3045 schema.html from the base documentation.
3049 =item domain_select_hash %OPTIONS
3051 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
3052 may at present purchase.
3054 Currently available options are: I<pkgnum> I<svcpart>
3058 sub domain_select_hash {
3059 my ($self, %options) = @_;
3065 $part_svc = $self->part_svc;
3066 $cust_pkg = $self->cust_svc->cust_pkg
3070 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
3071 if $options{'svcpart'};
3073 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
3074 if $options{'pkgnum'};
3076 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
3077 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
3078 %domains = map { $_->svcnum => $_->domain }
3079 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
3080 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
3081 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
3082 %domains = map { $_->svcnum => $_->domain }
3083 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
3084 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
3085 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
3087 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
3090 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
3091 my $svc_domain = qsearchs('svc_domain',
3092 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
3093 if ( $svc_domain ) {
3094 $domains{$svc_domain->svcnum} = $svc_domain->domain;
3096 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
3097 $part_svc->part_svc_column('domsvc')->columnvalue;