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
10 $password_noampersand $password_noexclamation
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
12 $warning_template $warning_from $warning_subject $warning_mimetype
15 $radius_password $radius_ip
21 use Crypt::PasswdMD5 1.2;
23 use FS::UID qw( datasrc );
25 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
26 use FS::Msgcat qw(gettext);
31 use FS::cust_main_invoice;
35 use FS::radius_usergroup;
42 @ISA = qw( FS::svc_Common );
45 $me = '[FS::svc_acct]';
47 #ask FS::UID to run this stuff for us later
48 $FS::UID::callback{'FS::svc_acct'} = sub {
50 $dir_prefix = $conf->config('home');
51 @shells = $conf->config('shells');
52 $usernamemin = $conf->config('usernamemin') || 2;
53 $usernamemax = $conf->config('usernamemax');
54 $passwordmin = $conf->config('passwordmin') || 6;
55 $passwordmax = $conf->config('passwordmax') || 8;
56 $username_letter = $conf->exists('username-letter');
57 $username_letterfirst = $conf->exists('username-letterfirst');
58 $username_noperiod = $conf->exists('username-noperiod');
59 $username_nounderscore = $conf->exists('username-nounderscore');
60 $username_nodash = $conf->exists('username-nodash');
61 $username_uppercase = $conf->exists('username-uppercase');
62 $username_ampersand = $conf->exists('username-ampersand');
63 $username_percent = $conf->exists('username-percent');
64 $password_noampersand = $conf->exists('password-noexclamation');
65 $password_noexclamation = $conf->exists('password-noexclamation');
66 $dirhash = $conf->config('dirhash') || 0;
67 if ( $conf->exists('welcome_email') ) {
68 $welcome_template = new Text::Template (
70 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
71 ) or warn "can't create welcome email template: $Text::Template::ERROR";
72 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
73 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
74 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
76 $welcome_template = '';
78 $welcome_subject = '';
79 $welcome_mimetype = '';
81 if ( $conf->exists('warning_email') ) {
82 $warning_template = new Text::Template (
84 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
85 ) or warn "can't create warning email template: $Text::Template::ERROR";
86 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
87 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
88 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
89 $warning_cc = $conf->config('warning_email-cc');
91 $warning_template = '';
93 $warning_subject = '';
94 $warning_mimetype = '';
97 $smtpmachine = $conf->config('smtpmachine');
98 $radius_password = $conf->config('radius-password') || 'Password';
99 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
102 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
103 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
107 my ( $hashref, $cache ) = @_;
108 if ( $hashref->{'svc_acct_svcnum'} ) {
109 $self->{'_domsvc'} = FS::svc_domain->new( {
110 'svcnum' => $hashref->{'domsvc'},
111 'domain' => $hashref->{'svc_acct_domain'},
112 'catchall' => $hashref->{'svc_acct_catchall'},
119 FS::svc_acct - Object methods for svc_acct records
125 $record = new FS::svc_acct \%hash;
126 $record = new FS::svc_acct { 'column' => 'value' };
128 $error = $record->insert;
130 $error = $new_record->replace($old_record);
132 $error = $record->delete;
134 $error = $record->check;
136 $error = $record->suspend;
138 $error = $record->unsuspend;
140 $error = $record->cancel;
142 %hash = $record->radius;
144 %hash = $record->radius_reply;
146 %hash = $record->radius_check;
148 $domain = $record->domain;
150 $svc_domain = $record->svc_domain;
152 $email = $record->email;
154 $seconds_since = $record->seconds_since($timestamp);
158 An FS::svc_acct object represents an account. FS::svc_acct inherits from
159 FS::svc_Common. The following fields are currently supported:
163 =item svcnum - primary key (assigned automatcially for new accounts)
167 =item _password - generated if blank
169 =item sec_phrase - security phrase
171 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
179 =item dir - set automatically if blank (and uid is not)
183 =item quota - (unimplementd)
185 =item slipip - IP address
195 =item domsvc - svcnum from svc_domain
197 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
199 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
209 Creates a new account. To add the account to the database, see L<"insert">.
216 'longname_plural' => 'Access accounts and mailboxes',
217 'sorts' => [ 'username', 'uid', ],
218 'display_weight' => 10,
219 'cancel_weight' => 50,
221 'dir' => 'Home directory',
224 def_label => 'UID (set to fixed and blank for no UIDs)',
227 'slipip' => 'IP address',
228 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
230 label => 'Access number',
232 select_table => 'svc_acct_pop',
233 select_key => 'popnum',
234 select_label => 'city',
239 disable_default => 1,
245 disable_inventory => 1,
247 '_password' => 'Password',
250 def_label => 'GID (when blank, defaults to UID)',
254 #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
256 def_label=> 'Shell (set to blank for no shell tracking)',
258 select_list => [ $conf->config('shells') ],
259 disable_inventory => 1,
261 'finger' => 'Real name (GECOS)',
264 def_label => 'svcnum from svc_domain',
266 select_table => 'svc_domain',
267 select_key => 'svcnum',
268 select_label => 'domain',
269 disable_inventory => 1,
272 label => 'RADIUS groups',
273 type => 'radius_usergroup_selector',
274 disable_inventory => 1,
277 'seconds' => { label => 'Seconds',
279 disable_inventory => 1,
285 sub table { 'svc_acct'; }
289 #false laziness with edit/svc_acct.cgi
291 my( $self, $groups ) = @_;
292 if ( ref($groups) eq 'ARRAY' ) {
294 } elsif ( length($groups) ) {
295 [ split(/\s*,\s*/, $groups) ];
303 =item search_sql STRING
305 Class method which returns an SQL fragment to search for the given string.
310 my( $class, $string ) = @_;
311 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
312 my( $username, $domain ) = ( $1, $2 );
313 my $q_username = dbh->quote($username);
314 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
316 "svc_acct.username = $q_username AND ( ".
317 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
322 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
324 $class->search_sql_field('slipip', $string ).
326 $class->search_sql_field('username', $string ).
329 $class->search_sql_field('username', $string);
333 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
335 Returns the "username@domain" string for this account.
337 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
349 =item insert [ , OPTION => VALUE ... ]
351 Adds this account to the database. If there is an error, returns the error,
352 otherwise returns false.
354 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
355 defined. An FS::cust_svc record will be created and inserted.
357 The additional field I<usergroup> can optionally be defined; if so it should
358 contain an arrayref of group names. See L<FS::radius_usergroup>.
360 The additional field I<child_objects> can optionally be defined; if so it
361 should contain an arrayref of FS::tablename objects. They will have their
362 svcnum fields set and will be inserted after this record, but before any
363 exports are run. Each element of the array can also optionally be a
364 two-element array reference containing the child object and the name of an
365 alternate field to be filled in with the newly-inserted svcnum, for example
366 C<[ $svc_forward, 'srcsvc' ]>
368 Currently available options are: I<depend_jobnum>
370 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
371 jobnums), all provisioning jobs will have a dependancy on the supplied
372 jobnum(s) (they will not run until the specific job(s) complete(s)).
374 (TODOC: L<FS::queue> and L<freeside-queued>)
376 (TODOC: new exports!)
385 warn "[$me] insert called on $self: ". Dumper($self).
386 "\nwith options: ". Dumper(%options);
389 local $SIG{HUP} = 'IGNORE';
390 local $SIG{INT} = 'IGNORE';
391 local $SIG{QUIT} = 'IGNORE';
392 local $SIG{TERM} = 'IGNORE';
393 local $SIG{TSTP} = 'IGNORE';
394 local $SIG{PIPE} = 'IGNORE';
396 my $oldAutoCommit = $FS::UID::AutoCommit;
397 local $FS::UID::AutoCommit = 0;
400 my $error = $self->check;
401 return $error if $error;
403 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
404 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
405 unless ( $cust_svc ) {
406 $dbh->rollback if $oldAutoCommit;
407 return "no cust_svc record found for svcnum ". $self->svcnum;
409 $self->pkgnum($cust_svc->pkgnum);
410 $self->svcpart($cust_svc->svcpart);
413 $error = $self->_check_duplicate;
415 $dbh->rollback if $oldAutoCommit;
420 $error = $self->SUPER::insert(
421 'jobnums' => \@jobnums,
422 'child_objects' => $self->child_objects,
426 $dbh->rollback if $oldAutoCommit;
430 if ( $self->usergroup ) {
431 foreach my $groupname ( @{$self->usergroup} ) {
432 my $radius_usergroup = new FS::radius_usergroup ( {
433 svcnum => $self->svcnum,
434 groupname => $groupname,
436 my $error = $radius_usergroup->insert;
438 $dbh->rollback if $oldAutoCommit;
444 unless ( $skip_fuzzyfiles ) {
445 $error = $self->queue_fuzzyfiles_update;
447 $dbh->rollback if $oldAutoCommit;
448 return "updating fuzzy search cache: $error";
452 my $cust_pkg = $self->cust_svc->cust_pkg;
455 my $cust_main = $cust_pkg->cust_main;
457 if ( $conf->exists('emailinvoiceautoalways')
458 || $conf->exists('emailinvoiceauto')
459 && ! $cust_main->invoicing_list_emailonly
461 my @invoicing_list = $cust_main->invoicing_list;
462 push @invoicing_list, $self->email;
463 $cust_main->invoicing_list(\@invoicing_list);
468 if ( $welcome_template && $cust_pkg ) {
469 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
471 my $wqueue = new FS::queue {
472 'svcnum' => $self->svcnum,
473 'job' => 'FS::svc_acct::send_email'
475 my $error = $wqueue->insert(
477 'from' => $welcome_from,
478 'subject' => $welcome_subject,
479 'mimetype' => $welcome_mimetype,
480 'body' => $welcome_template->fill_in( HASH => {
481 'custnum' => $self->custnum,
482 'username' => $self->username,
483 'password' => $self->_password,
484 'first' => $cust_main->first,
485 'last' => $cust_main->getfield('last'),
486 'pkg' => $cust_pkg->part_pkg->pkg,
490 $dbh->rollback if $oldAutoCommit;
491 return "error queuing welcome email: $error";
494 if ( $options{'depend_jobnum'} ) {
495 warn "$me depend_jobnum found; adding to welcome email dependancies"
497 if ( ref($options{'depend_jobnum'}) ) {
498 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
499 "to welcome email dependancies"
501 push @jobnums, @{ $options{'depend_jobnum'} };
503 warn "$me adding job $options{'depend_jobnum'} ".
504 "to welcome email dependancies"
506 push @jobnums, $options{'depend_jobnum'};
510 foreach my $jobnum ( @jobnums ) {
511 my $error = $wqueue->depend_insert($jobnum);
513 $dbh->rollback if $oldAutoCommit;
514 return "error queuing welcome email job dependancy: $error";
524 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
530 Deletes this account from the database. If there is an error, returns the
531 error, otherwise returns false.
533 The corresponding FS::cust_svc record will be deleted as well.
535 (TODOC: new exports!)
542 return "can't delete system account" if $self->_check_system;
544 return "Can't delete an account which is a (svc_forward) source!"
545 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
547 return "Can't delete an account which is a (svc_forward) destination!"
548 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
550 return "Can't delete an account with (svc_www) web service!"
551 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
553 # what about records in session ? (they should refer to history table)
555 local $SIG{HUP} = 'IGNORE';
556 local $SIG{INT} = 'IGNORE';
557 local $SIG{QUIT} = 'IGNORE';
558 local $SIG{TERM} = 'IGNORE';
559 local $SIG{TSTP} = 'IGNORE';
560 local $SIG{PIPE} = 'IGNORE';
562 my $oldAutoCommit = $FS::UID::AutoCommit;
563 local $FS::UID::AutoCommit = 0;
566 foreach my $cust_main_invoice (
567 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
569 unless ( defined($cust_main_invoice) ) {
570 warn "WARNING: something's wrong with qsearch";
573 my %hash = $cust_main_invoice->hash;
574 $hash{'dest'} = $self->email;
575 my $new = new FS::cust_main_invoice \%hash;
576 my $error = $new->replace($cust_main_invoice);
578 $dbh->rollback if $oldAutoCommit;
583 foreach my $svc_domain (
584 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
586 my %hash = new FS::svc_domain->hash;
587 $hash{'catchall'} = '';
588 my $new = new FS::svc_domain \%hash;
589 my $error = $new->replace($svc_domain);
591 $dbh->rollback if $oldAutoCommit;
596 foreach my $radius_usergroup (
597 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
599 my $error = $radius_usergroup->delete;
601 $dbh->rollback if $oldAutoCommit;
606 my $error = $self->SUPER::delete;
608 $dbh->rollback if $oldAutoCommit;
612 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
616 =item replace OLD_RECORD
618 Replaces OLD_RECORD with this one in the database. If there is an error,
619 returns the error, otherwise returns false.
621 The additional field I<usergroup> can optionally be defined; if so it should
622 contain an arrayref of group names. See L<FS::radius_usergroup>.
628 my ( $new, $old ) = ( shift, shift );
630 warn "$me replacing $old with $new\n" if $DEBUG;
632 # We absolutely have to have an old vs. new record to make this work.
633 if (!defined($old)) {
634 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
637 return "can't modify system account" if $old->_check_system;
640 #no warnings 'numeric'; #alas, a 5.006-ism
643 foreach my $xid (qw( uid gid )) {
645 return "Can't change $xid!"
646 if ! $conf->exists("svc_acct-edit_$xid")
647 && $old->$xid() != $new->$xid()
648 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
653 #change homdir when we change username
654 $new->setfield('dir', '') if $old->username ne $new->username;
656 local $SIG{HUP} = 'IGNORE';
657 local $SIG{INT} = 'IGNORE';
658 local $SIG{QUIT} = 'IGNORE';
659 local $SIG{TERM} = 'IGNORE';
660 local $SIG{TSTP} = 'IGNORE';
661 local $SIG{PIPE} = 'IGNORE';
663 my $oldAutoCommit = $FS::UID::AutoCommit;
664 local $FS::UID::AutoCommit = 0;
667 # redundant, but so $new->usergroup gets set
668 $error = $new->check;
669 return $error if $error;
671 $old->usergroup( [ $old->radius_groups ] );
673 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
674 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
676 if ( $new->usergroup ) {
677 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
678 my @newgroups = @{$new->usergroup};
679 foreach my $oldgroup ( @{$old->usergroup} ) {
680 if ( grep { $oldgroup eq $_ } @newgroups ) {
681 @newgroups = grep { $oldgroup ne $_ } @newgroups;
684 my $radius_usergroup = qsearchs('radius_usergroup', {
685 svcnum => $old->svcnum,
686 groupname => $oldgroup,
688 my $error = $radius_usergroup->delete;
690 $dbh->rollback if $oldAutoCommit;
691 return "error deleting radius_usergroup $oldgroup: $error";
695 foreach my $newgroup ( @newgroups ) {
696 my $radius_usergroup = new FS::radius_usergroup ( {
697 svcnum => $new->svcnum,
698 groupname => $newgroup,
700 my $error = $radius_usergroup->insert;
702 $dbh->rollback if $oldAutoCommit;
703 return "error adding radius_usergroup $newgroup: $error";
709 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
710 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
711 $error = $new->_check_duplicate;
713 $dbh->rollback if $oldAutoCommit;
718 $error = $new->SUPER::replace($old);
720 $dbh->rollback if $oldAutoCommit;
721 return $error if $error;
724 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
725 $error = $new->queue_fuzzyfiles_update;
727 $dbh->rollback if $oldAutoCommit;
728 return "updating fuzzy search cache: $error";
732 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
736 =item queue_fuzzyfiles_update
738 Used by insert & replace to update the fuzzy search cache
742 sub queue_fuzzyfiles_update {
745 local $SIG{HUP} = 'IGNORE';
746 local $SIG{INT} = 'IGNORE';
747 local $SIG{QUIT} = 'IGNORE';
748 local $SIG{TERM} = 'IGNORE';
749 local $SIG{TSTP} = 'IGNORE';
750 local $SIG{PIPE} = 'IGNORE';
752 my $oldAutoCommit = $FS::UID::AutoCommit;
753 local $FS::UID::AutoCommit = 0;
756 my $queue = new FS::queue {
757 'svcnum' => $self->svcnum,
758 'job' => 'FS::svc_acct::append_fuzzyfiles'
760 my $error = $queue->insert($self->username);
762 $dbh->rollback if $oldAutoCommit;
763 return "queueing job (transaction rolled back): $error";
766 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
774 Suspends this account by calling export-specific suspend hooks. If there is
775 an error, returns the error, otherwise returns false.
777 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
783 return "can't suspend system account" if $self->_check_system;
784 $self->SUPER::suspend;
789 Unsuspends this account by by calling export-specific suspend hooks. If there
790 is an error, returns the error, otherwise returns false.
792 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
798 my %hash = $self->hash;
799 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
800 $hash{_password} = $1;
801 my $new = new FS::svc_acct ( \%hash );
802 my $error = $new->replace($self);
803 return $error if $error;
806 $self->SUPER::unsuspend;
811 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
813 If the B<auto_unset_catchall> configuration option is set, this method will
814 automatically remove any references to the canceled service in the catchall
815 field of svc_domain. This allows packages that contain both a svc_domain and
816 its catchall svc_acct to be canceled in one step.
821 # Only one thing to do at this level
823 foreach my $svc_domain (
824 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
825 if($conf->exists('auto_unset_catchall')) {
826 my %hash = $svc_domain->hash;
827 $hash{catchall} = '';
828 my $new = new FS::svc_domain ( \%hash );
829 my $error = $new->replace($svc_domain);
830 return $error if $error;
832 return "cannot unprovision svc_acct #".$self->svcnum.
833 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
837 $self->SUPER::cancel;
843 Checks all fields to make sure this is a valid service. If there is an error,
844 returns the error, otherwise returns false. Called by the insert and replace
847 Sets any fixed values; see L<FS::part_svc>.
854 my($recref) = $self->hashref;
856 my $x = $self->setfixed( $self->_fieldhandlers );
857 return $x unless ref($x);
860 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
862 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
865 my $error = $self->ut_numbern('svcnum')
866 #|| $self->ut_number('domsvc')
867 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
868 || $self->ut_textn('sec_phrase')
869 || $self->ut_snumbern('seconds')
870 || $self->ut_snumbern('upbytes')
871 || $self->ut_snumbern('downbytes')
872 || $self->ut_snumbern('totalbytes')
874 return $error if $error;
876 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
877 if ( $username_uppercase ) {
878 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
879 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
880 $recref->{username} = $1;
882 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
883 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
884 $recref->{username} = $1;
887 if ( $username_letterfirst ) {
888 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
889 } elsif ( $username_letter ) {
890 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
892 if ( $username_noperiod ) {
893 $recref->{username} =~ /\./ and return gettext('illegal_username');
895 if ( $username_nounderscore ) {
896 $recref->{username} =~ /_/ and return gettext('illegal_username');
898 if ( $username_nodash ) {
899 $recref->{username} =~ /\-/ and return gettext('illegal_username');
901 unless ( $username_ampersand ) {
902 $recref->{username} =~ /\&/ and return gettext('illegal_username');
904 if ( $password_noampersand ) {
905 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
907 if ( $password_noexclamation ) {
908 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
910 unless ( $username_percent ) {
911 $recref->{username} =~ /\%/ and return gettext('illegal_username');
914 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
915 $recref->{popnum} = $1;
916 return "Unknown popnum" unless
917 ! $recref->{popnum} ||
918 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
920 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
922 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
923 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
925 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
926 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
927 #not all systems use gid=uid
928 #you can set a fixed gid in part_svc
930 return "Only root can have uid 0"
931 if $recref->{uid} == 0
932 && $recref->{username} !~ /^(root|toor|smtp)$/;
934 unless ( $recref->{username} eq 'sync' ) {
935 if ( grep $_ eq $recref->{shell}, @shells ) {
936 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
938 return "Illegal shell \`". $self->shell. "\'; ".
939 $conf->dir. "/shells contains: @shells";
942 $recref->{shell} = '/bin/sync';
946 $recref->{gid} ne '' ?
947 return "Can't have gid without uid" : ( $recref->{gid}='' );
948 #$recref->{dir} ne '' ?
949 # return "Can't have directory without uid" : ( $recref->{dir}='' );
950 $recref->{shell} ne '' ?
951 return "Can't have shell without uid" : ( $recref->{shell}='' );
954 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
956 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
957 or return "Illegal directory: ". $recref->{dir};
959 return "Illegal directory"
960 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
961 return "Illegal directory"
962 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
963 unless ( $recref->{dir} ) {
964 $recref->{dir} = $dir_prefix . '/';
965 if ( $dirhash > 0 ) {
966 for my $h ( 1 .. $dirhash ) {
967 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
969 } elsif ( $dirhash < 0 ) {
970 for my $h ( reverse $dirhash .. -1 ) {
971 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
974 $recref->{dir} .= $recref->{username};
980 # $error = $self->ut_textn('finger');
981 # return $error if $error;
982 if ( $self->getfield('finger') eq '' ) {
983 my $cust_pkg = $self->svcnum
984 ? $self->cust_svc->cust_pkg
985 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
987 my $cust_main = $cust_pkg->cust_main;
988 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
991 $self->getfield('finger') =~
992 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
993 or return "Illegal finger: ". $self->getfield('finger');
994 $self->setfield('finger', $1);
996 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
997 $recref->{quota} = $1;
999 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1000 if ( $recref->{slipip} eq '' ) {
1001 $recref->{slipip} = '';
1002 } elsif ( $recref->{slipip} eq '0e0' ) {
1003 $recref->{slipip} = '0e0';
1005 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1006 or return "Illegal slipip: ". $self->slipip;
1007 $recref->{slipip} = $1;
1012 #arbitrary RADIUS stuff; allow ut_textn for now
1013 foreach ( grep /^radius_/, fields('svc_acct') ) {
1014 $self->ut_textn($_);
1017 #generate a password if it is blank
1018 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1019 unless ( $recref->{_password} );
1021 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1022 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1023 $recref->{_password} = $1.$3;
1024 #uncomment this to encrypt password immediately upon entry, or run
1025 #bin/crypt_pw in cron to give new users a window during which their
1026 #password is available to techs, for faxing, etc. (also be aware of
1028 #$recref->{password} = $1.
1029 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
1031 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1032 $recref->{_password} = $1.$3;
1033 } elsif ( $recref->{_password} eq '*' ) {
1034 $recref->{_password} = '*';
1035 } elsif ( $recref->{_password} eq '!' ) {
1036 $recref->{_password} = '!';
1037 } elsif ( $recref->{_password} eq '!!' ) {
1038 $recref->{_password} = '!!';
1040 #return "Illegal password";
1041 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1042 FS::Msgcat::_gettext('illegal_password_characters').
1043 ": ". $recref->{_password};
1046 $self->SUPER::check;
1051 Internal function to check the username against the list of system usernames
1052 from the I<system_usernames> configuration value. Returns true if the username
1053 is listed on the system username list.
1059 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1060 $conf->config('system_usernames')
1064 =item _check_duplicate
1066 Internal function to check for duplicates usernames, username@domain pairs and
1069 If the I<global_unique-username> configuration value is set to B<username> or
1070 B<username@domain>, enforces global username or username@domain uniqueness.
1072 In all cases, check for duplicate uids and usernames or username@domain pairs
1073 per export and with identical I<svcpart> values.
1077 sub _check_duplicate {
1080 my $global_unique = $conf->config('global_unique-username') || 'none';
1081 return '' if $global_unique eq 'disabled';
1083 #this is Pg-specific. what to do for mysql etc?
1084 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
1085 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1086 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1088 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1090 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1091 unless ( $part_svc ) {
1092 return 'unknown svcpart '. $self->svcpart;
1095 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1096 qsearch( 'svc_acct', { 'username' => $self->username } );
1097 return gettext('username_in_use')
1098 if $global_unique eq 'username' && @dup_user;
1100 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1101 qsearch( 'svc_acct', { 'username' => $self->username,
1102 'domsvc' => $self->domsvc } );
1103 return gettext('username_in_use')
1104 if $global_unique eq 'username@domain' && @dup_userdomain;
1107 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1108 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1109 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1110 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1115 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1116 my $exports = FS::part_export::export_info('svc_acct');
1117 my %conflict_user_svcpart;
1118 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1120 foreach my $part_export ( $part_svc->part_export ) {
1122 #this will catch to the same exact export
1123 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1125 #this will catch to exports w/same exporthost+type ???
1126 #my @other_part_export = qsearch('part_export', {
1127 # 'machine' => $part_export->machine,
1128 # 'exporttype' => $part_export->exporttype,
1130 #foreach my $other_part_export ( @other_part_export ) {
1131 # push @svcparts, map { $_->svcpart }
1132 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1135 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1136 #silly kludge to avoid uninitialized value errors
1137 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1138 ? $exports->{$part_export->exporttype}{'nodomain'}
1140 if ( $nodomain =~ /^Y/i ) {
1141 $conflict_user_svcpart{$_} = $part_export->exportnum
1144 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1149 foreach my $dup_user ( @dup_user ) {
1150 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1151 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1152 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1153 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1157 foreach my $dup_userdomain ( @dup_userdomain ) {
1158 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1159 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1160 return "duplicate username\@domain: conflicts with svcnum ".
1161 $dup_userdomain->svcnum. " via exportnum ".
1162 $conflict_userdomain_svcpart{$dup_svcpart};
1166 foreach my $dup_uid ( @dup_uid ) {
1167 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1168 if ( exists($conflict_user_svcpart{$dup_svcpart})
1169 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1170 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1171 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1172 || $conflict_userdomain_svcpart{$dup_svcpart};
1184 Depriciated, use radius_reply instead.
1189 carp "FS::svc_acct::radius depriciated, use radius_reply";
1190 $_[0]->radius_reply;
1195 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1196 reply attributes of this record.
1198 Note that this is now the preferred method for reading RADIUS attributes -
1199 accessing the columns directly is discouraged, as the column names are
1200 expected to change in the future.
1207 return %{ $self->{'radius_reply'} }
1208 if exists $self->{'radius_reply'};
1213 my($column, $attrib) = ($1, $2);
1214 #$attrib =~ s/_/\-/g;
1215 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1216 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1218 if ( $self->slipip && $self->slipip ne '0e0' ) {
1219 $reply{$radius_ip} = $self->slipip;
1222 if ( $self->seconds !~ /^$/ ) {
1223 $reply{'Session-Timeout'} = $self->seconds;
1231 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1232 check attributes of this record.
1234 Note that this is now the preferred method for reading RADIUS attributes -
1235 accessing the columns directly is discouraged, as the column names are
1236 expected to change in the future.
1243 return %{ $self->{'radius_check'} }
1244 if exists $self->{'radius_check'};
1249 my($column, $attrib) = ($1, $2);
1250 #$attrib =~ s/_/\-/g;
1251 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1252 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1254 my $password = $self->_password;
1255 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1257 my $cust_svc = $self->cust_svc;
1258 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1260 my $cust_pkg = $cust_svc->cust_pkg;
1261 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1262 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1271 This method instructs the object to "snapshot" or freeze RADIUS check and
1272 reply attributes to the current values.
1276 #bah, my english is too broken this morning
1277 #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
1278 #the FS::cust_pkg's replace method to trigger the correct export updates when
1279 #package dates change)
1284 $self->{$_} = { $self->$_() }
1285 foreach qw( radius_reply radius_check );
1289 =item forget_snapshot
1291 This methos instructs the object to forget any previously snapshotted
1292 RADIUS check and reply attributes.
1296 sub forget_snapshot {
1300 foreach qw( radius_reply radius_check );
1304 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1306 Returns the domain associated with this account.
1308 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1315 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1316 my $svc_domain = $self->svc_domain(@_)
1317 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1318 $svc_domain->domain;
1323 Returns the FS::svc_domain record for this account's domain (see
1328 # FS::h_svc_acct has a history-aware svc_domain override
1333 ? $self->{'_domsvc'}
1334 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1339 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1343 #inherited from svc_Common
1345 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1347 Returns an email address associated with the account.
1349 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1356 $self->username. '@'. $self->domain(@_);
1361 Returns an array of FS::acct_snarf records associated with the account.
1362 If the acct_snarf table does not exist or there are no associated records,
1363 an empty list is returned
1369 return () unless dbdef->table('acct_snarf');
1370 eval "use FS::acct_snarf;";
1372 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1375 =item decrement_upbytes OCTETS
1377 Decrements the I<upbytes> field of this record by the given amount. If there
1378 is an error, returns the error, otherwise returns false.
1382 sub decrement_upbytes {
1383 shift->_op_usage('-', 'upbytes', @_);
1386 =item increment_upbytes OCTETS
1388 Increments the I<upbytes> field of this record by the given amount. If there
1389 is an error, returns the error, otherwise returns false.
1393 sub increment_upbytes {
1394 shift->_op_usage('+', 'upbytes', @_);
1397 =item decrement_downbytes OCTETS
1399 Decrements the I<downbytes> field of this record by the given amount. If there
1400 is an error, returns the error, otherwise returns false.
1404 sub decrement_downbytes {
1405 shift->_op_usage('-', 'downbytes', @_);
1408 =item increment_downbytes OCTETS
1410 Increments the I<downbytes> field of this record by the given amount. If there
1411 is an error, returns the error, otherwise returns false.
1415 sub increment_downbytes {
1416 shift->_op_usage('+', 'downbytes', @_);
1419 =item decrement_totalbytes OCTETS
1421 Decrements the I<totalbytes> field of this record by the given amount. If there
1422 is an error, returns the error, otherwise returns false.
1426 sub decrement_totalbytes {
1427 shift->_op_usage('-', 'totalbytes', @_);
1430 =item increment_totalbytes OCTETS
1432 Increments the I<totalbytes> field of this record by the given amount. If there
1433 is an error, returns the error, otherwise returns false.
1437 sub increment_totalbytes {
1438 shift->_op_usage('+', 'totalbytes', @_);
1441 =item decrement_seconds SECONDS
1443 Decrements the I<seconds> field of this record by the given amount. If there
1444 is an error, returns the error, otherwise returns false.
1448 sub decrement_seconds {
1449 shift->_op_usage('-', 'seconds', @_);
1452 =item increment_seconds SECONDS
1454 Increments the I<seconds> field of this record by the given amount. If there
1455 is an error, returns the error, otherwise returns false.
1459 sub increment_seconds {
1460 shift->_op_usage('+', 'seconds', @_);
1468 my %op2condition = (
1469 '-' => sub { my($self, $column, $amount) = @_;
1470 $self->$column - $amount <= 0;
1472 '+' => sub { my($self, $column, $amount) = @_;
1473 $self->$column + $amount > 0;
1476 my %op2warncondition = (
1477 '-' => sub { my($self, $column, $amount) = @_;
1478 my $threshold = $column . '_threshold';
1479 $self->$column - $amount <= $self->$threshold + 0;
1481 '+' => sub { my($self, $column, $amount) = @_;
1482 $self->$column + $amount > 0;
1487 my( $self, $op, $column, $amount ) = @_;
1489 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1490 ' ('. $self->email. "): $op $amount\n"
1493 return '' unless $amount;
1495 local $SIG{HUP} = 'IGNORE';
1496 local $SIG{INT} = 'IGNORE';
1497 local $SIG{QUIT} = 'IGNORE';
1498 local $SIG{TERM} = 'IGNORE';
1499 local $SIG{TSTP} = 'IGNORE';
1500 local $SIG{PIPE} = 'IGNORE';
1502 my $oldAutoCommit = $FS::UID::AutoCommit;
1503 local $FS::UID::AutoCommit = 0;
1506 my $sql = "UPDATE svc_acct SET $column = ".
1507 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1508 " $op ? WHERE svcnum = ?";
1512 my $sth = $dbh->prepare( $sql )
1513 or die "Error preparing $sql: ". $dbh->errstr;
1514 my $rv = $sth->execute($amount, $self->svcnum);
1515 die "Error executing $sql: ". $sth->errstr
1516 unless defined($rv);
1517 die "Can't update $column for svcnum". $self->svcnum
1520 my $action = $op2action{$op};
1522 if ( &{$op2condition{$op}}($self, $column, $amount) ) {
1523 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1524 if ($part_export->option('overlimit_groups')) {
1526 my $other = new FS::svc_acct $self->hashref;
1527 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1528 ($self, $part_export->option('overlimit_groups'));
1529 $other->usergroup( $groups );
1530 if ($action eq 'suspend'){
1531 $new = $other; $old = $self;
1533 $new = $self; $old = $other;
1535 my $error = $part_export->export_replace($new, $old);
1537 $dbh->rollback if $oldAutoCommit;
1538 return "Error replacing radius groups in export, ${op}: $error";
1544 if ( $conf->exists("svc_acct-usage_$action")
1545 && &{$op2condition{$op}}($self, $column, $amount) ) {
1546 #my $error = $self->$action();
1547 my $error = $self->cust_svc->cust_pkg->$action();
1549 $dbh->rollback if $oldAutoCommit;
1550 return "Error ${action}ing: $error";
1554 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1555 my $wqueue = new FS::queue {
1556 'svcnum' => $self->svcnum,
1557 'job' => 'FS::svc_acct::reached_threshold',
1562 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1566 my $error = $wqueue->insert(
1567 'svcnum' => $self->svcnum,
1569 'column' => $column,
1573 $dbh->rollback if $oldAutoCommit;
1574 return "Error queuing threshold activity: $error";
1578 warn "$me update successful; committing\n"
1580 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1586 my( $self, $valueref ) = @_;
1588 warn "$me set_usage called for svcnum ". $self->svcnum.
1589 ' ('. $self->email. "): ".
1590 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1593 local $SIG{HUP} = 'IGNORE';
1594 local $SIG{INT} = 'IGNORE';
1595 local $SIG{QUIT} = 'IGNORE';
1596 local $SIG{TERM} = 'IGNORE';
1597 local $SIG{TSTP} = 'IGNORE';
1598 local $SIG{PIPE} = 'IGNORE';
1600 local $FS::svc_Common::noexport_hack = 1;
1601 my $oldAutoCommit = $FS::UID::AutoCommit;
1602 local $FS::UID::AutoCommit = 0;
1606 foreach my $field (keys %$valueref){
1607 $reset = 1 if $valueref->{$field};
1608 $self->setfield($field, $valueref->{$field});
1609 $self->setfield( $field.'_threshold',
1610 int($self->getfield($field)
1611 * ( $conf->exists('svc_acct-usage_threshold')
1612 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1618 my $error = $self->replace;
1619 die $error if $error;
1621 if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) {
1622 my $error = $self->cust_svc->cust_pkg->unsuspend;
1624 $dbh->rollback if $oldAutoCommit;
1625 return "Error unsuspending: $error";
1629 warn "$me update successful; committing\n"
1631 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1637 =item recharge HASHREF
1639 Increments usage columns by the amount specified in HASHREF as
1640 column=>amount pairs.
1645 my ($self, $vhash) = @_;
1648 warn "[$me] recharge called on $self: ". Dumper($self).
1649 "\nwith vhash: ". Dumper($vhash);
1652 my $oldAutoCommit = $FS::UID::AutoCommit;
1653 local $FS::UID::AutoCommit = 0;
1657 foreach my $column (keys %$vhash){
1658 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1662 $dbh->rollback if $oldAutoCommit;
1664 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1669 =item is_rechargeable
1671 Returns true if this svc_account can be "recharged" and false otherwise.
1675 sub is_rechargable {
1677 $self->seconds ne ''
1678 || $self->upbytes ne ''
1679 || $self->downbytes ne ''
1680 || $self->totalbytes ne '';
1683 =item seconds_since TIMESTAMP
1685 Returns the number of seconds this account has been online since TIMESTAMP,
1686 according to the session monitor (see L<FS::Session>).
1688 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1689 L<Time::Local> and L<Date::Parse> for conversion functions.
1693 #note: POD here, implementation in FS::cust_svc
1696 $self->cust_svc->seconds_since(@_);
1699 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1701 Returns the numbers of seconds this account has been online between
1702 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1703 external SQL radacct table, specified via sqlradius export. Sessions which
1704 started in the specified range but are still open are counted from session
1705 start to the end of the range (unless they are over 1 day old, in which case
1706 they are presumed missing their stop record and not counted). Also, sessions
1707 which end in the range but started earlier are counted from the start of the
1708 range to session end. Finally, sessions which start before the range but end
1709 after are counted for the entire range.
1711 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1712 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1717 #note: POD here, implementation in FS::cust_svc
1718 sub seconds_since_sqlradacct {
1720 $self->cust_svc->seconds_since_sqlradacct(@_);
1723 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1725 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1726 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1727 TIMESTAMP_END (exclusive).
1729 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1730 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1735 #note: POD here, implementation in FS::cust_svc
1736 sub attribute_since_sqlradacct {
1738 $self->cust_svc->attribute_since_sqlradacct(@_);
1741 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1743 Returns an array of hash references of this customers login history for the
1744 given time range. (document this better)
1748 sub get_session_history {
1750 $self->cust_svc->get_session_history(@_);
1753 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1758 my($self, $start, $end, %opt ) = @_;
1760 my $did = $self->username; #yup
1762 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1764 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1766 #SELECT $for_update * FROM cdr
1767 # WHERE calldate >= $start #need a conversion
1768 # AND calldate < $end #ditto
1769 # AND ( charged_party = "$did"
1770 # OR charged_party = "$prefix$did" #if length($prefix);
1771 # OR ( ( charged_party IS NULL OR charged_party = '' )
1773 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1776 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1779 if ( length($prefix) ) {
1781 " AND ( charged_party = '$did'
1782 OR charged_party = '$prefix$did'
1783 OR ( ( charged_party IS NULL OR charged_party = '' )
1785 ( src = '$did' OR src = '$prefix$did' )
1791 " AND ( charged_party = '$did'
1792 OR ( ( charged_party IS NULL OR charged_party = '' )
1802 'select' => "$for_update *",
1805 #( freesidestatus IS NULL OR freesidestatus = '' )
1806 'freesidestatus' => '',
1808 'extra_sql' => $charged_or_src,
1816 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1822 if ( $self->usergroup ) {
1823 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1824 unless ref($self->usergroup) eq 'ARRAY';
1825 #when provisioning records, export callback runs in svc_Common.pm before
1826 #radius_usergroup records can be inserted...
1827 @{$self->usergroup};
1829 map { $_->groupname }
1830 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1834 =item clone_suspended
1836 Constructor used by FS::part_export::_export_suspend fallback. Document
1841 sub clone_suspended {
1843 my %hash = $self->hash;
1844 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1845 new FS::svc_acct \%hash;
1848 =item clone_kludge_unsuspend
1850 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1855 sub clone_kludge_unsuspend {
1857 my %hash = $self->hash;
1858 $hash{_password} = '';
1859 new FS::svc_acct \%hash;
1862 =item check_password
1864 Checks the supplied password against the (possibly encrypted) password in the
1865 database. Returns true for a successful authentication, false for no match.
1867 Currently supported encryptions are: classic DES crypt() and MD5
1871 sub check_password {
1872 my($self, $check_password) = @_;
1874 #remove old-style SUSPENDED kludge, they should be allowed to login to
1875 #self-service and pay up
1876 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1878 #eventually should check a "password-encoding" field
1879 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1881 } elsif ( length($password) < 13 ) { #plaintext
1882 $check_password eq $password;
1883 } elsif ( length($password) == 13 ) { #traditional DES crypt
1884 crypt($check_password, $password) eq $password;
1885 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1886 unix_md5_crypt($check_password, $password) eq $password;
1887 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1888 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1889 $self->svcnum. "\n";
1892 warn "Can't check password: Unrecognized encryption for svcnum ".
1893 $self->svcnum. "\n";
1899 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1901 Returns an encrypted password, either by passing through an encrypted password
1902 in the database or by encrypting a plaintext password from the database.
1904 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1905 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1906 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1907 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1908 encryption type is only used if the password is not already encrypted in the
1913 sub crypt_password {
1915 #eventually should check a "password-encoding" field
1916 if ( length($self->_password) == 13
1917 || $self->_password =~ /^\$(1|2a?)\$/
1918 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1923 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1924 if ( $encryption eq 'crypt' ) {
1927 $saltset[int(rand(64))].$saltset[int(rand(64))]
1929 } elsif ( $encryption eq 'md5' ) {
1930 unix_md5_crypt( $self->_password );
1931 } elsif ( $encryption eq 'blowfish' ) {
1932 croak "unknown encryption method $encryption";
1934 croak "unknown encryption method $encryption";
1939 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
1941 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
1942 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
1943 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
1945 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
1946 to work the same as the B</crypt_password> method.
1952 #eventually should check a "password-encoding" field
1953 if ( length($self->_password) == 13 ) { #crypt
1954 return '{CRYPT}'. $self->_password;
1955 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
1957 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
1958 die "Blowfish encryption not supported in this context, svcnum ".
1959 $self->svcnum. "\n";
1960 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
1961 return '{SSHA}'. $1;
1962 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
1963 return '{NS-MTA-MD5}'. $1;
1965 return '{PLAIN}'. $self->_password;
1966 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1967 #if ( $encryption eq 'crypt' ) {
1968 # return '{CRYPT}'. crypt(
1970 # $saltset[int(rand(64))].$saltset[int(rand(64))]
1972 #} elsif ( $encryption eq 'md5' ) {
1973 # unix_md5_crypt( $self->_password );
1974 #} elsif ( $encryption eq 'blowfish' ) {
1975 # croak "unknown encryption method $encryption";
1977 # croak "unknown encryption method $encryption";
1982 =item domain_slash_username
1984 Returns $domain/$username/
1988 sub domain_slash_username {
1990 $self->domain. '/'. $self->username. '/';
1993 =item virtual_maildir
1995 Returns $domain/maildirs/$username/
1999 sub virtual_maildir {
2001 $self->domain. '/maildirs/'. $self->username. '/';
2012 This is the FS::svc_acct job-queue-able version. It still uses
2013 FS::Misc::send_email under-the-hood.
2020 eval "use FS::Misc qw(send_email)";
2023 $opt{mimetype} ||= 'text/plain';
2024 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2026 my $error = send_email(
2027 'from' => $opt{from},
2029 'subject' => $opt{subject},
2030 'content-type' => $opt{mimetype},
2031 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2033 die $error if $error;
2036 =item check_and_rebuild_fuzzyfiles
2040 sub check_and_rebuild_fuzzyfiles {
2041 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2042 -e "$dir/svc_acct.username"
2043 or &rebuild_fuzzyfiles;
2046 =item rebuild_fuzzyfiles
2050 sub rebuild_fuzzyfiles {
2052 use Fcntl qw(:flock);
2054 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2058 open(USERNAMELOCK,">>$dir/svc_acct.username")
2059 or die "can't open $dir/svc_acct.username: $!";
2060 flock(USERNAMELOCK,LOCK_EX)
2061 or die "can't lock $dir/svc_acct.username: $!";
2063 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2065 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2066 or die "can't open $dir/svc_acct.username.tmp: $!";
2067 print USERNAMECACHE join("\n", @all_username), "\n";
2068 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2070 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2080 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2081 open(USERNAMECACHE,"<$dir/svc_acct.username")
2082 or die "can't open $dir/svc_acct.username: $!";
2083 my @array = map { chomp; $_; } <USERNAMECACHE>;
2084 close USERNAMECACHE;
2088 =item append_fuzzyfiles USERNAME
2092 sub append_fuzzyfiles {
2093 my $username = shift;
2095 &check_and_rebuild_fuzzyfiles;
2097 use Fcntl qw(:flock);
2099 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2101 open(USERNAME,">>$dir/svc_acct.username")
2102 or die "can't open $dir/svc_acct.username: $!";
2103 flock(USERNAME,LOCK_EX)
2104 or die "can't lock $dir/svc_acct.username: $!";
2106 print USERNAME "$username\n";
2108 flock(USERNAME,LOCK_UN)
2109 or die "can't unlock $dir/svc_acct.username: $!";
2117 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2121 sub radius_usergroup_selector {
2122 my $sel_groups = shift;
2123 my %sel_groups = map { $_=>1 } @$sel_groups;
2125 my $selectname = shift || 'radius_usergroup';
2128 my $sth = $dbh->prepare(
2129 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2130 ) or die $dbh->errstr;
2131 $sth->execute() or die $sth->errstr;
2132 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2136 function ${selectname}_doadd(object) {
2137 var myvalue = object.${selectname}_add.value;
2138 var optionName = new Option(myvalue,myvalue,false,true);
2139 var length = object.$selectname.length;
2140 object.$selectname.options[length] = optionName;
2141 object.${selectname}_add.value = "";
2144 <SELECT MULTIPLE NAME="$selectname">
2147 foreach my $group ( @all_groups ) {
2148 $html .= qq(<OPTION VALUE="$group");
2149 if ( $sel_groups{$group} ) {
2150 $html .= ' SELECTED';
2151 $sel_groups{$group} = 0;
2153 $html .= ">$group</OPTION>\n";
2155 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2156 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2158 $html .= '</SELECT>';
2160 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2161 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2166 =item reached_threshold
2168 Performs some activities when svc_acct thresholds (such as number of seconds
2169 remaining) are reached.
2173 sub reached_threshold {
2176 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2177 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2179 if ( $opt{'op'} eq '+' ){
2180 $svc_acct->setfield( $opt{'column'}.'_threshold',
2181 int($svc_acct->getfield($opt{'column'})
2182 * ( $conf->exists('svc_acct-usage_threshold')
2183 ? $conf->config('svc_acct-usage_threshold')/100
2188 my $error = $svc_acct->replace;
2189 die $error if $error;
2190 }elsif ( $opt{'op'} eq '-' ){
2192 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2193 return '' if ($threshold eq '' );
2195 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2196 my $error = $svc_acct->replace;
2197 die $error if $error; # email next time, i guess
2199 if ( $warning_template ) {
2200 eval "use FS::Misc qw(send_email)";
2203 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2204 my $cust_main = $cust_pkg->cust_main;
2206 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2207 $cust_main->invoicing_list,
2209 ($opt{'to'} ? $opt{'to'} : ())
2212 my $mimetype = $warning_mimetype;
2213 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2215 my $body = $warning_template->fill_in( HASH => {
2216 'custnum' => $cust_main->custnum,
2217 'username' => $svc_acct->username,
2218 'password' => $svc_acct->_password,
2219 'first' => $cust_main->first,
2220 'last' => $cust_main->getfield('last'),
2221 'pkg' => $cust_pkg->part_pkg->pkg,
2222 'column' => $opt{'column'},
2223 'amount' => $svc_acct->getfield($opt{'column'}),
2224 'threshold' => $threshold,
2228 my $error = send_email(
2229 'from' => $warning_from,
2231 'subject' => $warning_subject,
2232 'content-type' => $mimetype,
2233 'body' => [ map "$_\n", split("\n", $body) ],
2235 die $error if $error;
2238 die "unknown op: " . $opt{'op'};
2246 The $recref stuff in sub check should be cleaned up.
2248 The suspend, unsuspend and cancel methods update the database, but not the
2249 current object. This is probably a bug as it's unexpected and
2252 radius_usergroup_selector? putting web ui components in here? they should
2253 probably live somewhere else...
2255 insertion of RADIUS group stuff in insert could be done with child_objects now
2256 (would probably clean up export of them too)
2260 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2261 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2262 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2263 L<freeside-queued>), L<FS::svc_acct_pop>,
2264 schema.html from the base documentation.