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/username@domain/uid 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 } $part_export->export_svc;
277 #this will catch to exports w/same exporthost+type ???
278 #my @other_part_export = qsearch('part_export', {
279 # 'machine' => $part_export->machine,
280 # 'exporttype' => $part_export->exporttype,
282 #foreach my $other_part_export ( @other_part_export ) {
283 # push @svcparts, map { $_->svcpart }
284 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
287 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
288 #silly kludge to avoid uninitialized value errors
289 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
290 ? $exports->{$part_export->exporttype}{'nodomain'}
292 if ( $nodomain =~ /^Y/i ) {
293 $conflict_user_svcpart{$_} = $part_export->exportnum
296 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
301 foreach my $dup_user ( @dup_user ) {
302 my $dup_svcpart = $dup_user->cust_svc->svcpart;
303 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
304 $dbh->rollback if $oldAutoCommit;
305 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
306 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
310 foreach my $dup_userdomain ( @dup_userdomain ) {
311 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
312 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
313 $dbh->rollback if $oldAutoCommit;
314 return "duplicate username\@domain: conflicts with svcnum ".
315 $dup_userdomain->svcnum. " via exportnum ".
316 $conflict_userdomain_svcpart{$dup_svcpart};
320 foreach my $dup_uid ( @dup_uid ) {
321 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
322 if ( exists($conflict_user_svcpart{$dup_svcpart})
323 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
324 $dbh->rollback if $oldAutoCommit;
325 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
326 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
327 || $conflict_userdomain_svcpart{$dup_svcpart};
333 #see? i told you it was more complicated
336 $error = $self->SUPER::insert(
337 'jobnums' => \@jobnums,
338 'child_objects' => $self->child_objects,
342 $dbh->rollback if $oldAutoCommit;
346 if ( $self->usergroup ) {
347 foreach my $groupname ( @{$self->usergroup} ) {
348 my $radius_usergroup = new FS::radius_usergroup ( {
349 svcnum => $self->svcnum,
350 groupname => $groupname,
352 my $error = $radius_usergroup->insert;
354 $dbh->rollback if $oldAutoCommit;
360 #false laziness with sub replace (and cust_main)
361 my $queue = new FS::queue {
362 'svcnum' => $self->svcnum,
363 'job' => 'FS::svc_acct::append_fuzzyfiles'
365 $error = $queue->insert($self->username);
367 $dbh->rollback if $oldAutoCommit;
368 return "queueing job (transaction rolled back): $error";
371 my $cust_pkg = $self->cust_svc->cust_pkg;
374 my $cust_main = $cust_pkg->cust_main;
376 if ( $conf->exists('emailinvoiceauto') ) {
377 my @invoicing_list = $cust_main->invoicing_list;
378 push @invoicing_list, $self->email;
379 $cust_main->invoicing_list(\@invoicing_list);
384 if ( $welcome_template && $cust_pkg ) {
385 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
387 my $wqueue = new FS::queue {
388 'svcnum' => $self->svcnum,
389 'job' => 'FS::svc_acct::send_email'
391 my $error = $wqueue->insert(
393 'from' => $welcome_from,
394 'subject' => $welcome_subject,
395 'mimetype' => $welcome_mimetype,
396 'body' => $welcome_template->fill_in( HASH => {
397 'custnum' => $self->custnum,
398 'username' => $self->username,
399 'password' => $self->_password,
400 'first' => $cust_main->first,
401 'last' => $cust_main->getfield('last'),
402 'pkg' => $cust_pkg->part_pkg->pkg,
406 $dbh->rollback if $oldAutoCommit;
407 return "error queuing welcome email: $error";
410 if ( $options{'depend_jobnum'} ) {
411 warn "$me depend_jobnum found; adding to welcome email dependancies"
413 if ( ref($options{'depend_jobnum'}) ) {
414 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
415 "to welcome email dependancies"
417 push @jobnums, @{ $options{'depend_jobnum'} };
419 warn "$me adding job $options{'depend_jobnum'} ".
420 "to welcome email dependancies"
422 push @jobnums, $options{'depend_jobnum'};
426 foreach my $jobnum ( @jobnums ) {
427 my $error = $wqueue->depend_insert($jobnum);
429 $dbh->rollback if $oldAutoCommit;
430 return "error queuing welcome email job dependancy: $error";
440 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
446 Deletes this account from the database. If there is an error, returns the
447 error, otherwise returns false.
449 The corresponding FS::cust_svc record will be deleted as well.
451 (TODOC: new exports!)
458 return "can't delete system account" if $self->_check_system;
460 return "Can't delete an account which is a (svc_forward) source!"
461 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
463 return "Can't delete an account which is a (svc_forward) destination!"
464 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
466 return "Can't delete an account with (svc_www) web service!"
467 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
469 # what about records in session ? (they should refer to history table)
471 local $SIG{HUP} = 'IGNORE';
472 local $SIG{INT} = 'IGNORE';
473 local $SIG{QUIT} = 'IGNORE';
474 local $SIG{TERM} = 'IGNORE';
475 local $SIG{TSTP} = 'IGNORE';
476 local $SIG{PIPE} = 'IGNORE';
478 my $oldAutoCommit = $FS::UID::AutoCommit;
479 local $FS::UID::AutoCommit = 0;
482 foreach my $cust_main_invoice (
483 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
485 unless ( defined($cust_main_invoice) ) {
486 warn "WARNING: something's wrong with qsearch";
489 my %hash = $cust_main_invoice->hash;
490 $hash{'dest'} = $self->email;
491 my $new = new FS::cust_main_invoice \%hash;
492 my $error = $new->replace($cust_main_invoice);
494 $dbh->rollback if $oldAutoCommit;
499 foreach my $svc_domain (
500 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
502 my %hash = new FS::svc_domain->hash;
503 $hash{'catchall'} = '';
504 my $new = new FS::svc_domain \%hash;
505 my $error = $new->replace($svc_domain);
507 $dbh->rollback if $oldAutoCommit;
512 foreach my $radius_usergroup (
513 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
515 my $error = $radius_usergroup->delete;
517 $dbh->rollback if $oldAutoCommit;
522 my $error = $self->SUPER::delete;
524 $dbh->rollback if $oldAutoCommit;
528 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
532 =item replace OLD_RECORD
534 Replaces OLD_RECORD with this one in the database. If there is an error,
535 returns the error, otherwise returns false.
537 The additional field I<usergroup> can optionally be defined; if so it should
538 contain an arrayref of group names. See L<FS::radius_usergroup>.
544 my ( $new, $old ) = ( shift, shift );
546 warn "$me replacing $old with $new\n" if $DEBUG;
548 return "can't modify system account" if $old->_check_system;
550 return "Username in use"
551 if $old->username ne $new->username &&
552 qsearchs( 'svc_acct', { 'username' => $new->username,
553 'domsvc' => $new->domsvc,
556 #no warnings 'numeric'; #alas, a 5.006-ism
558 return "Can't change uid!" if $old->uid != $new->uid;
561 #change homdir when we change username
562 $new->setfield('dir', '') if $old->username ne $new->username;
564 local $SIG{HUP} = 'IGNORE';
565 local $SIG{INT} = 'IGNORE';
566 local $SIG{QUIT} = 'IGNORE';
567 local $SIG{TERM} = 'IGNORE';
568 local $SIG{TSTP} = 'IGNORE';
569 local $SIG{PIPE} = 'IGNORE';
571 my $oldAutoCommit = $FS::UID::AutoCommit;
572 local $FS::UID::AutoCommit = 0;
575 # redundant, but so $new->usergroup gets set
576 $error = $new->check;
577 return $error if $error;
579 $old->usergroup( [ $old->radius_groups ] );
580 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
581 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
582 if ( $new->usergroup ) {
583 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
584 my @newgroups = @{$new->usergroup};
585 foreach my $oldgroup ( @{$old->usergroup} ) {
586 if ( grep { $oldgroup eq $_ } @newgroups ) {
587 @newgroups = grep { $oldgroup ne $_ } @newgroups;
590 my $radius_usergroup = qsearchs('radius_usergroup', {
591 svcnum => $old->svcnum,
592 groupname => $oldgroup,
594 my $error = $radius_usergroup->delete;
596 $dbh->rollback if $oldAutoCommit;
597 return "error deleting radius_usergroup $oldgroup: $error";
601 foreach my $newgroup ( @newgroups ) {
602 my $radius_usergroup = new FS::radius_usergroup ( {
603 svcnum => $new->svcnum,
604 groupname => $newgroup,
606 my $error = $radius_usergroup->insert;
608 $dbh->rollback if $oldAutoCommit;
609 return "error adding radius_usergroup $newgroup: $error";
615 $error = $new->SUPER::replace($old);
617 $dbh->rollback if $oldAutoCommit;
618 return $error if $error;
621 if ( $new->username ne $old->username ) {
622 #false laziness with sub insert (and cust_main)
623 my $queue = new FS::queue {
624 'svcnum' => $new->svcnum,
625 'job' => 'FS::svc_acct::append_fuzzyfiles'
627 $error = $queue->insert($new->username);
629 $dbh->rollback if $oldAutoCommit;
630 return "queueing job (transaction rolled back): $error";
634 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
640 Suspends this account by calling export-specific suspend hooks. If there is
641 an error, returns the error, otherwise returns false.
643 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
649 return "can't suspend system account" if $self->_check_system;
650 $self->SUPER::suspend;
655 Unsuspends this account by by calling export-specific suspend hooks. If there
656 is an error, returns the error, otherwise returns false.
658 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
664 my %hash = $self->hash;
665 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
666 $hash{_password} = $1;
667 my $new = new FS::svc_acct ( \%hash );
668 my $error = $new->replace($self);
669 return $error if $error;
672 $self->SUPER::unsuspend;
677 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
679 If the B<auto_unset_catchall> configuration option is set, this method will
680 automatically remove any references to the canceled service in the catchall
681 field of svc_domain. This allows packages that contain both a svc_domain and
682 its catchall svc_acct to be canceled in one step.
687 # Only one thing to do at this level
689 foreach my $svc_domain (
690 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
691 if($conf->exists('auto_unset_catchall')) {
692 my %hash = $svc_domain->hash;
693 $hash{catchall} = '';
694 my $new = new FS::svc_domain ( \%hash );
695 my $error = $new->replace($svc_domain);
696 return $error if $error;
698 return "cannot unprovision svc_acct #".$self->svcnum.
699 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
703 $self->SUPER::cancel;
709 Checks all fields to make sure this is a valid service. If there is an error,
710 returns the error, otherwise returns false. Called by the insert and replace
713 Sets any fixed values; see L<FS::part_svc>.
720 my($recref) = $self->hashref;
722 my $x = $self->setfixed;
723 return $x unless ref($x);
726 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
728 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
731 my $error = $self->ut_numbern('svcnum')
732 #|| $self->ut_number('domsvc')
733 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
734 || $self->ut_textn('sec_phrase')
736 return $error if $error;
738 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
739 if ( $username_uppercase ) {
740 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
741 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
742 $recref->{username} = $1;
744 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
745 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
746 $recref->{username} = $1;
749 if ( $username_letterfirst ) {
750 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
751 } elsif ( $username_letter ) {
752 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
754 if ( $username_noperiod ) {
755 $recref->{username} =~ /\./ and return gettext('illegal_username');
757 if ( $username_nounderscore ) {
758 $recref->{username} =~ /_/ and return gettext('illegal_username');
760 if ( $username_nodash ) {
761 $recref->{username} =~ /\-/ and return gettext('illegal_username');
763 unless ( $username_ampersand ) {
764 $recref->{username} =~ /\&/ and return gettext('illegal_username');
767 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
768 $recref->{popnum} = $1;
769 return "Unknown popnum" unless
770 ! $recref->{popnum} ||
771 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
773 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
775 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
776 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
778 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
779 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
780 #not all systems use gid=uid
781 #you can set a fixed gid in part_svc
783 return "Only root can have uid 0"
784 if $recref->{uid} == 0
785 && $recref->{username} ne 'root'
786 && $recref->{username} ne 'toor';
789 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
790 or return "Illegal directory: ". $recref->{dir};
792 return "Illegal directory"
793 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
794 return "Illegal directory"
795 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
796 unless ( $recref->{dir} ) {
797 $recref->{dir} = $dir_prefix . '/';
798 if ( $dirhash > 0 ) {
799 for my $h ( 1 .. $dirhash ) {
800 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
802 } elsif ( $dirhash < 0 ) {
803 for my $h ( reverse $dirhash .. -1 ) {
804 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
807 $recref->{dir} .= $recref->{username};
811 unless ( $recref->{username} eq 'sync' ) {
812 if ( grep $_ eq $recref->{shell}, @shells ) {
813 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
815 return "Illegal shell \`". $self->shell. "\'; ".
816 $conf->dir. "/shells contains: @shells";
819 $recref->{shell} = '/bin/sync';
823 $recref->{gid} ne '' ?
824 return "Can't have gid without uid" : ( $recref->{gid}='' );
825 $recref->{dir} ne '' ?
826 return "Can't have directory without uid" : ( $recref->{dir}='' );
827 $recref->{shell} ne '' ?
828 return "Can't have shell without uid" : ( $recref->{shell}='' );
831 # $error = $self->ut_textn('finger');
832 # return $error if $error;
833 if ( $self->getfield('finger') eq '' ) {
834 my $cust_pkg = $self->svcnum
835 ? $self->cust_svc->cust_pkg
836 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
838 my $cust_main = $cust_pkg->cust_main;
839 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
842 $self->getfield('finger') =~
843 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
844 or return "Illegal finger: ". $self->getfield('finger');
845 $self->setfield('finger', $1);
847 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
848 $recref->{quota} = $1;
850 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
851 if ( $recref->{slipip} eq '' ) {
852 $recref->{slipip} = '';
853 } elsif ( $recref->{slipip} eq '0e0' ) {
854 $recref->{slipip} = '0e0';
856 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
857 or return "Illegal slipip: ". $self->slipip;
858 $recref->{slipip} = $1;
863 #arbitrary RADIUS stuff; allow ut_textn for now
864 foreach ( grep /^radius_/, fields('svc_acct') ) {
868 #generate a password if it is blank
869 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
870 unless ( $recref->{_password} );
872 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
873 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
874 $recref->{_password} = $1.$3;
875 #uncomment this to encrypt password immediately upon entry, or run
876 #bin/crypt_pw in cron to give new users a window during which their
877 #password is available to techs, for faxing, etc. (also be aware of
879 #$recref->{password} = $1.
880 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
882 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
883 $recref->{_password} = $1.$3;
884 } elsif ( $recref->{_password} eq '*' ) {
885 $recref->{_password} = '*';
886 } elsif ( $recref->{_password} eq '!' ) {
887 $recref->{_password} = '!';
888 } elsif ( $recref->{_password} eq '!!' ) {
889 $recref->{_password} = '!!';
891 #return "Illegal password";
892 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
893 FS::Msgcat::_gettext('illegal_password_characters').
894 ": ". $recref->{_password};
906 scalar( grep { $self->username eq $_ || $self->email eq $_ }
907 $conf->config('system_usernames')
913 Depriciated, use radius_reply instead.
918 carp "FS::svc_acct::radius depriciated, use radius_reply";
924 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
925 reply attributes of this record.
927 Note that this is now the preferred method for reading RADIUS attributes -
928 accessing the columns directly is discouraged, as the column names are
929 expected to change in the future.
938 my($column, $attrib) = ($1, $2);
939 #$attrib =~ s/_/\-/g;
940 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
941 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
942 if ( $self->slipip && $self->slipip ne '0e0' ) {
943 $reply{$radius_ip} = $self->slipip;
950 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
951 check attributes of this record.
953 Note that this is now the preferred method for reading RADIUS attributes -
954 accessing the columns directly is discouraged, as the column names are
955 expected to change in the future.
961 my $password = $self->_password;
962 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
963 ( $pw_attrib => $password,
966 my($column, $attrib) = ($1, $2);
967 #$attrib =~ s/_/\-/g;
968 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
969 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
975 Returns the domain associated with this account.
981 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
982 my $svc_domain = $self->svc_domain
983 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
989 Returns the FS::svc_domain record for this account's domain (see
998 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1003 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1009 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1014 Returns an email address associated with the account.
1020 $self->username. '@'. $self->domain;
1025 Returns an array of FS::acct_snarf records associated with the account.
1026 If the acct_snarf table does not exist or there are no associated records,
1027 an empty list is returned
1033 return () unless dbdef->table('acct_snarf');
1034 eval "use FS::acct_snarf;";
1036 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1039 =item seconds_since TIMESTAMP
1041 Returns the number of seconds this account has been online since TIMESTAMP,
1042 according to the session monitor (see L<FS::Session>).
1044 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1045 L<Time::Local> and L<Date::Parse> for conversion functions.
1049 #note: POD here, implementation in FS::cust_svc
1052 $self->cust_svc->seconds_since(@_);
1055 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1057 Returns the numbers of seconds this account has been online between
1058 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1059 external SQL radacct table, specified via sqlradius export. Sessions which
1060 started in the specified range but are still open are counted from session
1061 start to the end of the range (unless they are over 1 day old, in which case
1062 they are presumed missing their stop record and not counted). Also, sessions
1063 which end in the range but started earlier are counted from the start of the
1064 range to session end. Finally, sessions which start before the range but end
1065 after are counted for the entire range.
1067 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1068 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1073 #note: POD here, implementation in FS::cust_svc
1074 sub seconds_since_sqlradacct {
1076 $self->cust_svc->seconds_since_sqlradacct(@_);
1079 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1081 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1082 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1083 TIMESTAMP_END (exclusive).
1085 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1086 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1091 #note: POD here, implementation in FS::cust_svc
1092 sub attribute_since_sqlradacct {
1094 $self->cust_svc->attribute_since_sqlradacct(@_);
1097 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1099 Returns an array of hash references of this customers login history for the
1100 given time range. (document this better)
1104 sub get_session_history_sqlradacct {
1106 $self->cust_svc->get_session_history_sqlradacct(@_);
1111 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1117 if ( $self->usergroup ) {
1118 #when provisioning records, export callback runs in svc_Common.pm before
1119 #radius_usergroup records can be inserted...
1120 @{$self->usergroup};
1122 map { $_->groupname }
1123 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1127 =item clone_suspended
1129 Constructor used by FS::part_export::_export_suspend fallback. Document
1134 sub clone_suspended {
1136 my %hash = $self->hash;
1137 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1138 new FS::svc_acct \%hash;
1141 =item clone_kludge_unsuspend
1143 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1148 sub clone_kludge_unsuspend {
1150 my %hash = $self->hash;
1151 $hash{_password} = '';
1152 new FS::svc_acct \%hash;
1155 =item check_password
1157 Checks the supplied password against the (possibly encrypted) password in the
1158 database. Returns true for a sucessful authentication, false for no match.
1160 Currently supported encryptions are: classic DES crypt() and MD5
1164 sub check_password {
1165 my($self, $check_password) = @_;
1167 #remove old-style SUSPENDED kludge, they should be allowed to login to
1168 #self-service and pay up
1169 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1171 #eventually should check a "password-encoding" field
1172 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1174 } elsif ( length($password) < 13 ) { #plaintext
1175 $check_password eq $password;
1176 } elsif ( length($password) == 13 ) { #traditional DES crypt
1177 crypt($check_password, $password) eq $password;
1178 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1179 unix_md5_crypt($check_password, $password) eq $password;
1180 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1181 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1182 $self->svcnum. "\n";
1185 warn "Can't check password: Unrecognized encryption for svcnum ".
1186 $self->svcnum. "\n";
1192 =item crypt_password
1194 Returns an encrypted password, either by passing through an encrypted password
1195 in the database or by encrypting a plaintext password from the database.
1199 sub crypt_password {
1201 #false laziness w/shellcommands.pm
1202 #eventually should check a "password-encoding" field
1203 if ( length($self->_password) == 13
1204 || $self->_password =~ /^\$(1|2a?)\$/ ) {
1209 $saltset[int(rand(64))].$saltset[int(rand(64))]
1214 =item virtual_maildir
1216 Returns $domain/maildirs/$username/
1220 sub virtual_maildir {
1222 $self->domain. '/maildirs/'. $self->username. '/';
1233 This is the FS::svc_acct job-queue-able version. It still uses
1234 FS::Misc::send_email under-the-hood.
1241 eval "use FS::Misc qw(send_email)";
1244 $opt{mimetype} ||= 'text/plain';
1245 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1247 my $error = send_email(
1248 'from' => $opt{from},
1250 'subject' => $opt{subject},
1251 'content-type' => $opt{mimetype},
1252 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1254 die $error if $error;
1257 =item check_and_rebuild_fuzzyfiles
1261 sub check_and_rebuild_fuzzyfiles {
1262 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1263 -e "$dir/svc_acct.username"
1264 or &rebuild_fuzzyfiles;
1267 =item rebuild_fuzzyfiles
1271 sub rebuild_fuzzyfiles {
1273 use Fcntl qw(:flock);
1275 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1279 open(USERNAMELOCK,">>$dir/svc_acct.username")
1280 or die "can't open $dir/svc_acct.username: $!";
1281 flock(USERNAMELOCK,LOCK_EX)
1282 or die "can't lock $dir/svc_acct.username: $!";
1284 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1286 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1287 or die "can't open $dir/svc_acct.username.tmp: $!";
1288 print USERNAMECACHE join("\n", @all_username), "\n";
1289 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1291 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1301 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1302 open(USERNAMECACHE,"<$dir/svc_acct.username")
1303 or die "can't open $dir/svc_acct.username: $!";
1304 my @array = map { chomp; $_; } <USERNAMECACHE>;
1305 close USERNAMECACHE;
1309 =item append_fuzzyfiles USERNAME
1313 sub append_fuzzyfiles {
1314 my $username = shift;
1316 &check_and_rebuild_fuzzyfiles;
1318 use Fcntl qw(:flock);
1320 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1322 open(USERNAME,">>$dir/svc_acct.username")
1323 or die "can't open $dir/svc_acct.username: $!";
1324 flock(USERNAME,LOCK_EX)
1325 or die "can't lock $dir/svc_acct.username: $!";
1327 print USERNAME "$username\n";
1329 flock(USERNAME,LOCK_UN)
1330 or die "can't unlock $dir/svc_acct.username: $!";
1338 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1342 sub radius_usergroup_selector {
1343 my $sel_groups = shift;
1344 my %sel_groups = map { $_=>1 } @$sel_groups;
1346 my $selectname = shift || 'radius_usergroup';
1349 my $sth = $dbh->prepare(
1350 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1351 ) or die $dbh->errstr;
1352 $sth->execute() or die $sth->errstr;
1353 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1357 function ${selectname}_doadd(object) {
1358 var myvalue = object.${selectname}_add.value;
1359 var optionName = new Option(myvalue,myvalue,false,true);
1360 var length = object.$selectname.length;
1361 object.$selectname.options[length] = optionName;
1362 object.${selectname}_add.value = "";
1365 <SELECT MULTIPLE NAME="$selectname">
1368 foreach my $group ( @all_groups ) {
1370 if ( $sel_groups{$group} ) {
1371 $html .= ' SELECTED';
1372 $sel_groups{$group} = 0;
1374 $html .= ">$group</OPTION>\n";
1376 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1377 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1379 $html .= '</SELECT>';
1381 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1382 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1391 The $recref stuff in sub check should be cleaned up.
1393 The suspend, unsuspend and cancel methods update the database, but not the
1394 current object. This is probably a bug as it's unexpected and
1397 radius_usergroup_selector? putting web ui components in here? they should
1398 probably live somewhere else...
1400 insertion of RADIUS group stuff in insert could be done with child_objects now
1401 (would probably clean up export of them too)
1405 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1406 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1407 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1408 L<freeside-queued>), L<FS::svc_acct_pop>,
1409 schema.html from the base documentation.