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 foreach my $radius_usergroup (
612 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
614 my $error = $radius_usergroup->delete;
616 $dbh->rollback if $oldAutoCommit;
621 my $error = $self->SUPER::delete;
623 $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;
1674 foreach my $field (keys %$valueref){
1675 $reset = 1 if $valueref->{$field};
1676 $self->setfield($field, $valueref->{$field});
1677 $self->setfield( $field.'_threshold',
1678 int($self->getfield($field)
1679 * ( $conf->exists('svc_acct-usage_threshold')
1680 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1686 my $error = $self->replace;
1687 die $error if $error;
1689 if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) {
1690 my $error = $self->cust_svc->cust_pkg->unsuspend;
1692 $dbh->rollback if $oldAutoCommit;
1693 return "Error unsuspending: $error";
1697 warn "$me update successful; committing\n"
1699 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1705 =item recharge HASHREF
1707 Increments usage columns by the amount specified in HASHREF as
1708 column=>amount pairs.
1713 my ($self, $vhash) = @_;
1716 warn "[$me] recharge called on $self: ". Dumper($self).
1717 "\nwith vhash: ". Dumper($vhash);
1720 my $oldAutoCommit = $FS::UID::AutoCommit;
1721 local $FS::UID::AutoCommit = 0;
1725 foreach my $column (keys %$vhash){
1726 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1730 $dbh->rollback if $oldAutoCommit;
1732 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1737 =item is_rechargeable
1739 Returns true if this svc_account can be "recharged" and false otherwise.
1743 sub is_rechargable {
1745 $self->seconds ne ''
1746 || $self->upbytes ne ''
1747 || $self->downbytes ne ''
1748 || $self->totalbytes ne '';
1751 =item seconds_since TIMESTAMP
1753 Returns the number of seconds this account has been online since TIMESTAMP,
1754 according to the session monitor (see L<FS::Session>).
1756 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1757 L<Time::Local> and L<Date::Parse> for conversion functions.
1761 #note: POD here, implementation in FS::cust_svc
1764 $self->cust_svc->seconds_since(@_);
1767 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1769 Returns the numbers of seconds this account has been online between
1770 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1771 external SQL radacct table, specified via sqlradius export. Sessions which
1772 started in the specified range but are still open are counted from session
1773 start to the end of the range (unless they are over 1 day old, in which case
1774 they are presumed missing their stop record and not counted). Also, sessions
1775 which end in the range but started earlier are counted from the start of the
1776 range to session end. Finally, sessions which start before the range but end
1777 after are counted for the entire range.
1779 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1780 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1785 #note: POD here, implementation in FS::cust_svc
1786 sub seconds_since_sqlradacct {
1788 $self->cust_svc->seconds_since_sqlradacct(@_);
1791 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1793 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1794 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1795 TIMESTAMP_END (exclusive).
1797 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1798 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1803 #note: POD here, implementation in FS::cust_svc
1804 sub attribute_since_sqlradacct {
1806 $self->cust_svc->attribute_since_sqlradacct(@_);
1809 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1811 Returns an array of hash references of this customers login history for the
1812 given time range. (document this better)
1816 sub get_session_history {
1818 $self->cust_svc->get_session_history(@_);
1821 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1826 my($self, $start, $end, %opt ) = @_;
1828 my $did = $self->username; #yup
1830 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1832 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1834 #SELECT $for_update * FROM cdr
1835 # WHERE calldate >= $start #need a conversion
1836 # AND calldate < $end #ditto
1837 # AND ( charged_party = "$did"
1838 # OR charged_party = "$prefix$did" #if length($prefix);
1839 # OR ( ( charged_party IS NULL OR charged_party = '' )
1841 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1844 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1847 if ( length($prefix) ) {
1849 " AND ( charged_party = '$did'
1850 OR charged_party = '$prefix$did'
1851 OR ( ( charged_party IS NULL OR charged_party = '' )
1853 ( src = '$did' OR src = '$prefix$did' )
1859 " AND ( charged_party = '$did'
1860 OR ( ( charged_party IS NULL OR charged_party = '' )
1870 'select' => "$for_update *",
1873 #( freesidestatus IS NULL OR freesidestatus = '' )
1874 'freesidestatus' => '',
1876 'extra_sql' => $charged_or_src,
1884 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1890 if ( $self->usergroup ) {
1891 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1892 unless ref($self->usergroup) eq 'ARRAY';
1893 #when provisioning records, export callback runs in svc_Common.pm before
1894 #radius_usergroup records can be inserted...
1895 @{$self->usergroup};
1897 map { $_->groupname }
1898 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1902 =item clone_suspended
1904 Constructor used by FS::part_export::_export_suspend fallback. Document
1909 sub clone_suspended {
1911 my %hash = $self->hash;
1912 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1913 new FS::svc_acct \%hash;
1916 =item clone_kludge_unsuspend
1918 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1923 sub clone_kludge_unsuspend {
1925 my %hash = $self->hash;
1926 $hash{_password} = '';
1927 new FS::svc_acct \%hash;
1930 =item check_password
1932 Checks the supplied password against the (possibly encrypted) password in the
1933 database. Returns true for a successful authentication, false for no match.
1935 Currently supported encryptions are: classic DES crypt() and MD5
1939 sub check_password {
1940 my($self, $check_password) = @_;
1942 #remove old-style SUSPENDED kludge, they should be allowed to login to
1943 #self-service and pay up
1944 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1946 if ( $self->_password_encoding eq 'ldap' ) {
1948 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
1949 return $auth->match($check_password);
1951 } elsif ( $self->_password_encoding eq 'crypt' ) {
1953 my $auth = from_crypt Authen::Passphrase $self->_password;
1954 return $auth->match($check_password);
1956 } elsif ( $self->_password_encoding eq 'plain' ) {
1958 return $check_password eq $password;
1962 #XXX this could be replaced with Authen::Passphrase stuff
1964 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1966 } elsif ( length($password) < 13 ) { #plaintext
1967 $check_password eq $password;
1968 } elsif ( length($password) == 13 ) { #traditional DES crypt
1969 crypt($check_password, $password) eq $password;
1970 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1971 unix_md5_crypt($check_password, $password) eq $password;
1972 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1973 warn "Can't check password: Blowfish encryption not yet supported, ".
1974 "svcnum ". $self->svcnum. "\n";
1977 warn "Can't check password: Unrecognized encryption for svcnum ".
1978 $self->svcnum. "\n";
1986 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1988 Returns an encrypted password, either by passing through an encrypted password
1989 in the database or by encrypting a plaintext password from the database.
1991 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1992 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1993 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1994 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1995 encryption type is only used if the password is not already encrypted in the
2000 sub crypt_password {
2003 if ( $self->_password_encoding eq 'ldap' ) {
2005 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2008 #XXX this could be replaced with Authen::Passphrase stuff
2010 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2011 if ( $encryption eq 'crypt' ) {
2014 $saltset[int(rand(64))].$saltset[int(rand(64))]
2016 } elsif ( $encryption eq 'md5' ) {
2017 unix_md5_crypt( $self->_password );
2018 } elsif ( $encryption eq 'blowfish' ) {
2019 croak "unknown encryption method $encryption";
2021 croak "unknown encryption method $encryption";
2024 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2028 } elsif ( $self->_password_encoding eq 'crypt' ) {
2030 return $self->_password;
2032 } elsif ( $self->_password_encoding eq 'plain' ) {
2034 #XXX this could be replaced with Authen::Passphrase stuff
2036 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2037 if ( $encryption eq 'crypt' ) {
2040 $saltset[int(rand(64))].$saltset[int(rand(64))]
2042 } elsif ( $encryption eq 'md5' ) {
2043 unix_md5_crypt( $self->_password );
2044 } elsif ( $encryption eq 'blowfish' ) {
2045 croak "unknown encryption method $encryption";
2047 croak "unknown encryption method $encryption";
2052 if ( length($self->_password) == 13
2053 || $self->_password =~ /^\$(1|2a?)\$/
2054 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2060 #XXX this could be replaced with Authen::Passphrase stuff
2062 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2063 if ( $encryption eq 'crypt' ) {
2066 $saltset[int(rand(64))].$saltset[int(rand(64))]
2068 } elsif ( $encryption eq 'md5' ) {
2069 unix_md5_crypt( $self->_password );
2070 } elsif ( $encryption eq 'blowfish' ) {
2071 croak "unknown encryption method $encryption";
2073 croak "unknown encryption method $encryption";
2082 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2084 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2085 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2086 "{MD5}5426824942db4253f87a1009fd5d2d4".
2088 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2089 to work the same as the B</crypt_password> method.
2095 #eventually should check a "password-encoding" field
2097 if ( $self->_password_encoding eq 'ldap' ) {
2099 return $self->_password;
2101 } elsif ( $self->_password_encoding eq 'crypt' ) {
2103 if ( length($self->_password) == 13 ) { #crypt
2104 return '{CRYPT}'. $self->_password;
2105 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2107 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2108 # die "Blowfish encryption not supported in this context, svcnum ".
2109 # $self->svcnum. "\n";
2111 warn "encryption method not (yet?) supported in LDAP context";
2112 return '{CRYPT}*'; #unsupported, should not auth
2115 } elsif ( $self->_password_encoding eq 'plain' ) {
2117 return '{PLAIN}'. $self->_password;
2119 #return '{CLEARTEXT}'. $self->_password; #?
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 warn "Blowfish encryption not supported in this context, svcnum ".
2129 $self->svcnum. "\n";
2132 #are these two necessary anymore?
2133 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2134 return '{SSHA}'. $1;
2135 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2136 return '{NS-MTA-MD5}'. $1;
2139 return '{PLAIN}'. $self->_password;
2141 #return '{CLEARTEXT}'. $self->_password; #?
2143 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2144 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2145 #if ( $encryption eq 'crypt' ) {
2146 # return '{CRYPT}'. crypt(
2148 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2150 #} elsif ( $encryption eq 'md5' ) {
2151 # unix_md5_crypt( $self->_password );
2152 #} elsif ( $encryption eq 'blowfish' ) {
2153 # croak "unknown encryption method $encryption";
2155 # croak "unknown encryption method $encryption";
2163 =item domain_slash_username
2165 Returns $domain/$username/
2169 sub domain_slash_username {
2171 $self->domain. '/'. $self->username. '/';
2174 =item virtual_maildir
2176 Returns $domain/maildirs/$username/
2180 sub virtual_maildir {
2182 $self->domain. '/maildirs/'. $self->username. '/';
2193 This is the FS::svc_acct job-queue-able version. It still uses
2194 FS::Misc::send_email under-the-hood.
2201 eval "use FS::Misc qw(send_email)";
2204 $opt{mimetype} ||= 'text/plain';
2205 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2207 my $error = send_email(
2208 'from' => $opt{from},
2210 'subject' => $opt{subject},
2211 'content-type' => $opt{mimetype},
2212 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2214 die $error if $error;
2217 =item check_and_rebuild_fuzzyfiles
2221 sub check_and_rebuild_fuzzyfiles {
2222 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2223 -e "$dir/svc_acct.username"
2224 or &rebuild_fuzzyfiles;
2227 =item rebuild_fuzzyfiles
2231 sub rebuild_fuzzyfiles {
2233 use Fcntl qw(:flock);
2235 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2239 open(USERNAMELOCK,">>$dir/svc_acct.username")
2240 or die "can't open $dir/svc_acct.username: $!";
2241 flock(USERNAMELOCK,LOCK_EX)
2242 or die "can't lock $dir/svc_acct.username: $!";
2244 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2246 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2247 or die "can't open $dir/svc_acct.username.tmp: $!";
2248 print USERNAMECACHE join("\n", @all_username), "\n";
2249 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2251 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2261 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2262 open(USERNAMECACHE,"<$dir/svc_acct.username")
2263 or die "can't open $dir/svc_acct.username: $!";
2264 my @array = map { chomp; $_; } <USERNAMECACHE>;
2265 close USERNAMECACHE;
2269 =item append_fuzzyfiles USERNAME
2273 sub append_fuzzyfiles {
2274 my $username = shift;
2276 &check_and_rebuild_fuzzyfiles;
2278 use Fcntl qw(:flock);
2280 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2282 open(USERNAME,">>$dir/svc_acct.username")
2283 or die "can't open $dir/svc_acct.username: $!";
2284 flock(USERNAME,LOCK_EX)
2285 or die "can't lock $dir/svc_acct.username: $!";
2287 print USERNAME "$username\n";
2289 flock(USERNAME,LOCK_UN)
2290 or die "can't unlock $dir/svc_acct.username: $!";
2298 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2302 sub radius_usergroup_selector {
2303 my $sel_groups = shift;
2304 my %sel_groups = map { $_=>1 } @$sel_groups;
2306 my $selectname = shift || 'radius_usergroup';
2309 my $sth = $dbh->prepare(
2310 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2311 ) or die $dbh->errstr;
2312 $sth->execute() or die $sth->errstr;
2313 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2317 function ${selectname}_doadd(object) {
2318 var myvalue = object.${selectname}_add.value;
2319 var optionName = new Option(myvalue,myvalue,false,true);
2320 var length = object.$selectname.length;
2321 object.$selectname.options[length] = optionName;
2322 object.${selectname}_add.value = "";
2325 <SELECT MULTIPLE NAME="$selectname">
2328 foreach my $group ( @all_groups ) {
2329 $html .= qq(<OPTION VALUE="$group");
2330 if ( $sel_groups{$group} ) {
2331 $html .= ' SELECTED';
2332 $sel_groups{$group} = 0;
2334 $html .= ">$group</OPTION>\n";
2336 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2337 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2339 $html .= '</SELECT>';
2341 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2342 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2347 =item reached_threshold
2349 Performs some activities when svc_acct thresholds (such as number of seconds
2350 remaining) are reached.
2354 sub reached_threshold {
2357 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2358 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2360 if ( $opt{'op'} eq '+' ){
2361 $svc_acct->setfield( $opt{'column'}.'_threshold',
2362 int($svc_acct->getfield($opt{'column'})
2363 * ( $conf->exists('svc_acct-usage_threshold')
2364 ? $conf->config('svc_acct-usage_threshold')/100
2369 my $error = $svc_acct->replace;
2370 die $error if $error;
2371 }elsif ( $opt{'op'} eq '-' ){
2373 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2374 return '' if ($threshold eq '' );
2376 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2377 my $error = $svc_acct->replace;
2378 die $error if $error; # email next time, i guess
2380 if ( $warning_template ) {
2381 eval "use FS::Misc qw(send_email)";
2384 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2385 my $cust_main = $cust_pkg->cust_main;
2387 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2388 $cust_main->invoicing_list,
2390 ($opt{'to'} ? $opt{'to'} : ())
2393 my $mimetype = $warning_mimetype;
2394 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2396 my $body = $warning_template->fill_in( HASH => {
2397 'custnum' => $cust_main->custnum,
2398 'username' => $svc_acct->username,
2399 'password' => $svc_acct->_password,
2400 'first' => $cust_main->first,
2401 'last' => $cust_main->getfield('last'),
2402 'pkg' => $cust_pkg->part_pkg->pkg,
2403 'column' => $opt{'column'},
2404 'amount' => $svc_acct->getfield($opt{'column'}),
2405 'threshold' => $threshold,
2409 my $error = send_email(
2410 'from' => $warning_from,
2412 'subject' => $warning_subject,
2413 'content-type' => $mimetype,
2414 'body' => [ map "$_\n", split("\n", $body) ],
2416 die $error if $error;
2419 die "unknown op: " . $opt{'op'};
2427 The $recref stuff in sub check should be cleaned up.
2429 The suspend, unsuspend and cancel methods update the database, but not the
2430 current object. This is probably a bug as it's unexpected and
2433 radius_usergroup_selector? putting web ui components in here? they should
2434 probably live somewhere else...
2436 insertion of RADIUS group stuff in insert could be done with child_objects now
2437 (would probably clean up export of them too)
2441 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2442 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2443 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2444 L<freeside-queued>), L<FS::svc_acct_pop>,
2445 schema.html from the base documentation.