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);
34 @ISA = qw( FS::svc_Common );
38 $me = '[FS::svc_acct]';
40 #ask FS::UID to run this stuff for us later
41 $FS::UID::callback{'FS::svc_acct'} = sub {
43 $dir_prefix = $conf->config('home');
44 @shells = $conf->config('shells');
45 $usernamemin = $conf->config('usernamemin') || 2;
46 $usernamemax = $conf->config('usernamemax');
47 $passwordmin = $conf->config('passwordmin') || 6;
48 $passwordmax = $conf->config('passwordmax') || 8;
49 $username_letter = $conf->exists('username-letter');
50 $username_letterfirst = $conf->exists('username-letterfirst');
51 $username_noperiod = $conf->exists('username-noperiod');
52 $username_nounderscore = $conf->exists('username-nounderscore');
53 $username_nodash = $conf->exists('username-nodash');
54 $username_uppercase = $conf->exists('username-uppercase');
55 $username_ampersand = $conf->exists('username-ampersand');
56 $dirhash = $conf->config('dirhash') || 0;
57 if ( $conf->exists('welcome_email') ) {
58 $welcome_template = new Text::Template (
60 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
61 ) or warn "can't create welcome email template: $Text::Template::ERROR";
62 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
63 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
64 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
66 $welcome_template = '';
68 $welcome_subject = '';
69 $welcome_mimetype = '';
71 $smtpmachine = $conf->config('smtpmachine');
72 $radius_password = $conf->config('radius-password') || 'Password';
73 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
76 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
77 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
81 my ( $hashref, $cache ) = @_;
82 if ( $hashref->{'svc_acct_svcnum'} ) {
83 $self->{'_domsvc'} = FS::svc_domain->new( {
84 'svcnum' => $hashref->{'domsvc'},
85 'domain' => $hashref->{'svc_acct_domain'},
86 'catchall' => $hashref->{'svc_acct_catchall'},
93 FS::svc_acct - Object methods for svc_acct records
99 $record = new FS::svc_acct \%hash;
100 $record = new FS::svc_acct { 'column' => 'value' };
102 $error = $record->insert;
104 $error = $new_record->replace($old_record);
106 $error = $record->delete;
108 $error = $record->check;
110 $error = $record->suspend;
112 $error = $record->unsuspend;
114 $error = $record->cancel;
116 %hash = $record->radius;
118 %hash = $record->radius_reply;
120 %hash = $record->radius_check;
122 $domain = $record->domain;
124 $svc_domain = $record->svc_domain;
126 $email = $record->email;
128 $seconds_since = $record->seconds_since($timestamp);
132 An FS::svc_acct object represents an account. FS::svc_acct inherits from
133 FS::svc_Common. The following fields are currently supported:
137 =item svcnum - primary key (assigned automatcially for new accounts)
141 =item _password - generated if blank
143 =item sec_phrase - security phrase
145 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
153 =item dir - set automatically if blank (and uid is not)
157 =item quota - (unimplementd)
159 =item slipip - IP address
163 =item domsvc - svcnum from svc_domain
165 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
175 Creates a new account. To add the account to the database, see L<"insert">.
179 sub table { 'svc_acct'; }
181 =item insert [ , OPTION => VALUE ... ]
183 Adds this account to the database. If there is an error, returns the error,
184 otherwise returns false.
186 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
187 defined. An FS::cust_svc record will be created and inserted.
189 The additional field I<usergroup> can optionally be defined; if so it should
190 contain an arrayref of group names. See L<FS::radius_usergroup>.
192 The additional field I<child_objects> can optionally be defined; if so it
193 should contain an arrayref of FS::tablename objects. They will have their
194 svcnum fields set and will be inserted after this record, but before any
197 Currently available options are: I<depend_jobnum>
199 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
200 jobnums), all provisioning jobs will have a dependancy on the supplied
201 jobnum(s) (they will not run until the specific job(s) complete(s)).
203 (TODOC: L<FS::queue> and L<freeside-queued>)
205 (TODOC: new exports!)
214 local $SIG{HUP} = 'IGNORE';
215 local $SIG{INT} = 'IGNORE';
216 local $SIG{QUIT} = 'IGNORE';
217 local $SIG{TERM} = 'IGNORE';
218 local $SIG{TSTP} = 'IGNORE';
219 local $SIG{PIPE} = 'IGNORE';
221 my $oldAutoCommit = $FS::UID::AutoCommit;
222 local $FS::UID::AutoCommit = 0;
225 $error = $self->check;
226 return $error if $error;
228 #no, duplicate checking just got a whole lot more complicated
229 #(perhaps keep this check with a config option to turn on?)
231 #return gettext('username_in_use'). ": ". $self->username
232 # if qsearchs( 'svc_acct', { 'username' => $self->username,
233 # 'domsvc' => $self->domsvc,
236 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
237 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
238 unless ( $cust_svc ) {
239 $dbh->rollback if $oldAutoCommit;
240 return "no cust_svc record found for svcnum ". $self->svcnum;
242 $self->pkgnum($cust_svc->pkgnum);
243 $self->svcpart($cust_svc->svcpart);
246 #new duplicate username checking
248 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
249 unless ( $part_svc ) {
250 $dbh->rollback if $oldAutoCommit;
251 return 'unknown svcpart '. $self->svcpart;
254 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
255 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
256 'domsvc' => $self->domsvc } );
258 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
259 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
260 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
265 if ( @dup_user || @dup_userdomain || @dup_uid ) {
266 my $exports = FS::part_export::export_info('svc_acct');
267 my %conflict_user_svcpart;
268 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
270 foreach my $part_export ( $part_svc->part_export ) {
272 #this will catch to the same exact export
273 my @svcparts = map { $_->svcpart }
274 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
276 #this will catch to exports w/same exporthost+type ???
277 #my @other_part_export = qsearch('part_export', {
278 # 'machine' => $part_export->machine,
279 # 'exporttype' => $part_export->exporttype,
281 #foreach my $other_part_export ( @other_part_export ) {
282 # push @svcparts, map { $_->svcpart }
283 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
286 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
287 #silly kludge to avoid uninitialized value errors
288 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
289 ? $exports->{$part_export->exporttype}{'nodomain'}
291 if ( $nodomain =~ /^Y/i ) {
292 $conflict_user_svcpart{$_} = $part_export->exportnum
295 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
300 foreach my $dup_user ( @dup_user ) {
301 my $dup_svcpart = $dup_user->cust_svc->svcpart;
302 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
303 $dbh->rollback if $oldAutoCommit;
304 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
305 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
309 foreach my $dup_userdomain ( @dup_userdomain ) {
310 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
311 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
312 $dbh->rollback if $oldAutoCommit;
313 return "duplicate username\@domain: conflicts with svcnum ".
314 $dup_userdomain->svcnum. " via exportnum ".
315 $conflict_userdomain_svcpart{$dup_svcpart};
319 foreach my $dup_uid ( @dup_uid ) {
320 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
321 if ( exists($conflict_user_svcpart{$dup_svcpart})
322 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
323 $dbh->rollback if $oldAutoCommit;
324 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
325 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
326 || $conflict_userdomain_svcpart{$dup_svcpart};
332 #see? i told you it was more complicated
335 $error = $self->SUPER::insert(
336 'jobnums' => \@jobnums,
337 'child_objects' => $self->child_objects,
341 $dbh->rollback if $oldAutoCommit;
345 if ( $self->usergroup ) {
346 foreach my $groupname ( @{$self->usergroup} ) {
347 my $radius_usergroup = new FS::radius_usergroup ( {
348 svcnum => $self->svcnum,
349 groupname => $groupname,
351 my $error = $radius_usergroup->insert;
353 $dbh->rollback if $oldAutoCommit;
359 #false laziness with sub replace (and cust_main)
360 my $queue = new FS::queue {
361 'svcnum' => $self->svcnum,
362 'job' => 'FS::svc_acct::append_fuzzyfiles'
364 $error = $queue->insert($self->username);
366 $dbh->rollback if $oldAutoCommit;
367 return "queueing job (transaction rolled back): $error";
370 my $cust_pkg = $self->cust_svc->cust_pkg;
373 my $cust_main = $cust_pkg->cust_main;
375 if ( $conf->exists('emailinvoiceauto') ) {
376 my @invoicing_list = $cust_main->invoicing_list;
377 push @invoicing_list, $self->email;
378 $cust_main->invoicing_list(\@invoicing_list);
383 if ( $welcome_template && $cust_pkg ) {
384 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
386 my $wqueue = new FS::queue {
387 'svcnum' => $self->svcnum,
388 'job' => 'FS::svc_acct::send_email'
390 my $error = $wqueue->insert(
392 'from' => $welcome_from,
393 'subject' => $welcome_subject,
394 'mimetype' => $welcome_mimetype,
395 'body' => $welcome_template->fill_in( HASH => {
396 'custnum' => $self->custnum,
397 'username' => $self->username,
398 'password' => $self->_password,
399 'first' => $cust_main->first,
400 'last' => $cust_main->getfield('last'),
401 'pkg' => $cust_pkg->part_pkg->pkg,
405 $dbh->rollback if $oldAutoCommit;
406 return "error queuing welcome email: $error";
409 if ( $options{'depend_jobnum'} ) {
410 warn "$me depend_jobnum found; adding to welcome email dependancies"
412 if ( ref($options{'depend_jobnum'}) ) {
413 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
414 "to welcome email dependancies"
416 push @jobnums, @{ $options{'depend_jobnum'} };
418 warn "$me adding job $options{'depend_jobnum'} ".
419 "to welcome email dependancies"
421 push @jobnums, $options{'depend_jobnum'};
425 foreach my $jobnum ( @jobnums ) {
426 my $error = $wqueue->depend_insert($jobnum);
428 $dbh->rollback if $oldAutoCommit;
429 return "error queuing welcome email job dependancy: $error";
439 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
445 Deletes this account from the database. If there is an error, returns the
446 error, otherwise returns false.
448 The corresponding FS::cust_svc record will be deleted as well.
450 (TODOC: new exports!)
457 return "can't delete system account" if $self->_check_system;
459 return "Can't delete an account which is a (svc_forward) source!"
460 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
462 return "Can't delete an account which is a (svc_forward) destination!"
463 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
465 return "Can't delete an account with (svc_www) web service!"
466 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
468 # what about records in session ? (they should refer to history table)
470 local $SIG{HUP} = 'IGNORE';
471 local $SIG{INT} = 'IGNORE';
472 local $SIG{QUIT} = 'IGNORE';
473 local $SIG{TERM} = 'IGNORE';
474 local $SIG{TSTP} = 'IGNORE';
475 local $SIG{PIPE} = 'IGNORE';
477 my $oldAutoCommit = $FS::UID::AutoCommit;
478 local $FS::UID::AutoCommit = 0;
481 foreach my $cust_main_invoice (
482 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
484 unless ( defined($cust_main_invoice) ) {
485 warn "WARNING: something's wrong with qsearch";
488 my %hash = $cust_main_invoice->hash;
489 $hash{'dest'} = $self->email;
490 my $new = new FS::cust_main_invoice \%hash;
491 my $error = $new->replace($cust_main_invoice);
493 $dbh->rollback if $oldAutoCommit;
498 foreach my $svc_domain (
499 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
501 my %hash = new FS::svc_domain->hash;
502 $hash{'catchall'} = '';
503 my $new = new FS::svc_domain \%hash;
504 my $error = $new->replace($svc_domain);
506 $dbh->rollback if $oldAutoCommit;
511 foreach my $radius_usergroup (
512 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
514 my $error = $radius_usergroup->delete;
516 $dbh->rollback if $oldAutoCommit;
521 my $error = $self->SUPER::delete;
523 $dbh->rollback if $oldAutoCommit;
527 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
531 =item replace OLD_RECORD
533 Replaces OLD_RECORD with this one in the database. If there is an error,
534 returns the error, otherwise returns false.
536 The additional field I<usergroup> can optionally be defined; if so it should
537 contain an arrayref of group names. See L<FS::radius_usergroup>.
543 my ( $new, $old ) = ( shift, shift );
545 warn "$me replacing $old with $new\n" if $DEBUG;
547 return "can't modify system account" if $old->_check_system;
549 return "Username in use"
550 if $old->username ne $new->username &&
551 qsearchs( 'svc_acct', { 'username' => $new->username,
552 'domsvc' => $new->domsvc,
555 #no warnings 'numeric'; #alas, a 5.006-ism
557 return "Can't change uid!" if $old->uid != $new->uid;
560 #change homdir when we change username
561 $new->setfield('dir', '') if $old->username ne $new->username;
563 local $SIG{HUP} = 'IGNORE';
564 local $SIG{INT} = 'IGNORE';
565 local $SIG{QUIT} = 'IGNORE';
566 local $SIG{TERM} = 'IGNORE';
567 local $SIG{TSTP} = 'IGNORE';
568 local $SIG{PIPE} = 'IGNORE';
570 my $oldAutoCommit = $FS::UID::AutoCommit;
571 local $FS::UID::AutoCommit = 0;
574 # redundant, but so $new->usergroup gets set
575 $error = $new->check;
576 return $error if $error;
578 $old->usergroup( [ $old->radius_groups ] );
579 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
580 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
581 if ( $new->usergroup ) {
582 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
583 my @newgroups = @{$new->usergroup};
584 foreach my $oldgroup ( @{$old->usergroup} ) {
585 if ( grep { $oldgroup eq $_ } @newgroups ) {
586 @newgroups = grep { $oldgroup ne $_ } @newgroups;
589 my $radius_usergroup = qsearchs('radius_usergroup', {
590 svcnum => $old->svcnum,
591 groupname => $oldgroup,
593 my $error = $radius_usergroup->delete;
595 $dbh->rollback if $oldAutoCommit;
596 return "error deleting radius_usergroup $oldgroup: $error";
600 foreach my $newgroup ( @newgroups ) {
601 my $radius_usergroup = new FS::radius_usergroup ( {
602 svcnum => $new->svcnum,
603 groupname => $newgroup,
605 my $error = $radius_usergroup->insert;
607 $dbh->rollback if $oldAutoCommit;
608 return "error adding radius_usergroup $newgroup: $error";
614 $error = $new->SUPER::replace($old);
616 $dbh->rollback if $oldAutoCommit;
617 return $error if $error;
620 if ( $new->username ne $old->username ) {
621 #false laziness with sub insert (and cust_main)
622 my $queue = new FS::queue {
623 'svcnum' => $new->svcnum,
624 'job' => 'FS::svc_acct::append_fuzzyfiles'
626 $error = $queue->insert($new->username);
628 $dbh->rollback if $oldAutoCommit;
629 return "queueing job (transaction rolled back): $error";
633 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
639 Suspends this account by calling export-specific suspend hooks. If there is
640 an error, returns the error, otherwise returns false.
642 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
648 return "can't suspend system account" if $self->_check_system;
649 $self->SUPER::suspend;
654 Unsuspends this account by by calling export-specific suspend hooks. If there
655 is an error, returns the error, otherwise returns false.
657 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
663 my %hash = $self->hash;
664 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
665 $hash{_password} = $1;
666 my $new = new FS::svc_acct ( \%hash );
667 my $error = $new->replace($self);
668 return $error if $error;
671 $self->SUPER::unsuspend;
676 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
678 If the B<auto_unset_catchall> configuration option is set, this method will
679 automatically remove any references to the canceled service in the catchall
680 field of svc_domain. This allows packages that contain both a svc_domain and
681 its catchall svc_acct to be canceled in one step.
686 # Only one thing to do at this level
688 foreach my $svc_domain (
689 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
690 if($conf->exists('auto_unset_catchall')) {
691 my %hash = $svc_domain->hash;
692 $hash{catchall} = '';
693 my $new = new FS::svc_domain ( \%hash );
694 my $error = $new->replace($svc_domain);
695 return $error if $error;
697 return "cannot unprovision svc_acct #".$self->svcnum.
698 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
702 $self->SUPER::cancel;
708 Checks all fields to make sure this is a valid service. If there is an error,
709 returns the error, otherwise returns false. Called by the insert and replace
712 Sets any fixed values; see L<FS::part_svc>.
719 my($recref) = $self->hashref;
721 my $x = $self->setfixed;
722 return $x unless ref($x);
725 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
727 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
730 my $error = $self->ut_numbern('svcnum')
731 #|| $self->ut_number('domsvc')
732 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
733 || $self->ut_textn('sec_phrase')
735 return $error if $error;
737 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
738 if ( $username_uppercase ) {
739 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
740 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
741 $recref->{username} = $1;
743 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
744 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
745 $recref->{username} = $1;
748 if ( $username_letterfirst ) {
749 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
750 } elsif ( $username_letter ) {
751 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
753 if ( $username_noperiod ) {
754 $recref->{username} =~ /\./ and return gettext('illegal_username');
756 if ( $username_nounderscore ) {
757 $recref->{username} =~ /_/ and return gettext('illegal_username');
759 if ( $username_nodash ) {
760 $recref->{username} =~ /\-/ and return gettext('illegal_username');
762 unless ( $username_ampersand ) {
763 $recref->{username} =~ /\&/ and return gettext('illegal_username');
766 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
767 $recref->{popnum} = $1;
768 return "Unknown popnum" unless
769 ! $recref->{popnum} ||
770 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
772 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
774 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
775 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
777 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
778 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
779 #not all systems use gid=uid
780 #you can set a fixed gid in part_svc
782 return "Only root can have uid 0"
783 if $recref->{uid} == 0
784 && $recref->{username} ne 'root'
785 && $recref->{username} ne 'toor';
788 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
789 or return "Illegal directory: ". $recref->{dir};
791 return "Illegal directory"
792 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
793 return "Illegal directory"
794 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
795 unless ( $recref->{dir} ) {
796 $recref->{dir} = $dir_prefix . '/';
797 if ( $dirhash > 0 ) {
798 for my $h ( 1 .. $dirhash ) {
799 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
801 } elsif ( $dirhash < 0 ) {
802 for my $h ( reverse $dirhash .. -1 ) {
803 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
806 $recref->{dir} .= $recref->{username};
810 unless ( $recref->{username} eq 'sync' ) {
811 if ( grep $_ eq $recref->{shell}, @shells ) {
812 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
814 return "Illegal shell \`". $self->shell. "\'; ".
815 $conf->dir. "/shells contains: @shells";
818 $recref->{shell} = '/bin/sync';
822 $recref->{gid} ne '' ?
823 return "Can't have gid without uid" : ( $recref->{gid}='' );
824 $recref->{dir} ne '' ?
825 return "Can't have directory without uid" : ( $recref->{dir}='' );
826 $recref->{shell} ne '' ?
827 return "Can't have shell without uid" : ( $recref->{shell}='' );
830 # $error = $self->ut_textn('finger');
831 # return $error if $error;
832 $self->getfield('finger') =~
833 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
834 or return "Illegal finger: ". $self->getfield('finger');
835 $self->setfield('finger', $1);
837 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
838 $recref->{quota} = $1;
840 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
841 if ( $recref->{slipip} eq '' ) {
842 $recref->{slipip} = '';
843 } elsif ( $recref->{slipip} eq '0e0' ) {
844 $recref->{slipip} = '0e0';
846 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
847 or return "Illegal slipip: ". $self->slipip;
848 $recref->{slipip} = $1;
853 #arbitrary RADIUS stuff; allow ut_textn for now
854 foreach ( grep /^radius_/, fields('svc_acct') ) {
858 #generate a password if it is blank
859 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
860 unless ( $recref->{_password} );
862 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
863 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
864 $recref->{_password} = $1.$3;
865 #uncomment this to encrypt password immediately upon entry, or run
866 #bin/crypt_pw in cron to give new users a window during which their
867 #password is available to techs, for faxing, etc. (also be aware of
869 #$recref->{password} = $1.
870 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
872 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
873 $recref->{_password} = $1.$3;
874 } elsif ( $recref->{_password} eq '*' ) {
875 $recref->{_password} = '*';
876 } elsif ( $recref->{_password} eq '!' ) {
877 $recref->{_password} = '!';
878 } elsif ( $recref->{_password} eq '!!' ) {
879 $recref->{_password} = '!!';
881 #return "Illegal password";
882 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
883 FS::Msgcat::_gettext('illegal_password_characters').
884 ": ". $recref->{_password};
896 scalar( grep { $self->username eq $_ || $self->email eq $_ }
897 $conf->config('system_usernames')
903 Depriciated, use radius_reply instead.
908 carp "FS::svc_acct::radius depriciated, use radius_reply";
914 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
915 reply attributes of this record.
917 Note that this is now the preferred method for reading RADIUS attributes -
918 accessing the columns directly is discouraged, as the column names are
919 expected to change in the future.
928 my($column, $attrib) = ($1, $2);
929 #$attrib =~ s/_/\-/g;
930 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
931 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
932 if ( $self->slipip && $self->slipip ne '0e0' ) {
933 $reply{$radius_ip} = $self->slipip;
940 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
941 check attributes of this record.
943 Note that this is now the preferred method for reading RADIUS attributes -
944 accessing the columns directly is discouraged, as the column names are
945 expected to change in the future.
951 my $password = $self->_password;
952 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
953 ( $pw_attrib => $password,
956 my($column, $attrib) = ($1, $2);
957 #$attrib =~ s/_/\-/g;
958 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
959 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
965 Returns the domain associated with this account.
971 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
972 my $svc_domain = $self->svc_domain
973 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
979 Returns the FS::svc_domain record for this account's domain (see
988 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
993 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
999 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1004 Returns an email address associated with the account.
1010 $self->username. '@'. $self->domain;
1015 Returns an array of FS::acct_snarf records associated with the account.
1016 If the acct_snarf table does not exist or there are no associated records,
1017 an empty list is returned
1023 return () unless dbdef->table('acct_snarf');
1024 eval "use FS::acct_snarf;";
1026 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1029 =item seconds_since TIMESTAMP
1031 Returns the number of seconds this account has been online since TIMESTAMP,
1032 according to the session monitor (see L<FS::Session>).
1034 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1035 L<Time::Local> and L<Date::Parse> for conversion functions.
1039 #note: POD here, implementation in FS::cust_svc
1042 $self->cust_svc->seconds_since(@_);
1045 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1047 Returns the numbers of seconds this account has been online between
1048 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1049 external SQL radacct table, specified via sqlradius export. Sessions which
1050 started in the specified range but are still open are counted from session
1051 start to the end of the range (unless they are over 1 day old, in which case
1052 they are presumed missing their stop record and not counted). Also, sessions
1053 which end in the range but started earlier are counted from the start of the
1054 range to session end. Finally, sessions which start before the range but end
1055 after are counted for the entire range.
1057 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1058 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1063 #note: POD here, implementation in FS::cust_svc
1064 sub seconds_since_sqlradacct {
1066 $self->cust_svc->seconds_since_sqlradacct(@_);
1069 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1071 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1072 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1073 TIMESTAMP_END (exclusive).
1075 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1076 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1081 #note: POD here, implementation in FS::cust_svc
1082 sub attribute_since_sqlradacct {
1084 $self->cust_svc->attribute_since_sqlradacct(@_);
1087 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1089 Returns an array of hash references of this customers login history for the
1090 given time range. (document this better)
1094 sub get_session_history_sqlradacct {
1096 $self->cust_svc->get_session_history_sqlradacct(@_);
1101 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1107 if ( $self->usergroup ) {
1108 #when provisioning records, export callback runs in svc_Common.pm before
1109 #radius_usergroup records can be inserted...
1110 @{$self->usergroup};
1112 map { $_->groupname }
1113 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1117 =item clone_suspended
1119 Constructor used by FS::part_export::_export_suspend fallback. Document
1124 sub clone_suspended {
1126 my %hash = $self->hash;
1127 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1128 new FS::svc_acct \%hash;
1131 =item clone_kludge_unsuspend
1133 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1138 sub clone_kludge_unsuspend {
1140 my %hash = $self->hash;
1141 $hash{_password} = '';
1142 new FS::svc_acct \%hash;
1145 =item check_password
1147 Checks the supplied password against the (possibly encrypted) password in the
1148 database. Returns true for a sucessful authentication, false for no match.
1150 Currently supported encryptions are: classic DES crypt() and MD5
1154 sub check_password {
1155 my($self, $check_password) = @_;
1157 #remove old-style SUSPENDED kludge, they should be allowed to login to
1158 #self-service and pay up
1159 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1161 #eventually should check a "password-encoding" field
1162 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1164 } elsif ( length($password) < 13 ) { #plaintext
1165 $check_password eq $password;
1166 } elsif ( length($password) == 13 ) { #traditional DES crypt
1167 crypt($check_password, $password) eq $password;
1168 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1169 unix_md5_crypt($check_password, $password) eq $password;
1170 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1171 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1172 $self->svcnum. "\n";
1175 warn "Can't check password: Unrecognized encryption for svcnum ".
1176 $self->svcnum. "\n";
1190 This is the FS::svc_acct job-queue-able version. It still uses
1191 FS::Misc::send_email under-the-hood.
1198 eval "use FS::Misc qw(send_email)";
1201 $opt{mimetype} ||= 'text/plain';
1202 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1204 my $error = send_email(
1205 'from' => $opt{from},
1207 'subject' => $opt{subject},
1208 'content-type' => $opt{mimetype},
1209 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1211 die $error if $error;
1214 =item check_and_rebuild_fuzzyfiles
1218 sub check_and_rebuild_fuzzyfiles {
1219 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1220 -e "$dir/svc_acct.username"
1221 or &rebuild_fuzzyfiles;
1224 =item rebuild_fuzzyfiles
1228 sub rebuild_fuzzyfiles {
1230 use Fcntl qw(:flock);
1232 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1236 open(USERNAMELOCK,">>$dir/svc_acct.username")
1237 or die "can't open $dir/svc_acct.username: $!";
1238 flock(USERNAMELOCK,LOCK_EX)
1239 or die "can't lock $dir/svc_acct.username: $!";
1241 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1243 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1244 or die "can't open $dir/svc_acct.username.tmp: $!";
1245 print USERNAMECACHE join("\n", @all_username), "\n";
1246 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1248 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1258 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1259 open(USERNAMECACHE,"<$dir/svc_acct.username")
1260 or die "can't open $dir/svc_acct.username: $!";
1261 my @array = map { chomp; $_; } <USERNAMECACHE>;
1262 close USERNAMECACHE;
1266 =item append_fuzzyfiles USERNAME
1270 sub append_fuzzyfiles {
1271 my $username = shift;
1273 &check_and_rebuild_fuzzyfiles;
1275 use Fcntl qw(:flock);
1277 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1279 open(USERNAME,">>$dir/svc_acct.username")
1280 or die "can't open $dir/svc_acct.username: $!";
1281 flock(USERNAME,LOCK_EX)
1282 or die "can't lock $dir/svc_acct.username: $!";
1284 print USERNAME "$username\n";
1286 flock(USERNAME,LOCK_UN)
1287 or die "can't unlock $dir/svc_acct.username: $!";
1295 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1299 sub radius_usergroup_selector {
1300 my $sel_groups = shift;
1301 my %sel_groups = map { $_=>1 } @$sel_groups;
1303 my $selectname = shift || 'radius_usergroup';
1306 my $sth = $dbh->prepare(
1307 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1308 ) or die $dbh->errstr;
1309 $sth->execute() or die $sth->errstr;
1310 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1314 function ${selectname}_doadd(object) {
1315 var myvalue = object.${selectname}_add.value;
1316 var optionName = new Option(myvalue,myvalue,false,true);
1317 var length = object.$selectname.length;
1318 object.$selectname.options[length] = optionName;
1319 object.${selectname}_add.value = "";
1322 <SELECT MULTIPLE NAME="$selectname">
1325 foreach my $group ( @all_groups ) {
1327 if ( $sel_groups{$group} ) {
1328 $html .= ' SELECTED';
1329 $sel_groups{$group} = 0;
1331 $html .= ">$group</OPTION>\n";
1333 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1334 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1336 $html .= '</SELECT>';
1338 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1339 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1348 The $recref stuff in sub check should be cleaned up.
1350 The suspend, unsuspend and cancel methods update the database, but not the
1351 current object. This is probably a bug as it's unexpected and
1354 radius_usergroup_selector? putting web ui components in here? they should
1355 probably live somewhere else...
1357 insertion of RADIUS group stuff in insert could be done with child_objects now
1358 (would probably clean up export of them too)
1362 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1363 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1364 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1365 L<freeside-queued>), L<FS::svc_acct_pop>,
1366 schema.html from the base documentation.