4 use vars qw( @ISA $DEBUG $me $conf
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
10 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
12 $radius_password $radius_ip
18 use FS::UID qw( datasrc );
20 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
25 use FS::cust_main_invoice;
29 use FS::radius_usergroup;
32 use FS::Msgcat qw(gettext);
36 @ISA = qw( FS::svc_Common );
40 $me = '[FS::svc_acct]';
42 #ask FS::UID to run this stuff for us later
43 $FS::UID::callback{'FS::svc_acct'} = sub {
45 $dir_prefix = $conf->config('home');
46 @shells = $conf->config('shells');
47 $usernamemin = $conf->config('usernamemin') || 2;
48 $usernamemax = $conf->config('usernamemax');
49 $passwordmin = $conf->config('passwordmin') || 6;
50 $passwordmax = $conf->config('passwordmax') || 8;
51 $username_letter = $conf->exists('username-letter');
52 $username_letterfirst = $conf->exists('username-letterfirst');
53 $username_noperiod = $conf->exists('username-noperiod');
54 $username_nounderscore = $conf->exists('username-nounderscore');
55 $username_nodash = $conf->exists('username-nodash');
56 $username_uppercase = $conf->exists('username-uppercase');
57 $username_ampersand = $conf->exists('username-ampersand');
58 $dirhash = $conf->config('dirhash') || 0;
59 if ( $conf->exists('welcome_email') ) {
60 $welcome_template = new Text::Template (
62 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
63 ) or warn "can't create welcome email template: $Text::Template::ERROR";
64 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
65 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
66 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
68 $welcome_template = '';
70 $welcome_subject = '';
71 $welcome_mimetype = '';
73 $smtpmachine = $conf->config('smtpmachine');
74 $radius_password = $conf->config('radius-password') || 'Password';
75 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
78 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
79 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
83 my ( $hashref, $cache ) = @_;
84 if ( $hashref->{'svc_acct_svcnum'} ) {
85 $self->{'_domsvc'} = FS::svc_domain->new( {
86 'svcnum' => $hashref->{'domsvc'},
87 'domain' => $hashref->{'svc_acct_domain'},
88 'catchall' => $hashref->{'svc_acct_catchall'},
95 FS::svc_acct - Object methods for svc_acct records
101 $record = new FS::svc_acct \%hash;
102 $record = new FS::svc_acct { 'column' => 'value' };
104 $error = $record->insert;
106 $error = $new_record->replace($old_record);
108 $error = $record->delete;
110 $error = $record->check;
112 $error = $record->suspend;
114 $error = $record->unsuspend;
116 $error = $record->cancel;
118 %hash = $record->radius;
120 %hash = $record->radius_reply;
122 %hash = $record->radius_check;
124 $domain = $record->domain;
126 $svc_domain = $record->svc_domain;
128 $email = $record->email;
130 $seconds_since = $record->seconds_since($timestamp);
134 An FS::svc_acct object represents an account. FS::svc_acct inherits from
135 FS::svc_Common. The following fields are currently supported:
139 =item svcnum - primary key (assigned automatcially for new accounts)
143 =item _password - generated if blank
145 =item sec_phrase - security phrase
147 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
155 =item dir - set automatically if blank (and uid is not)
159 =item quota - (unimplementd)
161 =item slipip - IP address
165 =item domsvc - svcnum from svc_domain
167 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
177 Creates a new account. To add the account to the database, see L<"insert">.
181 sub table { 'svc_acct'; }
183 =item insert [ , OPTION => VALUE ... ]
185 Adds this account to the database. If there is an error, returns the error,
186 otherwise returns false.
188 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
189 defined. An FS::cust_svc record will be created and inserted.
191 The additional field I<usergroup> can optionally be defined; if so it should
192 contain an arrayref of group names. See L<FS::radius_usergroup>.
194 The additional field I<child_objects> can optionally be defined; if so it
195 should contain an arrayref of FS::tablename objects. They will have their
196 svcnum fields set and will be inserted after this record, but before any
199 Currently available options are: I<depend_jobnum>
201 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
202 jobnums), all provisioning jobs will have a dependancy on the supplied
203 jobnum(s) (they will not run until the specific job(s) complete(s)).
205 (TODOC: L<FS::queue> and L<freeside-queued>)
207 (TODOC: new exports!)
216 local $SIG{HUP} = 'IGNORE';
217 local $SIG{INT} = 'IGNORE';
218 local $SIG{QUIT} = 'IGNORE';
219 local $SIG{TERM} = 'IGNORE';
220 local $SIG{TSTP} = 'IGNORE';
221 local $SIG{PIPE} = 'IGNORE';
223 my $oldAutoCommit = $FS::UID::AutoCommit;
224 local $FS::UID::AutoCommit = 0;
227 $error = $self->check;
228 return $error if $error;
230 #no, duplicate checking just got a whole lot more complicated
231 #(perhaps keep this check with a config option to turn on?)
233 #return gettext('username_in_use'). ": ". $self->username
234 # if qsearchs( 'svc_acct', { 'username' => $self->username,
235 # 'domsvc' => $self->domsvc,
238 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
239 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
240 unless ( $cust_svc ) {
241 $dbh->rollback if $oldAutoCommit;
242 return "no cust_svc record found for svcnum ". $self->svcnum;
244 $self->pkgnum($cust_svc->pkgnum);
245 $self->svcpart($cust_svc->svcpart);
248 #new duplicate username checking
250 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
251 unless ( $part_svc ) {
252 $dbh->rollback if $oldAutoCommit;
253 return 'unknown svcpart '. $self->svcpart;
256 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
257 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
258 'domsvc' => $self->domsvc } );
260 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
261 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
262 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
267 if ( @dup_user || @dup_userdomain || @dup_uid ) {
268 my $exports = FS::part_export::export_info('svc_acct');
269 my %conflict_user_svcpart;
270 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
272 foreach my $part_export ( $part_svc->part_export ) {
274 #this will catch to the same exact export
275 my @svcparts = map { $_->svcpart }
276 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
278 #this will catch to exports w/same exporthost+type ???
279 #my @other_part_export = qsearch('part_export', {
280 # 'machine' => $part_export->machine,
281 # 'exporttype' => $part_export->exporttype,
283 #foreach my $other_part_export ( @other_part_export ) {
284 # push @svcparts, map { $_->svcpart }
285 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
288 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
289 #silly kludge to avoid uninitialized value errors
290 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
291 ? $exports->{$part_export->exporttype}{'nodomain'}
293 if ( $nodomain =~ /^Y/i ) {
294 $conflict_user_svcpart{$_} = $part_export->exportnum
297 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
302 foreach my $dup_user ( @dup_user ) {
303 my $dup_svcpart = $dup_user->cust_svc->svcpart;
304 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
305 $dbh->rollback if $oldAutoCommit;
306 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
307 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
311 foreach my $dup_userdomain ( @dup_userdomain ) {
312 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
313 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
314 $dbh->rollback if $oldAutoCommit;
315 return "duplicate username\@domain: conflicts with svcnum ".
316 $dup_userdomain->svcnum. " via exportnum ".
317 $conflict_userdomain_svcpart{$dup_svcpart};
321 foreach my $dup_uid ( @dup_uid ) {
322 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
323 if ( exists($conflict_user_svcpart{$dup_svcpart})
324 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
325 $dbh->rollback if $oldAutoCommit;
326 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
327 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
328 || $conflict_userdomain_svcpart{$dup_svcpart};
334 #see? i told you it was more complicated
337 $error = $self->SUPER::insert(
338 'jobnums' => \@jobnums,
339 'child_objects' => $self->child_objects,
343 $dbh->rollback if $oldAutoCommit;
347 if ( $self->usergroup ) {
348 foreach my $groupname ( @{$self->usergroup} ) {
349 my $radius_usergroup = new FS::radius_usergroup ( {
350 svcnum => $self->svcnum,
351 groupname => $groupname,
353 my $error = $radius_usergroup->insert;
355 $dbh->rollback if $oldAutoCommit;
361 #false laziness with sub replace (and cust_main)
362 my $queue = new FS::queue {
363 'svcnum' => $self->svcnum,
364 'job' => 'FS::svc_acct::append_fuzzyfiles'
366 $error = $queue->insert($self->username);
368 $dbh->rollback if $oldAutoCommit;
369 return "queueing job (transaction rolled back): $error";
372 my $cust_pkg = $self->cust_svc->cust_pkg;
375 my $cust_main = $cust_pkg->cust_main;
377 if ( $conf->exists('emailinvoiceauto') ) {
378 my @invoicing_list = $cust_main->invoicing_list;
379 push @invoicing_list, $self->email;
380 $cust_main->invoicing_list(\@invoicing_list);
385 if ( $welcome_template && $cust_pkg ) {
386 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
388 my $wqueue = new FS::queue {
389 'svcnum' => $self->svcnum,
390 'job' => 'FS::svc_acct::send_email'
392 my $error = $wqueue->insert(
394 'from' => $welcome_from,
395 'subject' => $welcome_subject,
396 'mimetype' => $welcome_mimetype,
397 'body' => $welcome_template->fill_in( HASH => {
398 'custnum' => $self->custnum,
399 'username' => $self->username,
400 'password' => $self->_password,
401 'first' => $cust_main->first,
402 'last' => $cust_main->getfield('last'),
403 'pkg' => $cust_pkg->part_pkg->pkg,
407 $dbh->rollback if $oldAutoCommit;
408 return "error queuing welcome email: $error";
411 if ( $options{'depend_jobnum'} ) {
412 warn "$me depend_jobnum found; adding to welcome email dependancies"
414 if ( ref($options{'depend_jobnum'}) ) {
415 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
416 "to welcome email dependancies"
418 push @jobnums, @{ $options{'depend_jobnum'} };
420 warn "$me adding job $options{'depend_jobnum'} ".
421 "to welcome email dependancies"
423 push @jobnums, $options{'depend_jobnum'};
427 foreach my $jobnum ( @jobnums ) {
428 my $error = $wqueue->depend_insert($jobnum);
430 $dbh->rollback if $oldAutoCommit;
431 return "error queuing welcome email job dependancy: $error";
441 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
447 Deletes this account from the database. If there is an error, returns the
448 error, otherwise returns false.
450 The corresponding FS::cust_svc record will be deleted as well.
452 (TODOC: new exports!)
459 return "can't delete system account" if $self->_check_system;
461 return "Can't delete an account which is a (svc_forward) source!"
462 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
464 return "Can't delete an account which is a (svc_forward) destination!"
465 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
467 return "Can't delete an account with (svc_www) web service!"
468 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
470 # what about records in session ? (they should refer to history table)
472 local $SIG{HUP} = 'IGNORE';
473 local $SIG{INT} = 'IGNORE';
474 local $SIG{QUIT} = 'IGNORE';
475 local $SIG{TERM} = 'IGNORE';
476 local $SIG{TSTP} = 'IGNORE';
477 local $SIG{PIPE} = 'IGNORE';
479 my $oldAutoCommit = $FS::UID::AutoCommit;
480 local $FS::UID::AutoCommit = 0;
483 foreach my $cust_main_invoice (
484 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
486 unless ( defined($cust_main_invoice) ) {
487 warn "WARNING: something's wrong with qsearch";
490 my %hash = $cust_main_invoice->hash;
491 $hash{'dest'} = $self->email;
492 my $new = new FS::cust_main_invoice \%hash;
493 my $error = $new->replace($cust_main_invoice);
495 $dbh->rollback if $oldAutoCommit;
500 foreach my $svc_domain (
501 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
503 my %hash = new FS::svc_domain->hash;
504 $hash{'catchall'} = '';
505 my $new = new FS::svc_domain \%hash;
506 my $error = $new->replace($svc_domain);
508 $dbh->rollback if $oldAutoCommit;
513 foreach my $radius_usergroup (
514 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
516 my $error = $radius_usergroup->delete;
518 $dbh->rollback if $oldAutoCommit;
523 my $error = $self->SUPER::delete;
525 $dbh->rollback if $oldAutoCommit;
529 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
533 =item replace OLD_RECORD
535 Replaces OLD_RECORD with this one in the database. If there is an error,
536 returns the error, otherwise returns false.
538 The additional field I<usergroup> can optionally be defined; if so it should
539 contain an arrayref of group names. See L<FS::radius_usergroup>.
545 my ( $new, $old ) = ( shift, shift );
547 warn "$me replacing $old with $new\n" if $DEBUG;
549 return "can't modify system account" if $old->_check_system;
551 return "Username in use"
552 if $old->username ne $new->username &&
553 qsearchs( 'svc_acct', { 'username' => $new->username,
554 'domsvc' => $new->domsvc,
557 #no warnings 'numeric'; #alas, a 5.006-ism
559 return "Can't change uid!" if $old->uid != $new->uid;
562 #change homdir when we change username
563 $new->setfield('dir', '') if $old->username ne $new->username;
565 local $SIG{HUP} = 'IGNORE';
566 local $SIG{INT} = 'IGNORE';
567 local $SIG{QUIT} = 'IGNORE';
568 local $SIG{TERM} = 'IGNORE';
569 local $SIG{TSTP} = 'IGNORE';
570 local $SIG{PIPE} = 'IGNORE';
572 my $oldAutoCommit = $FS::UID::AutoCommit;
573 local $FS::UID::AutoCommit = 0;
576 # redundant, but so $new->usergroup gets set
577 $error = $new->check;
578 return $error if $error;
580 $old->usergroup( [ $old->radius_groups ] );
581 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
582 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
583 if ( $new->usergroup ) {
584 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
585 my @newgroups = @{$new->usergroup};
586 foreach my $oldgroup ( @{$old->usergroup} ) {
587 if ( grep { $oldgroup eq $_ } @newgroups ) {
588 @newgroups = grep { $oldgroup ne $_ } @newgroups;
591 my $radius_usergroup = qsearchs('radius_usergroup', {
592 svcnum => $old->svcnum,
593 groupname => $oldgroup,
595 my $error = $radius_usergroup->delete;
597 $dbh->rollback if $oldAutoCommit;
598 return "error deleting radius_usergroup $oldgroup: $error";
602 foreach my $newgroup ( @newgroups ) {
603 my $radius_usergroup = new FS::radius_usergroup ( {
604 svcnum => $new->svcnum,
605 groupname => $newgroup,
607 my $error = $radius_usergroup->insert;
609 $dbh->rollback if $oldAutoCommit;
610 return "error adding radius_usergroup $newgroup: $error";
616 $error = $new->SUPER::replace($old);
618 $dbh->rollback if $oldAutoCommit;
619 return $error if $error;
622 if ( $new->username ne $old->username ) {
623 #false laziness with sub insert (and cust_main)
624 my $queue = new FS::queue {
625 'svcnum' => $new->svcnum,
626 'job' => 'FS::svc_acct::append_fuzzyfiles'
628 $error = $queue->insert($new->username);
630 $dbh->rollback if $oldAutoCommit;
631 return "queueing job (transaction rolled back): $error";
635 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
641 Suspends this account by calling export-specific suspend hooks. If there is
642 an error, returns the error, otherwise returns false.
644 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
650 return "can't suspend system account" if $self->_check_system;
651 $self->SUPER::suspend;
656 Unsuspends this account by by calling export-specific suspend hooks. If there
657 is an error, returns the error, otherwise returns false.
659 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
665 my %hash = $self->hash;
666 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
667 $hash{_password} = $1;
668 my $new = new FS::svc_acct ( \%hash );
669 my $error = $new->replace($self);
670 return $error if $error;
673 $self->SUPER::unsuspend;
678 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
680 If the B<auto_unset_catchall> configuration option is set, this method will
681 automatically remove any references to the canceled service in the catchall
682 field of svc_domain. This allows packages that contain both a svc_domain and
683 its catchall svc_acct to be canceled in one step.
688 # Only one thing to do at this level
690 foreach my $svc_domain (
691 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
692 if($conf->exists('auto_unset_catchall')) {
693 my %hash = $svc_domain->hash;
694 $hash{catchall} = '';
695 my $new = new FS::svc_domain ( \%hash );
696 my $error = $new->replace($svc_domain);
697 return $error if $error;
699 return "cannot unprovision svc_acct #".$self->svcnum.
700 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
704 $self->SUPER::cancel;
710 Checks all fields to make sure this is a valid service. If there is an error,
711 returns the error, otherwise returns false. Called by the insert and replace
714 Sets any fixed values; see L<FS::part_svc>.
721 my($recref) = $self->hashref;
723 my $x = $self->setfixed;
724 return $x unless ref($x);
727 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
729 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
732 my $error = $self->ut_numbern('svcnum')
733 #|| $self->ut_number('domsvc')
734 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
735 || $self->ut_textn('sec_phrase')
737 return $error if $error;
739 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
740 if ( $username_uppercase ) {
741 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
742 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
743 $recref->{username} = $1;
745 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
746 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
747 $recref->{username} = $1;
750 if ( $username_letterfirst ) {
751 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
752 } elsif ( $username_letter ) {
753 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
755 if ( $username_noperiod ) {
756 $recref->{username} =~ /\./ and return gettext('illegal_username');
758 if ( $username_nounderscore ) {
759 $recref->{username} =~ /_/ and return gettext('illegal_username');
761 if ( $username_nodash ) {
762 $recref->{username} =~ /\-/ and return gettext('illegal_username');
764 unless ( $username_ampersand ) {
765 $recref->{username} =~ /\&/ and return gettext('illegal_username');
768 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
769 $recref->{popnum} = $1;
770 return "Unknown popnum" unless
771 ! $recref->{popnum} ||
772 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
774 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
776 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
777 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
779 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
780 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
781 #not all systems use gid=uid
782 #you can set a fixed gid in part_svc
784 return "Only root can have uid 0"
785 if $recref->{uid} == 0
786 && $recref->{username} ne 'root'
787 && $recref->{username} ne 'toor';
790 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
791 or return "Illegal directory: ". $recref->{dir};
793 return "Illegal directory"
794 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
795 return "Illegal directory"
796 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
797 unless ( $recref->{dir} ) {
798 $recref->{dir} = $dir_prefix . '/';
799 if ( $dirhash > 0 ) {
800 for my $h ( 1 .. $dirhash ) {
801 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
803 } elsif ( $dirhash < 0 ) {
804 for my $h ( reverse $dirhash .. -1 ) {
805 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
808 $recref->{dir} .= $recref->{username};
812 unless ( $recref->{username} eq 'sync' ) {
813 if ( grep $_ eq $recref->{shell}, @shells ) {
814 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
816 return "Illegal shell \`". $self->shell. "\'; ".
817 $conf->dir. "/shells contains: @shells";
820 $recref->{shell} = '/bin/sync';
824 $recref->{gid} ne '' ?
825 return "Can't have gid without uid" : ( $recref->{gid}='' );
826 $recref->{dir} ne '' ?
827 return "Can't have directory without uid" : ( $recref->{dir}='' );
828 $recref->{shell} ne '' ?
829 return "Can't have shell without uid" : ( $recref->{shell}='' );
832 # $error = $self->ut_textn('finger');
833 # return $error if $error;
834 if ( $self->getfield('finger') eq '' ) {
835 my $cust_pkg = $self->svcnum
836 ? $self->cust_svc->cust_pkg
837 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
839 my $cust_main = $cust_pkg->cust_main;
840 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
843 $self->getfield('finger') =~
844 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
845 or return "Illegal finger: ". $self->getfield('finger');
846 $self->setfield('finger', $1);
848 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
849 $recref->{quota} = $1;
851 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
852 if ( $recref->{slipip} eq '' ) {
853 $recref->{slipip} = '';
854 } elsif ( $recref->{slipip} eq '0e0' ) {
855 $recref->{slipip} = '0e0';
857 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
858 or return "Illegal slipip: ". $self->slipip;
859 $recref->{slipip} = $1;
864 #arbitrary RADIUS stuff; allow ut_textn for now
865 foreach ( grep /^radius_/, fields('svc_acct') ) {
869 #generate a password if it is blank
870 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
871 unless ( $recref->{_password} );
873 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
874 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
875 $recref->{_password} = $1.$3;
876 #uncomment this to encrypt password immediately upon entry, or run
877 #bin/crypt_pw in cron to give new users a window during which their
878 #password is available to techs, for faxing, etc. (also be aware of
880 #$recref->{password} = $1.
881 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
883 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
884 $recref->{_password} = $1.$3;
885 } elsif ( $recref->{_password} eq '*' ) {
886 $recref->{_password} = '*';
887 } elsif ( $recref->{_password} eq '!' ) {
888 $recref->{_password} = '!';
889 } elsif ( $recref->{_password} eq '!!' ) {
890 $recref->{_password} = '!!';
892 #return "Illegal password";
893 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
894 FS::Msgcat::_gettext('illegal_password_characters').
895 ": ". $recref->{_password};
907 scalar( grep { $self->username eq $_ || $self->email eq $_ }
908 $conf->config('system_usernames')
914 Depriciated, use radius_reply instead.
919 carp "FS::svc_acct::radius depriciated, use radius_reply";
925 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
926 reply attributes of this record.
928 Note that this is now the preferred method for reading RADIUS attributes -
929 accessing the columns directly is discouraged, as the column names are
930 expected to change in the future.
939 my($column, $attrib) = ($1, $2);
940 #$attrib =~ s/_/\-/g;
941 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
942 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
943 if ( $self->slipip && $self->slipip ne '0e0' ) {
944 $reply{$radius_ip} = $self->slipip;
951 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
952 check attributes of this record.
954 Note that this is now the preferred method for reading RADIUS attributes -
955 accessing the columns directly is discouraged, as the column names are
956 expected to change in the future.
962 my $password = $self->_password;
963 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
964 ( $pw_attrib => $password,
967 my($column, $attrib) = ($1, $2);
968 #$attrib =~ s/_/\-/g;
969 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
970 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
976 Returns the domain associated with this account.
982 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
983 my $svc_domain = $self->svc_domain
984 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
990 Returns the FS::svc_domain record for this account's domain (see
999 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1004 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1010 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1015 Returns an email address associated with the account.
1021 $self->username. '@'. $self->domain;
1026 Returns an array of FS::acct_snarf records associated with the account.
1027 If the acct_snarf table does not exist or there are no associated records,
1028 an empty list is returned
1034 return () unless dbdef->table('acct_snarf');
1035 eval "use FS::acct_snarf;";
1037 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1040 =item seconds_since TIMESTAMP
1042 Returns the number of seconds this account has been online since TIMESTAMP,
1043 according to the session monitor (see L<FS::Session>).
1045 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1046 L<Time::Local> and L<Date::Parse> for conversion functions.
1050 #note: POD here, implementation in FS::cust_svc
1053 $self->cust_svc->seconds_since(@_);
1056 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1058 Returns the numbers of seconds this account has been online between
1059 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1060 external SQL radacct table, specified via sqlradius export. Sessions which
1061 started in the specified range but are still open are counted from session
1062 start to the end of the range (unless they are over 1 day old, in which case
1063 they are presumed missing their stop record and not counted). Also, sessions
1064 which end in the range but started earlier are counted from the start of the
1065 range to session end. Finally, sessions which start before the range but end
1066 after are counted for the entire range.
1068 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1069 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1074 #note: POD here, implementation in FS::cust_svc
1075 sub seconds_since_sqlradacct {
1077 $self->cust_svc->seconds_since_sqlradacct(@_);
1080 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1082 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1083 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1084 TIMESTAMP_END (exclusive).
1086 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1087 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1092 #note: POD here, implementation in FS::cust_svc
1093 sub attribute_since_sqlradacct {
1095 $self->cust_svc->attribute_since_sqlradacct(@_);
1098 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1100 Returns an array of hash references of this customers login history for the
1101 given time range. (document this better)
1105 sub get_session_history_sqlradacct {
1107 $self->cust_svc->get_session_history_sqlradacct(@_);
1112 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1118 if ( $self->usergroup ) {
1119 #when provisioning records, export callback runs in svc_Common.pm before
1120 #radius_usergroup records can be inserted...
1121 @{$self->usergroup};
1123 map { $_->groupname }
1124 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1128 =item clone_suspended
1130 Constructor used by FS::part_export::_export_suspend fallback. Document
1135 sub clone_suspended {
1137 my %hash = $self->hash;
1138 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1139 new FS::svc_acct \%hash;
1142 =item clone_kludge_unsuspend
1144 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1149 sub clone_kludge_unsuspend {
1151 my %hash = $self->hash;
1152 $hash{_password} = '';
1153 new FS::svc_acct \%hash;
1156 =item check_password
1158 Checks the supplied password against the (possibly encrypted) password in the
1159 database. Returns true for a sucessful authentication, false for no match.
1161 Currently supported encryptions are: classic DES crypt() and MD5
1165 sub check_password {
1166 my($self, $check_password) = @_;
1168 #remove old-style SUSPENDED kludge, they should be allowed to login to
1169 #self-service and pay up
1170 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1172 #eventually should check a "password-encoding" field
1173 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1175 } elsif ( length($password) < 13 ) { #plaintext
1176 $check_password eq $password;
1177 } elsif ( length($password) == 13 ) { #traditional DES crypt
1178 crypt($check_password, $password) eq $password;
1179 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1180 unix_md5_crypt($check_password, $password) eq $password;
1181 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1182 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1183 $self->svcnum. "\n";
1186 warn "Can't check password: Unrecognized encryption for svcnum ".
1187 $self->svcnum. "\n";
1193 =item crypt_password
1195 Returns an encrypted password, either by passing through an encrypted password
1196 in the database or by encrypting a plaintext password from the database.
1200 sub crypt_password {
1202 #false laziness w/shellcommands.pm
1203 #eventually should check a "password-encoding" field
1204 if ( length($self->_password) == 13
1205 || $self->_password =~ /^\$(1|2a?)\$/ ) {
1210 $saltset[int(rand(64))].$saltset[int(rand(64))]
1215 =item virtual_maildir
1217 Returns $domain/maildirs/$username/
1221 sub virtual_maildir {
1223 $self->domain. '/maildirs/'. $self->username. '/';
1234 This is the FS::svc_acct job-queue-able version. It still uses
1235 FS::Misc::send_email under-the-hood.
1242 eval "use FS::Misc qw(send_email)";
1245 $opt{mimetype} ||= 'text/plain';
1246 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1248 my $error = send_email(
1249 'from' => $opt{from},
1251 'subject' => $opt{subject},
1252 'content-type' => $opt{mimetype},
1253 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1255 die $error if $error;
1258 =item check_and_rebuild_fuzzyfiles
1262 sub check_and_rebuild_fuzzyfiles {
1263 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1264 -e "$dir/svc_acct.username"
1265 or &rebuild_fuzzyfiles;
1268 =item rebuild_fuzzyfiles
1272 sub rebuild_fuzzyfiles {
1274 use Fcntl qw(:flock);
1276 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1280 open(USERNAMELOCK,">>$dir/svc_acct.username")
1281 or die "can't open $dir/svc_acct.username: $!";
1282 flock(USERNAMELOCK,LOCK_EX)
1283 or die "can't lock $dir/svc_acct.username: $!";
1285 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1287 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1288 or die "can't open $dir/svc_acct.username.tmp: $!";
1289 print USERNAMECACHE join("\n", @all_username), "\n";
1290 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1292 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1302 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1303 open(USERNAMECACHE,"<$dir/svc_acct.username")
1304 or die "can't open $dir/svc_acct.username: $!";
1305 my @array = map { chomp; $_; } <USERNAMECACHE>;
1306 close USERNAMECACHE;
1310 =item append_fuzzyfiles USERNAME
1314 sub append_fuzzyfiles {
1315 my $username = shift;
1317 &check_and_rebuild_fuzzyfiles;
1319 use Fcntl qw(:flock);
1321 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1323 open(USERNAME,">>$dir/svc_acct.username")
1324 or die "can't open $dir/svc_acct.username: $!";
1325 flock(USERNAME,LOCK_EX)
1326 or die "can't lock $dir/svc_acct.username: $!";
1328 print USERNAME "$username\n";
1330 flock(USERNAME,LOCK_UN)
1331 or die "can't unlock $dir/svc_acct.username: $!";
1339 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1343 sub radius_usergroup_selector {
1344 my $sel_groups = shift;
1345 my %sel_groups = map { $_=>1 } @$sel_groups;
1347 my $selectname = shift || 'radius_usergroup';
1350 my $sth = $dbh->prepare(
1351 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1352 ) or die $dbh->errstr;
1353 $sth->execute() or die $sth->errstr;
1354 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1358 function ${selectname}_doadd(object) {
1359 var myvalue = object.${selectname}_add.value;
1360 var optionName = new Option(myvalue,myvalue,false,true);
1361 var length = object.$selectname.length;
1362 object.$selectname.options[length] = optionName;
1363 object.${selectname}_add.value = "";
1366 <SELECT MULTIPLE NAME="$selectname">
1369 foreach my $group ( @all_groups ) {
1371 if ( $sel_groups{$group} ) {
1372 $html .= ' SELECTED';
1373 $sel_groups{$group} = 0;
1375 $html .= ">$group</OPTION>\n";
1377 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1378 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1380 $html .= '</SELECT>';
1382 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1383 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1392 The $recref stuff in sub check should be cleaned up.
1394 The suspend, unsuspend and cancel methods update the database, but not the
1395 current object. This is probably a bug as it's unexpected and
1398 radius_usergroup_selector? putting web ui components in here? they should
1399 probably live somewhere else...
1401 insertion of RADIUS group stuff in insert could be done with child_objects now
1402 (would probably clean up export of them too)
1406 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1407 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1408 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1409 L<freeside-queued>), L<FS::svc_acct_pop>,
1410 schema.html from the base documentation.