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 $warning_template $warning_from $warning_subject $warning_mimetype
14 $radius_password $radius_ip
20 use Crypt::PasswdMD5 1.2;
22 use Authen::Passphrase;
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('warning_email') ) {
68 $warning_template = new Text::Template (
70 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
71 ) or warn "can't create warning email template: $Text::Template::ERROR";
72 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
73 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
74 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
75 $warning_cc = $conf->config('warning_email-cc');
77 $warning_template = '';
79 $warning_subject = '';
80 $warning_mimetype = '';
83 $smtpmachine = $conf->config('smtpmachine');
84 $radius_password = $conf->config('radius-password') || 'Password';
85 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
88 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
89 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
93 my ( $hashref, $cache ) = @_;
94 if ( $hashref->{'svc_acct_svcnum'} ) {
95 $self->{'_domsvc'} = FS::svc_domain->new( {
96 'svcnum' => $hashref->{'domsvc'},
97 'domain' => $hashref->{'svc_acct_domain'},
98 'catchall' => $hashref->{'svc_acct_catchall'},
105 FS::svc_acct - Object methods for svc_acct records
111 $record = new FS::svc_acct \%hash;
112 $record = new FS::svc_acct { 'column' => 'value' };
114 $error = $record->insert;
116 $error = $new_record->replace($old_record);
118 $error = $record->delete;
120 $error = $record->check;
122 $error = $record->suspend;
124 $error = $record->unsuspend;
126 $error = $record->cancel;
128 %hash = $record->radius;
130 %hash = $record->radius_reply;
132 %hash = $record->radius_check;
134 $domain = $record->domain;
136 $svc_domain = $record->svc_domain;
138 $email = $record->email;
140 $seconds_since = $record->seconds_since($timestamp);
144 An FS::svc_acct object represents an account. FS::svc_acct inherits from
145 FS::svc_Common. The following fields are currently supported:
149 =item svcnum - primary key (assigned automatcially for new accounts)
153 =item _password - generated if blank
155 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
157 =item sec_phrase - security phrase
159 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
167 =item dir - set automatically if blank (and uid is not)
171 =item quota - (unimplementd)
173 =item slipip - IP address
183 =item domsvc - svcnum from svc_domain
185 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
187 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
197 Creates a new account. To add the account to the database, see L<"insert">.
204 'longname_plural' => 'Access accounts and mailboxes',
205 'sorts' => [ 'username', 'uid', ],
206 'display_weight' => 10,
207 'cancel_weight' => 50,
209 'dir' => 'Home directory',
212 def_label => 'UID (set to fixed and blank for no UIDs)',
215 'slipip' => 'IP address',
216 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
218 label => 'Access number',
220 select_table => 'svc_acct_pop',
221 select_key => 'popnum',
222 select_label => 'city',
228 disable_default => 1,
235 disable_inventory => 1,
238 '_password' => 'Password',
241 def_label => 'GID (when blank, defaults to UID)',
245 #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)',
247 def_label=> 'Shell (set to blank for no shell tracking)',
249 select_list => [ $conf->config('shells') ],
250 disable_inventory => 1,
253 'finger' => 'Real name (GECOS)',
256 #def_label => 'svcnum from svc_domain',
258 select_table => 'svc_domain',
259 select_key => 'svcnum',
260 select_label => 'domain',
261 disable_inventory => 1,
265 label => 'RADIUS groups',
266 type => 'radius_usergroup_selector',
267 disable_inventory => 1,
270 'seconds' => { label => 'Seconds',
272 disable_inventory => 1,
279 sub table { 'svc_acct'; }
283 #false laziness with edit/svc_acct.cgi
285 my( $self, $groups ) = @_;
286 if ( ref($groups) eq 'ARRAY' ) {
288 } elsif ( length($groups) ) {
289 [ split(/\s*,\s*/, $groups) ];
297 =item search_sql STRING
299 Class method which returns an SQL fragment to search for the given string.
304 my( $class, $string ) = @_;
305 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
306 my( $username, $domain ) = ( $1, $2 );
307 my $q_username = dbh->quote($username);
308 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
310 "svc_acct.username = $q_username AND ( ".
311 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
316 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
318 $class->search_sql_field('slipip', $string ).
320 $class->search_sql_field('username', $string ).
323 $class->search_sql_field('username', $string);
327 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
329 Returns the "username@domain" string for this account.
331 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
343 =item insert [ , OPTION => VALUE ... ]
345 Adds this account to the database. If there is an error, returns the error,
346 otherwise returns false.
348 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
349 defined. An FS::cust_svc record will be created and inserted.
351 The additional field I<usergroup> can optionally be defined; if so it should
352 contain an arrayref of group names. See L<FS::radius_usergroup>.
354 The additional field I<child_objects> can optionally be defined; if so it
355 should contain an arrayref of FS::tablename objects. They will have their
356 svcnum fields set and will be inserted after this record, but before any
357 exports are run. Each element of the array can also optionally be a
358 two-element array reference containing the child object and the name of an
359 alternate field to be filled in with the newly-inserted svcnum, for example
360 C<[ $svc_forward, 'srcsvc' ]>
362 Currently available options are: I<depend_jobnum>
364 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
365 jobnums), all provisioning jobs will have a dependancy on the supplied
366 jobnum(s) (they will not run until the specific job(s) complete(s)).
368 (TODOC: L<FS::queue> and L<freeside-queued>)
370 (TODOC: new exports!)
379 warn "[$me] insert called on $self: ". Dumper($self).
380 "\nwith options: ". Dumper(%options);
383 local $SIG{HUP} = 'IGNORE';
384 local $SIG{INT} = 'IGNORE';
385 local $SIG{QUIT} = 'IGNORE';
386 local $SIG{TERM} = 'IGNORE';
387 local $SIG{TSTP} = 'IGNORE';
388 local $SIG{PIPE} = 'IGNORE';
390 my $oldAutoCommit = $FS::UID::AutoCommit;
391 local $FS::UID::AutoCommit = 0;
394 my $error = $self->check;
395 return $error if $error;
397 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
398 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
399 unless ( $cust_svc ) {
400 $dbh->rollback if $oldAutoCommit;
401 return "no cust_svc record found for svcnum ". $self->svcnum;
403 $self->pkgnum($cust_svc->pkgnum);
404 $self->svcpart($cust_svc->svcpart);
407 $error = $self->_check_duplicate;
409 $dbh->rollback if $oldAutoCommit;
414 $error = $self->SUPER::insert(
415 'jobnums' => \@jobnums,
416 'child_objects' => $self->child_objects,
420 $dbh->rollback if $oldAutoCommit;
424 if ( $self->usergroup ) {
425 foreach my $groupname ( @{$self->usergroup} ) {
426 my $radius_usergroup = new FS::radius_usergroup ( {
427 svcnum => $self->svcnum,
428 groupname => $groupname,
430 my $error = $radius_usergroup->insert;
432 $dbh->rollback if $oldAutoCommit;
438 unless ( $skip_fuzzyfiles ) {
439 $error = $self->queue_fuzzyfiles_update;
441 $dbh->rollback if $oldAutoCommit;
442 return "updating fuzzy search cache: $error";
446 my $cust_pkg = $self->cust_svc->cust_pkg;
449 my $cust_main = $cust_pkg->cust_main;
450 my $agentnum = $cust_main->agentnum;
452 if ( $conf->exists('emailinvoiceautoalways')
453 || $conf->exists('emailinvoiceauto')
454 && ! $cust_main->invoicing_list_emailonly
456 my @invoicing_list = $cust_main->invoicing_list;
457 push @invoicing_list, $self->email;
458 $cust_main->invoicing_list(\@invoicing_list);
462 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
463 = ('','','','','','');
465 if ( $conf->exists('welcome_email', $agentnum) ) {
466 $welcome_template = new Text::Template (
468 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
469 ) or warn "can't create welcome email template: $Text::Template::ERROR";
470 $welcome_from = $conf->config('welcome_email-from', $agentnum);
471 # || 'your-isp-is-dum'
472 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
474 $welcome_subject_template = new Text::Template (
476 SOURCE => $welcome_subject,
477 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
478 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
481 if ( $welcome_template && $cust_pkg ) {
482 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
486 'custnum' => $self->custnum,
487 'username' => $self->username,
488 'password' => $self->_password,
489 'first' => $cust_main->first,
490 'last' => $cust_main->getfield('last'),
491 'pkg' => $cust_pkg->part_pkg->pkg,
493 my $wqueue = new FS::queue {
494 'svcnum' => $self->svcnum,
495 'job' => 'FS::svc_acct::send_email'
497 my $error = $wqueue->insert(
499 'from' => $welcome_from,
500 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
501 'mimetype' => $welcome_mimetype,
502 'body' => $welcome_template->fill_in( HASH => \%hash, ),
505 $dbh->rollback if $oldAutoCommit;
506 return "error queuing welcome email: $error";
509 if ( $options{'depend_jobnum'} ) {
510 warn "$me depend_jobnum found; adding to welcome email dependancies"
512 if ( ref($options{'depend_jobnum'}) ) {
513 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
514 "to welcome email dependancies"
516 push @jobnums, @{ $options{'depend_jobnum'} };
518 warn "$me adding job $options{'depend_jobnum'} ".
519 "to welcome email dependancies"
521 push @jobnums, $options{'depend_jobnum'};
525 foreach my $jobnum ( @jobnums ) {
526 my $error = $wqueue->depend_insert($jobnum);
528 $dbh->rollback if $oldAutoCommit;
529 return "error queuing welcome email job dependancy: $error";
539 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
545 Deletes this account from the database. If there is an error, returns the
546 error, otherwise returns false.
548 The corresponding FS::cust_svc record will be deleted as well.
550 (TODOC: new exports!)
557 return "can't delete system account" if $self->_check_system;
559 return "Can't delete an account which is a (svc_forward) source!"
560 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
562 return "Can't delete an account which is a (svc_forward) destination!"
563 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
565 return "Can't delete an account with (svc_www) web service!"
566 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
568 # what about records in session ? (they should refer to history table)
570 local $SIG{HUP} = 'IGNORE';
571 local $SIG{INT} = 'IGNORE';
572 local $SIG{QUIT} = 'IGNORE';
573 local $SIG{TERM} = 'IGNORE';
574 local $SIG{TSTP} = 'IGNORE';
575 local $SIG{PIPE} = 'IGNORE';
577 my $oldAutoCommit = $FS::UID::AutoCommit;
578 local $FS::UID::AutoCommit = 0;
581 foreach my $cust_main_invoice (
582 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
584 unless ( defined($cust_main_invoice) ) {
585 warn "WARNING: something's wrong with qsearch";
588 my %hash = $cust_main_invoice->hash;
589 $hash{'dest'} = $self->email;
590 my $new = new FS::cust_main_invoice \%hash;
591 my $error = $new->replace($cust_main_invoice);
593 $dbh->rollback if $oldAutoCommit;
598 foreach my $svc_domain (
599 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
601 my %hash = new FS::svc_domain->hash;
602 $hash{'catchall'} = '';
603 my $new = new FS::svc_domain \%hash;
604 my $error = $new->replace($svc_domain);
606 $dbh->rollback if $oldAutoCommit;
611 my $error = $self->SUPER::delete;
613 $dbh->rollback if $oldAutoCommit;
617 foreach my $radius_usergroup (
618 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
620 my $error = $radius_usergroup->delete;
622 $dbh->rollback if $oldAutoCommit;
627 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
631 =item replace OLD_RECORD
633 Replaces OLD_RECORD with this one in the database. If there is an error,
634 returns the error, otherwise returns false.
636 The additional field I<usergroup> can optionally be defined; if so it should
637 contain an arrayref of group names. See L<FS::radius_usergroup>.
643 my ( $new, $old ) = ( shift, shift );
645 warn "$me replacing $old with $new\n" if $DEBUG;
647 # We absolutely have to have an old vs. new record to make this work.
648 if (!defined($old)) {
649 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
652 return "can't modify system account" if $old->_check_system;
655 #no warnings 'numeric'; #alas, a 5.006-ism
658 foreach my $xid (qw( uid gid )) {
660 return "Can't change $xid!"
661 if ! $conf->exists("svc_acct-edit_$xid")
662 && $old->$xid() != $new->$xid()
663 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
668 #change homdir when we change username
669 $new->setfield('dir', '') if $old->username ne $new->username;
671 local $SIG{HUP} = 'IGNORE';
672 local $SIG{INT} = 'IGNORE';
673 local $SIG{QUIT} = 'IGNORE';
674 local $SIG{TERM} = 'IGNORE';
675 local $SIG{TSTP} = 'IGNORE';
676 local $SIG{PIPE} = 'IGNORE';
678 my $oldAutoCommit = $FS::UID::AutoCommit;
679 local $FS::UID::AutoCommit = 0;
682 # redundant, but so $new->usergroup gets set
683 $error = $new->check;
684 return $error if $error;
686 $old->usergroup( [ $old->radius_groups ] );
688 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
689 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
691 if ( $new->usergroup ) {
692 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
693 my @newgroups = @{$new->usergroup};
694 foreach my $oldgroup ( @{$old->usergroup} ) {
695 if ( grep { $oldgroup eq $_ } @newgroups ) {
696 @newgroups = grep { $oldgroup ne $_ } @newgroups;
699 my $radius_usergroup = qsearchs('radius_usergroup', {
700 svcnum => $old->svcnum,
701 groupname => $oldgroup,
703 my $error = $radius_usergroup->delete;
705 $dbh->rollback if $oldAutoCommit;
706 return "error deleting radius_usergroup $oldgroup: $error";
710 foreach my $newgroup ( @newgroups ) {
711 my $radius_usergroup = new FS::radius_usergroup ( {
712 svcnum => $new->svcnum,
713 groupname => $newgroup,
715 my $error = $radius_usergroup->insert;
717 $dbh->rollback if $oldAutoCommit;
718 return "error adding radius_usergroup $newgroup: $error";
724 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
725 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
726 $error = $new->_check_duplicate;
728 $dbh->rollback if $oldAutoCommit;
733 $error = $new->SUPER::replace($old);
735 $dbh->rollback if $oldAutoCommit;
736 return $error if $error;
739 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
740 $error = $new->queue_fuzzyfiles_update;
742 $dbh->rollback if $oldAutoCommit;
743 return "updating fuzzy search cache: $error";
747 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
751 =item queue_fuzzyfiles_update
753 Used by insert & replace to update the fuzzy search cache
757 sub queue_fuzzyfiles_update {
760 local $SIG{HUP} = 'IGNORE';
761 local $SIG{INT} = 'IGNORE';
762 local $SIG{QUIT} = 'IGNORE';
763 local $SIG{TERM} = 'IGNORE';
764 local $SIG{TSTP} = 'IGNORE';
765 local $SIG{PIPE} = 'IGNORE';
767 my $oldAutoCommit = $FS::UID::AutoCommit;
768 local $FS::UID::AutoCommit = 0;
771 my $queue = new FS::queue {
772 'svcnum' => $self->svcnum,
773 'job' => 'FS::svc_acct::append_fuzzyfiles'
775 my $error = $queue->insert($self->username);
777 $dbh->rollback if $oldAutoCommit;
778 return "queueing job (transaction rolled back): $error";
781 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
789 Suspends this account by calling export-specific suspend hooks. If there is
790 an error, returns the error, otherwise returns false.
792 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
798 return "can't suspend system account" if $self->_check_system;
799 $self->SUPER::suspend;
804 Unsuspends this account by by calling export-specific suspend hooks. If there
805 is an error, returns the error, otherwise returns false.
807 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
813 my %hash = $self->hash;
814 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
815 $hash{_password} = $1;
816 my $new = new FS::svc_acct ( \%hash );
817 my $error = $new->replace($self);
818 return $error if $error;
821 $self->SUPER::unsuspend;
826 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
828 If the B<auto_unset_catchall> configuration option is set, this method will
829 automatically remove any references to the canceled service in the catchall
830 field of svc_domain. This allows packages that contain both a svc_domain and
831 its catchall svc_acct to be canceled in one step.
836 # Only one thing to do at this level
838 foreach my $svc_domain (
839 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
840 if($conf->exists('auto_unset_catchall')) {
841 my %hash = $svc_domain->hash;
842 $hash{catchall} = '';
843 my $new = new FS::svc_domain ( \%hash );
844 my $error = $new->replace($svc_domain);
845 return $error if $error;
847 return "cannot unprovision svc_acct #".$self->svcnum.
848 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
852 $self->SUPER::cancel;
858 Checks all fields to make sure this is a valid service. If there is an error,
859 returns the error, otherwise returns false. Called by the insert and replace
862 Sets any fixed values; see L<FS::part_svc>.
869 my($recref) = $self->hashref;
871 my $x = $self->setfixed( $self->_fieldhandlers );
872 return $x unless ref($x);
875 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
877 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
880 my $error = $self->ut_numbern('svcnum')
881 #|| $self->ut_number('domsvc')
882 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
883 || $self->ut_textn('sec_phrase')
884 || $self->ut_snumbern('seconds')
885 || $self->ut_snumbern('upbytes')
886 || $self->ut_snumbern('downbytes')
887 || $self->ut_snumbern('totalbytes')
888 || $self->ut_enum( '_password_encoding',
889 [ '', qw( plain crypt ldap ) ]
892 return $error if $error;
894 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
895 if ( $username_uppercase ) {
896 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
897 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
898 $recref->{username} = $1;
900 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
901 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
902 $recref->{username} = $1;
905 if ( $username_letterfirst ) {
906 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
907 } elsif ( $username_letter ) {
908 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
910 if ( $username_noperiod ) {
911 $recref->{username} =~ /\./ and return gettext('illegal_username');
913 if ( $username_nounderscore ) {
914 $recref->{username} =~ /_/ and return gettext('illegal_username');
916 if ( $username_nodash ) {
917 $recref->{username} =~ /\-/ and return gettext('illegal_username');
919 unless ( $username_ampersand ) {
920 $recref->{username} =~ /\&/ and return gettext('illegal_username');
922 unless ( $username_percent ) {
923 $recref->{username} =~ /\%/ and return gettext('illegal_username');
926 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
927 $recref->{popnum} = $1;
928 return "Unknown popnum" unless
929 ! $recref->{popnum} ||
930 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
932 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
934 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
935 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
937 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
938 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
939 #not all systems use gid=uid
940 #you can set a fixed gid in part_svc
942 return "Only root can have uid 0"
943 if $recref->{uid} == 0
944 && $recref->{username} !~ /^(root|toor|smtp)$/;
946 unless ( $recref->{username} eq 'sync' ) {
947 if ( grep $_ eq $recref->{shell}, @shells ) {
948 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
950 return "Illegal shell \`". $self->shell. "\'; ".
951 "shells configuration value contains: @shells";
954 $recref->{shell} = '/bin/sync';
958 $recref->{gid} ne '' ?
959 return "Can't have gid without uid" : ( $recref->{gid}='' );
960 #$recref->{dir} ne '' ?
961 # return "Can't have directory without uid" : ( $recref->{dir}='' );
962 $recref->{shell} ne '' ?
963 return "Can't have shell without uid" : ( $recref->{shell}='' );
966 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
968 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
969 or return "Illegal directory: ". $recref->{dir};
971 return "Illegal directory"
972 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
973 return "Illegal directory"
974 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
975 unless ( $recref->{dir} ) {
976 $recref->{dir} = $dir_prefix . '/';
977 if ( $dirhash > 0 ) {
978 for my $h ( 1 .. $dirhash ) {
979 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
981 } elsif ( $dirhash < 0 ) {
982 for my $h ( reverse $dirhash .. -1 ) {
983 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
986 $recref->{dir} .= $recref->{username};
992 # $error = $self->ut_textn('finger');
993 # return $error if $error;
994 if ( $self->getfield('finger') eq '' ) {
995 my $cust_pkg = $self->svcnum
996 ? $self->cust_svc->cust_pkg
997 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
999 my $cust_main = $cust_pkg->cust_main;
1000 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1003 $self->getfield('finger') =~
1004 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1005 or return "Illegal finger: ". $self->getfield('finger');
1006 $self->setfield('finger', $1);
1008 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1009 $recref->{quota} = $1;
1011 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1012 if ( $recref->{slipip} eq '' ) {
1013 $recref->{slipip} = '';
1014 } elsif ( $recref->{slipip} eq '0e0' ) {
1015 $recref->{slipip} = '0e0';
1017 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1018 or return "Illegal slipip: ". $self->slipip;
1019 $recref->{slipip} = $1;
1024 #arbitrary RADIUS stuff; allow ut_textn for now
1025 foreach ( grep /^radius_/, fields('svc_acct') ) {
1026 $self->ut_textn($_);
1029 if ( $recref->{_password_encoding} eq 'ldap' ) {
1031 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1032 $recref->{_password} = uc($1).$2;
1034 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1037 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1039 if ( $recref->{_password} =~
1040 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1041 /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1044 $recref->{_password} = $1.$2;
1047 return 'Illegal (crypt-encoded) password';
1050 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1052 #generate a password if it is blank
1053 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1054 unless length( $recref->{_password} );
1056 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1057 $recref->{_password} = $1;
1059 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1060 FS::Msgcat::_gettext('illegal_password_characters').
1061 ": ". $recref->{_password};
1064 if ( $password_noampersand ) {
1065 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1067 if ( $password_noexclamation ) {
1068 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1073 #carp "warning: _password_encoding unspecified\n";
1075 #generate a password if it is blank
1076 unless ( length( $recref->{_password} ) ) {
1078 $recref->{_password} =
1079 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1080 $recref->{_password_encoding} = 'plain';
1084 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1085 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1086 $recref->{_password} = $1.$3;
1087 $recref->{_password_encoding} = 'plain';
1088 } elsif ( $recref->{_password} =~
1089 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1091 $recref->{_password} = $1.$3;
1092 $recref->{_password_encoding} = 'crypt';
1093 } elsif ( $recref->{_password} eq '*' ) {
1094 $recref->{_password} = '*';
1095 $recref->{_password_encoding} = 'crypt';
1096 } elsif ( $recref->{_password} eq '!' ) {
1097 $recref->{_password_encoding} = 'crypt';
1098 $recref->{_password} = '!';
1099 } elsif ( $recref->{_password} eq '!!' ) {
1100 $recref->{_password} = '!!';
1101 $recref->{_password_encoding} = 'crypt';
1103 #return "Illegal password";
1104 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1105 FS::Msgcat::_gettext('illegal_password_characters').
1106 ": ". $recref->{_password};
1113 $self->SUPER::check;
1119 Internal function to check the username against the list of system usernames
1120 from the I<system_usernames> configuration value. Returns true if the username
1121 is listed on the system username list.
1127 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1128 $conf->config('system_usernames')
1132 =item _check_duplicate
1134 Internal function to check for duplicates usernames, username@domain pairs and
1137 If the I<global_unique-username> configuration value is set to B<username> or
1138 B<username@domain>, enforces global username or username@domain uniqueness.
1140 In all cases, check for duplicate uids and usernames or username@domain pairs
1141 per export and with identical I<svcpart> values.
1145 sub _check_duplicate {
1148 my $global_unique = $conf->config('global_unique-username') || 'none';
1149 return '' if $global_unique eq 'disabled';
1151 #this is Pg-specific. what to do for mysql etc?
1152 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
1153 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1154 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1156 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1158 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1159 unless ( $part_svc ) {
1160 return 'unknown svcpart '. $self->svcpart;
1163 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1164 qsearch( 'svc_acct', { 'username' => $self->username } );
1165 return gettext('username_in_use')
1166 if $global_unique eq 'username' && @dup_user;
1168 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1169 qsearch( 'svc_acct', { 'username' => $self->username,
1170 'domsvc' => $self->domsvc } );
1171 return gettext('username_in_use')
1172 if $global_unique eq 'username@domain' && @dup_userdomain;
1175 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1176 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1177 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1178 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1183 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1184 my $exports = FS::part_export::export_info('svc_acct');
1185 my %conflict_user_svcpart;
1186 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1188 foreach my $part_export ( $part_svc->part_export ) {
1190 #this will catch to the same exact export
1191 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1193 #this will catch to exports w/same exporthost+type ???
1194 #my @other_part_export = qsearch('part_export', {
1195 # 'machine' => $part_export->machine,
1196 # 'exporttype' => $part_export->exporttype,
1198 #foreach my $other_part_export ( @other_part_export ) {
1199 # push @svcparts, map { $_->svcpart }
1200 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1203 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1204 #silly kludge to avoid uninitialized value errors
1205 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1206 ? $exports->{$part_export->exporttype}{'nodomain'}
1208 if ( $nodomain =~ /^Y/i ) {
1209 $conflict_user_svcpart{$_} = $part_export->exportnum
1212 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1217 foreach my $dup_user ( @dup_user ) {
1218 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1219 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1220 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1221 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1225 foreach my $dup_userdomain ( @dup_userdomain ) {
1226 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1227 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1228 return "duplicate username\@domain: conflicts with svcnum ".
1229 $dup_userdomain->svcnum. " via exportnum ".
1230 $conflict_userdomain_svcpart{$dup_svcpart};
1234 foreach my $dup_uid ( @dup_uid ) {
1235 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1236 if ( exists($conflict_user_svcpart{$dup_svcpart})
1237 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1238 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1239 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1240 || $conflict_userdomain_svcpart{$dup_svcpart};
1252 Depriciated, use radius_reply instead.
1257 carp "FS::svc_acct::radius depriciated, use radius_reply";
1258 $_[0]->radius_reply;
1263 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1264 reply attributes of this record.
1266 Note that this is now the preferred method for reading RADIUS attributes -
1267 accessing the columns directly is discouraged, as the column names are
1268 expected to change in the future.
1275 return %{ $self->{'radius_reply'} }
1276 if exists $self->{'radius_reply'};
1281 my($column, $attrib) = ($1, $2);
1282 #$attrib =~ s/_/\-/g;
1283 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1284 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1286 if ( $self->slipip && $self->slipip ne '0e0' ) {
1287 $reply{$radius_ip} = $self->slipip;
1290 if ( $self->seconds !~ /^$/ ) {
1291 $reply{'Session-Timeout'} = $self->seconds;
1299 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1300 check attributes of this record.
1302 Note that this is now the preferred method for reading RADIUS attributes -
1303 accessing the columns directly is discouraged, as the column names are
1304 expected to change in the future.
1311 return %{ $self->{'radius_check'} }
1312 if exists $self->{'radius_check'};
1317 my($column, $attrib) = ($1, $2);
1318 #$attrib =~ s/_/\-/g;
1319 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1320 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1322 my $password = $self->_password;
1323 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1325 my $cust_svc = $self->cust_svc;
1326 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1328 my $cust_pkg = $cust_svc->cust_pkg;
1329 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1330 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1339 This method instructs the object to "snapshot" or freeze RADIUS check and
1340 reply attributes to the current values.
1344 #bah, my english is too broken this morning
1345 #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
1346 #the FS::cust_pkg's replace method to trigger the correct export updates when
1347 #package dates change)
1352 $self->{$_} = { $self->$_() }
1353 foreach qw( radius_reply radius_check );
1357 =item forget_snapshot
1359 This methos instructs the object to forget any previously snapshotted
1360 RADIUS check and reply attributes.
1364 sub forget_snapshot {
1368 foreach qw( radius_reply radius_check );
1372 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1374 Returns the domain associated with this account.
1376 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1383 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1384 my $svc_domain = $self->svc_domain(@_)
1385 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1386 $svc_domain->domain;
1391 Returns the FS::svc_domain record for this account's domain (see
1396 # FS::h_svc_acct has a history-aware svc_domain override
1401 ? $self->{'_domsvc'}
1402 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1407 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1411 #inherited from svc_Common
1413 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1415 Returns an email address associated with the account.
1417 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1424 $self->username. '@'. $self->domain(@_);
1429 Returns an array of FS::acct_snarf records associated with the account.
1430 If the acct_snarf table does not exist or there are no associated records,
1431 an empty list is returned
1437 return () unless dbdef->table('acct_snarf');
1438 eval "use FS::acct_snarf;";
1440 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1443 =item decrement_upbytes OCTETS
1445 Decrements the I<upbytes> field of this record by the given amount. If there
1446 is an error, returns the error, otherwise returns false.
1450 sub decrement_upbytes {
1451 shift->_op_usage('-', 'upbytes', @_);
1454 =item increment_upbytes OCTETS
1456 Increments the I<upbytes> field of this record by the given amount. If there
1457 is an error, returns the error, otherwise returns false.
1461 sub increment_upbytes {
1462 shift->_op_usage('+', 'upbytes', @_);
1465 =item decrement_downbytes OCTETS
1467 Decrements the I<downbytes> field of this record by the given amount. If there
1468 is an error, returns the error, otherwise returns false.
1472 sub decrement_downbytes {
1473 shift->_op_usage('-', 'downbytes', @_);
1476 =item increment_downbytes OCTETS
1478 Increments the I<downbytes> field of this record by the given amount. If there
1479 is an error, returns the error, otherwise returns false.
1483 sub increment_downbytes {
1484 shift->_op_usage('+', 'downbytes', @_);
1487 =item decrement_totalbytes OCTETS
1489 Decrements the I<totalbytes> field of this record by the given amount. If there
1490 is an error, returns the error, otherwise returns false.
1494 sub decrement_totalbytes {
1495 shift->_op_usage('-', 'totalbytes', @_);
1498 =item increment_totalbytes OCTETS
1500 Increments the I<totalbytes> field of this record by the given amount. If there
1501 is an error, returns the error, otherwise returns false.
1505 sub increment_totalbytes {
1506 shift->_op_usage('+', 'totalbytes', @_);
1509 =item decrement_seconds SECONDS
1511 Decrements the I<seconds> field of this record by the given amount. If there
1512 is an error, returns the error, otherwise returns false.
1516 sub decrement_seconds {
1517 shift->_op_usage('-', 'seconds', @_);
1520 =item increment_seconds SECONDS
1522 Increments the I<seconds> field of this record by the given amount. If there
1523 is an error, returns the error, otherwise returns false.
1527 sub increment_seconds {
1528 shift->_op_usage('+', 'seconds', @_);
1536 my %op2condition = (
1537 '-' => sub { my($self, $column, $amount) = @_;
1538 $self->$column - $amount <= 0;
1540 '+' => sub { my($self, $column, $amount) = @_;
1541 $self->$column + $amount > 0;
1544 my %op2warncondition = (
1545 '-' => sub { my($self, $column, $amount) = @_;
1546 my $threshold = $column . '_threshold';
1547 $self->$column - $amount <= $self->$threshold + 0;
1549 '+' => sub { my($self, $column, $amount) = @_;
1550 $self->$column + $amount > 0;
1555 my( $self, $op, $column, $amount ) = @_;
1557 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1558 ' ('. $self->email. "): $op $amount\n"
1561 return '' unless $amount;
1563 local $SIG{HUP} = 'IGNORE';
1564 local $SIG{INT} = 'IGNORE';
1565 local $SIG{QUIT} = 'IGNORE';
1566 local $SIG{TERM} = 'IGNORE';
1567 local $SIG{TSTP} = 'IGNORE';
1568 local $SIG{PIPE} = 'IGNORE';
1570 my $oldAutoCommit = $FS::UID::AutoCommit;
1571 local $FS::UID::AutoCommit = 0;
1574 my $sql = "UPDATE svc_acct SET $column = ".
1575 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1576 " $op ? WHERE svcnum = ?";
1580 my $sth = $dbh->prepare( $sql )
1581 or die "Error preparing $sql: ". $dbh->errstr;
1582 my $rv = $sth->execute($amount, $self->svcnum);
1583 die "Error executing $sql: ". $sth->errstr
1584 unless defined($rv);
1585 die "Can't update $column for svcnum". $self->svcnum
1588 my $action = $op2action{$op};
1590 if ( &{$op2condition{$op}}($self, $column, $amount) ) {
1591 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1592 if ($part_export->option('overlimit_groups')) {
1594 my $other = new FS::svc_acct $self->hashref;
1595 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1596 ($self, $part_export->option('overlimit_groups'));
1597 $other->usergroup( $groups );
1598 if ($action eq 'suspend'){
1599 $new = $other; $old = $self;
1601 $new = $self; $old = $other;
1603 my $error = $part_export->export_replace($new, $old);
1605 $dbh->rollback if $oldAutoCommit;
1606 return "Error replacing radius groups in export, ${op}: $error";
1612 if ( $conf->exists("svc_acct-usage_$action")
1613 && &{$op2condition{$op}}($self, $column, $amount) ) {
1614 #my $error = $self->$action();
1615 my $error = $self->cust_svc->cust_pkg->$action();
1617 $dbh->rollback if $oldAutoCommit;
1618 return "Error ${action}ing: $error";
1622 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1623 my $wqueue = new FS::queue {
1624 'svcnum' => $self->svcnum,
1625 'job' => 'FS::svc_acct::reached_threshold',
1630 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1634 my $error = $wqueue->insert(
1635 'svcnum' => $self->svcnum,
1637 'column' => $column,
1641 $dbh->rollback if $oldAutoCommit;
1642 return "Error queuing threshold activity: $error";
1646 warn "$me update successful; committing\n"
1648 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1654 my( $self, $valueref ) = @_;
1656 warn "$me set_usage called for svcnum ". $self->svcnum.
1657 ' ('. $self->email. "): ".
1658 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1661 local $SIG{HUP} = 'IGNORE';
1662 local $SIG{INT} = 'IGNORE';
1663 local $SIG{QUIT} = 'IGNORE';
1664 local $SIG{TERM} = 'IGNORE';
1665 local $SIG{TSTP} = 'IGNORE';
1666 local $SIG{PIPE} = 'IGNORE';
1668 local $FS::svc_Common::noexport_hack = 1;
1669 my $oldAutoCommit = $FS::UID::AutoCommit;
1670 local $FS::UID::AutoCommit = 0;
1675 foreach my $field (keys %$valueref){
1676 $reset = 1 if $valueref->{$field};
1677 $self->setfield($field, $valueref->{$field});
1678 $self->setfield( $field.'_threshold',
1679 int($self->getfield($field)
1680 * ( $conf->exists('svc_acct-usage_threshold')
1681 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1686 $handyhash{$field} = $self->getfield($field);
1687 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1689 #my $error = $self->replace; #NO! we avoid the call to ->check for
1690 #die $error if $error; #services not explicity changed via the UI
1692 my $sql = "UPDATE svc_acct SET " .
1693 join (',', map { "$_ = ?" } (keys %handyhash) ).
1694 " WHERE svcnum = ?";
1699 if (scalar(keys %handyhash)) {
1700 my $sth = $dbh->prepare( $sql )
1701 or die "Error preparing $sql: ". $dbh->errstr;
1702 my $rv = $sth->execute((grep{$_} values %handyhash), $self->svcnum);
1703 die "Error executing $sql: ". $sth->errstr
1704 unless defined($rv);
1705 die "Can't update usage for svcnum ". $self->svcnum
1709 if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) {
1710 my $error = $self->cust_svc->cust_pkg->unsuspend;
1712 $dbh->rollback if $oldAutoCommit;
1713 return "Error unsuspending: $error";
1717 warn "$me update successful; committing\n"
1719 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1725 =item recharge HASHREF
1727 Increments usage columns by the amount specified in HASHREF as
1728 column=>amount pairs.
1733 my ($self, $vhash) = @_;
1736 warn "[$me] recharge called on $self: ". Dumper($self).
1737 "\nwith vhash: ". Dumper($vhash);
1740 my $oldAutoCommit = $FS::UID::AutoCommit;
1741 local $FS::UID::AutoCommit = 0;
1745 foreach my $column (keys %$vhash){
1746 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1750 $dbh->rollback if $oldAutoCommit;
1752 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1757 =item is_rechargeable
1759 Returns true if this svc_account can be "recharged" and false otherwise.
1763 sub is_rechargable {
1765 $self->seconds ne ''
1766 || $self->upbytes ne ''
1767 || $self->downbytes ne ''
1768 || $self->totalbytes ne '';
1771 =item seconds_since TIMESTAMP
1773 Returns the number of seconds this account has been online since TIMESTAMP,
1774 according to the session monitor (see L<FS::Session>).
1776 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1777 L<Time::Local> and L<Date::Parse> for conversion functions.
1781 #note: POD here, implementation in FS::cust_svc
1784 $self->cust_svc->seconds_since(@_);
1787 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1789 Returns the numbers of seconds this account has been online between
1790 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1791 external SQL radacct table, specified via sqlradius export. Sessions which
1792 started in the specified range but are still open are counted from session
1793 start to the end of the range (unless they are over 1 day old, in which case
1794 they are presumed missing their stop record and not counted). Also, sessions
1795 which end in the range but started earlier are counted from the start of the
1796 range to session end. Finally, sessions which start before the range but end
1797 after are counted for the entire range.
1799 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1800 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1805 #note: POD here, implementation in FS::cust_svc
1806 sub seconds_since_sqlradacct {
1808 $self->cust_svc->seconds_since_sqlradacct(@_);
1811 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1813 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1814 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1815 TIMESTAMP_END (exclusive).
1817 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1818 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1823 #note: POD here, implementation in FS::cust_svc
1824 sub attribute_since_sqlradacct {
1826 $self->cust_svc->attribute_since_sqlradacct(@_);
1829 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1831 Returns an array of hash references of this customers login history for the
1832 given time range. (document this better)
1836 sub get_session_history {
1838 $self->cust_svc->get_session_history(@_);
1841 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1846 my($self, $start, $end, %opt ) = @_;
1848 my $did = $self->username; #yup
1850 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1852 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1854 #SELECT $for_update * FROM cdr
1855 # WHERE calldate >= $start #need a conversion
1856 # AND calldate < $end #ditto
1857 # AND ( charged_party = "$did"
1858 # OR charged_party = "$prefix$did" #if length($prefix);
1859 # OR ( ( charged_party IS NULL OR charged_party = '' )
1861 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1864 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1867 if ( length($prefix) ) {
1869 " AND ( charged_party = '$did'
1870 OR charged_party = '$prefix$did'
1871 OR ( ( charged_party IS NULL OR charged_party = '' )
1873 ( src = '$did' OR src = '$prefix$did' )
1879 " AND ( charged_party = '$did'
1880 OR ( ( charged_party IS NULL OR charged_party = '' )
1890 'select' => "$for_update *",
1893 #( freesidestatus IS NULL OR freesidestatus = '' )
1894 'freesidestatus' => '',
1896 'extra_sql' => $charged_or_src,
1904 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1910 if ( $self->usergroup ) {
1911 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1912 unless ref($self->usergroup) eq 'ARRAY';
1913 #when provisioning records, export callback runs in svc_Common.pm before
1914 #radius_usergroup records can be inserted...
1915 @{$self->usergroup};
1917 map { $_->groupname }
1918 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1922 =item clone_suspended
1924 Constructor used by FS::part_export::_export_suspend fallback. Document
1929 sub clone_suspended {
1931 my %hash = $self->hash;
1932 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1933 new FS::svc_acct \%hash;
1936 =item clone_kludge_unsuspend
1938 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1943 sub clone_kludge_unsuspend {
1945 my %hash = $self->hash;
1946 $hash{_password} = '';
1947 new FS::svc_acct \%hash;
1950 =item check_password
1952 Checks the supplied password against the (possibly encrypted) password in the
1953 database. Returns true for a successful authentication, false for no match.
1955 Currently supported encryptions are: classic DES crypt() and MD5
1959 sub check_password {
1960 my($self, $check_password) = @_;
1962 #remove old-style SUSPENDED kludge, they should be allowed to login to
1963 #self-service and pay up
1964 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1966 if ( $self->_password_encoding eq 'ldap' ) {
1968 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
1969 return $auth->match($check_password);
1971 } elsif ( $self->_password_encoding eq 'crypt' ) {
1973 my $auth = from_crypt Authen::Passphrase $self->_password;
1974 return $auth->match($check_password);
1976 } elsif ( $self->_password_encoding eq 'plain' ) {
1978 return $check_password eq $password;
1982 #XXX this could be replaced with Authen::Passphrase stuff
1984 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1986 } elsif ( length($password) < 13 ) { #plaintext
1987 $check_password eq $password;
1988 } elsif ( length($password) == 13 ) { #traditional DES crypt
1989 crypt($check_password, $password) eq $password;
1990 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1991 unix_md5_crypt($check_password, $password) eq $password;
1992 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1993 warn "Can't check password: Blowfish encryption not yet supported, ".
1994 "svcnum ". $self->svcnum. "\n";
1997 warn "Can't check password: Unrecognized encryption for svcnum ".
1998 $self->svcnum. "\n";
2006 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2008 Returns an encrypted password, either by passing through an encrypted password
2009 in the database or by encrypting a plaintext password from the database.
2011 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2012 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2013 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2014 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2015 encryption type is only used if the password is not already encrypted in the
2020 sub crypt_password {
2023 if ( $self->_password_encoding eq 'ldap' ) {
2025 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2028 #XXX this could be replaced with Authen::Passphrase stuff
2030 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2031 if ( $encryption eq 'crypt' ) {
2034 $saltset[int(rand(64))].$saltset[int(rand(64))]
2036 } elsif ( $encryption eq 'md5' ) {
2037 unix_md5_crypt( $self->_password );
2038 } elsif ( $encryption eq 'blowfish' ) {
2039 croak "unknown encryption method $encryption";
2041 croak "unknown encryption method $encryption";
2044 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2048 } elsif ( $self->_password_encoding eq 'crypt' ) {
2050 return $self->_password;
2052 } elsif ( $self->_password_encoding eq 'plain' ) {
2054 #XXX this could be replaced with Authen::Passphrase stuff
2056 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2057 if ( $encryption eq 'crypt' ) {
2060 $saltset[int(rand(64))].$saltset[int(rand(64))]
2062 } elsif ( $encryption eq 'md5' ) {
2063 unix_md5_crypt( $self->_password );
2064 } elsif ( $encryption eq 'blowfish' ) {
2065 croak "unknown encryption method $encryption";
2067 croak "unknown encryption method $encryption";
2072 if ( length($self->_password) == 13
2073 || $self->_password =~ /^\$(1|2a?)\$/
2074 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2080 #XXX this could be replaced with Authen::Passphrase stuff
2082 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2083 if ( $encryption eq 'crypt' ) {
2086 $saltset[int(rand(64))].$saltset[int(rand(64))]
2088 } elsif ( $encryption eq 'md5' ) {
2089 unix_md5_crypt( $self->_password );
2090 } elsif ( $encryption eq 'blowfish' ) {
2091 croak "unknown encryption method $encryption";
2093 croak "unknown encryption method $encryption";
2102 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2104 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2105 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2106 "{MD5}5426824942db4253f87a1009fd5d2d4".
2108 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2109 to work the same as the B</crypt_password> method.
2115 #eventually should check a "password-encoding" field
2117 if ( $self->_password_encoding eq 'ldap' ) {
2119 return $self->_password;
2121 } elsif ( $self->_password_encoding eq 'crypt' ) {
2123 if ( length($self->_password) == 13 ) { #crypt
2124 return '{CRYPT}'. $self->_password;
2125 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2127 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2128 # die "Blowfish encryption not supported in this context, svcnum ".
2129 # $self->svcnum. "\n";
2131 warn "encryption method not (yet?) supported in LDAP context";
2132 return '{CRYPT}*'; #unsupported, should not auth
2135 } elsif ( $self->_password_encoding eq 'plain' ) {
2137 return '{PLAIN}'. $self->_password;
2139 #return '{CLEARTEXT}'. $self->_password; #?
2143 if ( length($self->_password) == 13 ) { #crypt
2144 return '{CRYPT}'. $self->_password;
2145 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2147 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2148 warn "Blowfish encryption not supported in this context, svcnum ".
2149 $self->svcnum. "\n";
2152 #are these two necessary anymore?
2153 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2154 return '{SSHA}'. $1;
2155 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2156 return '{NS-MTA-MD5}'. $1;
2159 return '{PLAIN}'. $self->_password;
2161 #return '{CLEARTEXT}'. $self->_password; #?
2163 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2164 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2165 #if ( $encryption eq 'crypt' ) {
2166 # return '{CRYPT}'. crypt(
2168 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2170 #} elsif ( $encryption eq 'md5' ) {
2171 # unix_md5_crypt( $self->_password );
2172 #} elsif ( $encryption eq 'blowfish' ) {
2173 # croak "unknown encryption method $encryption";
2175 # croak "unknown encryption method $encryption";
2183 =item domain_slash_username
2185 Returns $domain/$username/
2189 sub domain_slash_username {
2191 $self->domain. '/'. $self->username. '/';
2194 =item virtual_maildir
2196 Returns $domain/maildirs/$username/
2200 sub virtual_maildir {
2202 $self->domain. '/maildirs/'. $self->username. '/';
2213 This is the FS::svc_acct job-queue-able version. It still uses
2214 FS::Misc::send_email under-the-hood.
2221 eval "use FS::Misc qw(send_email)";
2224 $opt{mimetype} ||= 'text/plain';
2225 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2227 my $error = send_email(
2228 'from' => $opt{from},
2230 'subject' => $opt{subject},
2231 'content-type' => $opt{mimetype},
2232 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2234 die $error if $error;
2237 =item check_and_rebuild_fuzzyfiles
2241 sub check_and_rebuild_fuzzyfiles {
2242 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2243 -e "$dir/svc_acct.username"
2244 or &rebuild_fuzzyfiles;
2247 =item rebuild_fuzzyfiles
2251 sub rebuild_fuzzyfiles {
2253 use Fcntl qw(:flock);
2255 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2259 open(USERNAMELOCK,">>$dir/svc_acct.username")
2260 or die "can't open $dir/svc_acct.username: $!";
2261 flock(USERNAMELOCK,LOCK_EX)
2262 or die "can't lock $dir/svc_acct.username: $!";
2264 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2266 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2267 or die "can't open $dir/svc_acct.username.tmp: $!";
2268 print USERNAMECACHE join("\n", @all_username), "\n";
2269 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2271 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2281 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2282 open(USERNAMECACHE,"<$dir/svc_acct.username")
2283 or die "can't open $dir/svc_acct.username: $!";
2284 my @array = map { chomp; $_; } <USERNAMECACHE>;
2285 close USERNAMECACHE;
2289 =item append_fuzzyfiles USERNAME
2293 sub append_fuzzyfiles {
2294 my $username = shift;
2296 &check_and_rebuild_fuzzyfiles;
2298 use Fcntl qw(:flock);
2300 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2302 open(USERNAME,">>$dir/svc_acct.username")
2303 or die "can't open $dir/svc_acct.username: $!";
2304 flock(USERNAME,LOCK_EX)
2305 or die "can't lock $dir/svc_acct.username: $!";
2307 print USERNAME "$username\n";
2309 flock(USERNAME,LOCK_UN)
2310 or die "can't unlock $dir/svc_acct.username: $!";
2318 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2322 sub radius_usergroup_selector {
2323 my $sel_groups = shift;
2324 my %sel_groups = map { $_=>1 } @$sel_groups;
2326 my $selectname = shift || 'radius_usergroup';
2329 my $sth = $dbh->prepare(
2330 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2331 ) or die $dbh->errstr;
2332 $sth->execute() or die $sth->errstr;
2333 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2337 function ${selectname}_doadd(object) {
2338 var myvalue = object.${selectname}_add.value;
2339 var optionName = new Option(myvalue,myvalue,false,true);
2340 var length = object.$selectname.length;
2341 object.$selectname.options[length] = optionName;
2342 object.${selectname}_add.value = "";
2345 <SELECT MULTIPLE NAME="$selectname">
2348 foreach my $group ( @all_groups ) {
2349 $html .= qq(<OPTION VALUE="$group");
2350 if ( $sel_groups{$group} ) {
2351 $html .= ' SELECTED';
2352 $sel_groups{$group} = 0;
2354 $html .= ">$group</OPTION>\n";
2356 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2357 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2359 $html .= '</SELECT>';
2361 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2362 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2367 =item reached_threshold
2369 Performs some activities when svc_acct thresholds (such as number of seconds
2370 remaining) are reached.
2374 sub reached_threshold {
2377 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2378 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2380 if ( $opt{'op'} eq '+' ){
2381 $svc_acct->setfield( $opt{'column'}.'_threshold',
2382 int($svc_acct->getfield($opt{'column'})
2383 * ( $conf->exists('svc_acct-usage_threshold')
2384 ? $conf->config('svc_acct-usage_threshold')/100
2389 my $error = $svc_acct->replace;
2390 die $error if $error;
2391 }elsif ( $opt{'op'} eq '-' ){
2393 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2394 return '' if ($threshold eq '' );
2396 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2397 my $error = $svc_acct->replace;
2398 die $error if $error; # email next time, i guess
2400 if ( $warning_template ) {
2401 eval "use FS::Misc qw(send_email)";
2404 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2405 my $cust_main = $cust_pkg->cust_main;
2407 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2408 $cust_main->invoicing_list,
2410 ($opt{'to'} ? $opt{'to'} : ())
2413 my $mimetype = $warning_mimetype;
2414 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2416 my $body = $warning_template->fill_in( HASH => {
2417 'custnum' => $cust_main->custnum,
2418 'username' => $svc_acct->username,
2419 'password' => $svc_acct->_password,
2420 'first' => $cust_main->first,
2421 'last' => $cust_main->getfield('last'),
2422 'pkg' => $cust_pkg->part_pkg->pkg,
2423 'column' => $opt{'column'},
2424 'amount' => $svc_acct->getfield($opt{'column'}),
2425 'threshold' => $threshold,
2429 my $error = send_email(
2430 'from' => $warning_from,
2432 'subject' => $warning_subject,
2433 'content-type' => $mimetype,
2434 'body' => [ map "$_\n", split("\n", $body) ],
2436 die $error if $error;
2439 die "unknown op: " . $opt{'op'};
2447 The $recref stuff in sub check should be cleaned up.
2449 The suspend, unsuspend and cancel methods update the database, but not the
2450 current object. This is probably a bug as it's unexpected and
2453 radius_usergroup_selector? putting web ui components in here? they should
2454 probably live somewhere else...
2456 insertion of RADIUS group stuff in insert could be done with child_objects now
2457 (would probably clean up export of them too)
2461 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2462 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2463 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2464 L<freeside-queued>), L<FS::svc_acct_pop>,
2465 schema.html from the base documentation.