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
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
13 $radius_password $radius_ip
19 use FS::UID qw( datasrc );
21 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
28 use FS::cust_main_invoice;
32 use FS::radius_usergroup;
35 use FS::Msgcat qw(gettext);
39 @ISA = qw( FS::svc_Common );
43 $me = '[FS::svc_acct]';
45 #ask FS::UID to run this stuff for us later
46 $FS::UID::callback{'FS::svc_acct'} = sub {
48 $dir_prefix = $conf->config('home');
49 @shells = $conf->config('shells');
50 $usernamemin = $conf->config('usernamemin') || 2;
51 $usernamemax = $conf->config('usernamemax');
52 $passwordmin = $conf->config('passwordmin') || 6;
53 $passwordmax = $conf->config('passwordmax') || 8;
54 $username_letter = $conf->exists('username-letter');
55 $username_letterfirst = $conf->exists('username-letterfirst');
56 $username_noperiod = $conf->exists('username-noperiod');
57 $username_nounderscore = $conf->exists('username-nounderscore');
58 $username_nodash = $conf->exists('username-nodash');
59 $username_uppercase = $conf->exists('username-uppercase');
60 $username_ampersand = $conf->exists('username-ampersand');
61 $mydomain = $conf->config('domain');
62 $dirhash = $conf->config('dirhash') || 0;
63 if ( $conf->exists('welcome_email') ) {
64 $welcome_template = new Text::Template (
66 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
67 ) or warn "can't create welcome email template: $Text::Template::ERROR";
68 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
69 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
70 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
72 $welcome_template = '';
74 $welcome_subject = '';
75 $welcome_mimetype = '';
77 $smtpmachine = $conf->config('smtpmachine');
78 $radius_password = $conf->config('radius-password') || 'Password';
79 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
82 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
83 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
87 my ( $hashref, $cache ) = @_;
88 if ( $hashref->{'svc_acct_svcnum'} ) {
89 $self->{'_domsvc'} = FS::svc_domain->new( {
90 'svcnum' => $hashref->{'domsvc'},
91 'domain' => $hashref->{'svc_acct_domain'},
92 'catchall' => $hashref->{'svc_acct_catchall'},
99 FS::svc_acct - Object methods for svc_acct records
105 $record = new FS::svc_acct \%hash;
106 $record = new FS::svc_acct { 'column' => 'value' };
108 $error = $record->insert;
110 $error = $new_record->replace($old_record);
112 $error = $record->delete;
114 $error = $record->check;
116 $error = $record->suspend;
118 $error = $record->unsuspend;
120 $error = $record->cancel;
122 %hash = $record->radius;
124 %hash = $record->radius_reply;
126 %hash = $record->radius_check;
128 $domain = $record->domain;
130 $svc_domain = $record->svc_domain;
132 $email = $record->email;
134 $seconds_since = $record->seconds_since($timestamp);
138 An FS::svc_acct object represents an account. FS::svc_acct inherits from
139 FS::svc_Common. The following fields are currently supported:
143 =item svcnum - primary key (assigned automatcially for new accounts)
147 =item _password - generated if blank
149 =item sec_phrase - security phrase
151 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
159 =item dir - set automatically if blank (and uid is not)
163 =item quota - (unimplementd)
165 =item slipip - IP address
169 =item domsvc - svcnum from svc_domain
171 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
181 Creates a new account. To add the account to the database, see L<"insert">.
185 sub table { 'svc_acct'; }
187 =item insert [ , OPTION => VALUE ... ]
189 Adds this account to the database. If there is an error, returns the error,
190 otherwise returns false.
192 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
193 defined. An FS::cust_svc record will be created and inserted.
195 The additional field I<usergroup> can optionally be defined; if so it should
196 contain an arrayref of group names. See L<FS::radius_usergroup>.
198 The additional field I<child_objects> can optionally be defined; if so it
199 should contain an arrayref of FS::tablename objects. They will have their
200 svcnum fields set and will be inserted after this record, but before any
203 Currently available options are: I<depend_jobnum>
205 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
206 jobnums), all provisioning jobs will have a dependancy on the supplied
207 jobnum(s) (they will not run until the specific job(s) complete(s)).
209 (TODOC: L<FS::queue> and L<freeside-queued>)
211 (TODOC: new exports!)
220 local $SIG{HUP} = 'IGNORE';
221 local $SIG{INT} = 'IGNORE';
222 local $SIG{QUIT} = 'IGNORE';
223 local $SIG{TERM} = 'IGNORE';
224 local $SIG{TSTP} = 'IGNORE';
225 local $SIG{PIPE} = 'IGNORE';
227 my $oldAutoCommit = $FS::UID::AutoCommit;
228 local $FS::UID::AutoCommit = 0;
231 $error = $self->check;
232 return $error if $error;
234 #no, duplicate checking just got a whole lot more complicated
235 #(perhaps keep this check with a config option to turn on?)
237 #return gettext('username_in_use'). ": ". $self->username
238 # if qsearchs( 'svc_acct', { 'username' => $self->username,
239 # 'domsvc' => $self->domsvc,
242 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
243 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
244 unless ( $cust_svc ) {
245 $dbh->rollback if $oldAutoCommit;
246 return "no cust_svc record found for svcnum ". $self->svcnum;
248 $self->pkgnum($cust_svc->pkgnum);
249 $self->svcpart($cust_svc->svcpart);
252 #new duplicate username checking
254 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
255 unless ( $part_svc ) {
256 $dbh->rollback if $oldAutoCommit;
257 return 'unknown svcpart '. $self->svcpart;
260 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
261 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
262 'domsvc' => $self->domsvc } );
264 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
265 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
266 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
271 if ( @dup_user || @dup_userdomain || @dup_uid ) {
272 my $exports = FS::part_export::export_info('svc_acct');
273 my %conflict_user_svcpart;
274 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
276 foreach my $part_export ( $part_svc->part_export ) {
278 #this will catch to the same exact export
279 my @svcparts = map { $_->svcpart }
280 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
282 #this will catch to exports w/same exporthost+type ???
283 #my @other_part_export = qsearch('part_export', {
284 # 'machine' => $part_export->machine,
285 # 'exporttype' => $part_export->exporttype,
287 #foreach my $other_part_export ( @other_part_export ) {
288 # push @svcparts, map { $_->svcpart }
289 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
292 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
293 #silly kludge to avoid uninitialized value errors
294 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
295 ? $exports->{$part_export->exporttype}{'nodomain'}
297 if ( $nodomain =~ /^Y/i ) {
298 $conflict_user_svcpart{$_} = $part_export->exportnum
301 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
306 foreach my $dup_user ( @dup_user ) {
307 my $dup_svcpart = $dup_user->cust_svc->svcpart;
308 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
309 $dbh->rollback if $oldAutoCommit;
310 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
311 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
315 foreach my $dup_userdomain ( @dup_userdomain ) {
316 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
317 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
318 $dbh->rollback if $oldAutoCommit;
319 return "duplicate username\@domain: conflicts with svcnum ".
320 $dup_userdomain->svcnum. " via exportnum ".
321 $conflict_userdomain_svcpart{$dup_svcpart};
325 foreach my $dup_uid ( @dup_uid ) {
326 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
327 if ( exists($conflict_user_svcpart{$dup_svcpart})
328 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
329 $dbh->rollback if $oldAutoCommit;
330 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
331 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
332 || $conflict_userdomain_svcpart{$dup_svcpart};
338 #see? i told you it was more complicated
341 $error = $self->SUPER::insert(
342 'jobnums' => \@jobnums,
343 'child_objects' => $self->child_objects,
347 $dbh->rollback if $oldAutoCommit;
351 if ( $self->usergroup ) {
352 foreach my $groupname ( @{$self->usergroup} ) {
353 my $radius_usergroup = new FS::radius_usergroup ( {
354 svcnum => $self->svcnum,
355 groupname => $groupname,
357 my $error = $radius_usergroup->insert;
359 $dbh->rollback if $oldAutoCommit;
365 #false laziness with sub replace (and cust_main)
366 my $queue = new FS::queue {
367 'svcnum' => $self->svcnum,
368 'job' => 'FS::svc_acct::append_fuzzyfiles'
370 $error = $queue->insert($self->username);
372 $dbh->rollback if $oldAutoCommit;
373 return "queueing job (transaction rolled back): $error";
376 my $cust_pkg = $self->cust_svc->cust_pkg;
379 my $cust_main = $cust_pkg->cust_main;
381 if ( $conf->exists('emailinvoiceauto') ) {
382 my @invoicing_list = $cust_main->invoicing_list;
383 push @invoicing_list, $self->email;
384 $cust_main->invoicing_list(\@invoicing_list);
389 if ( $welcome_template && $cust_pkg ) {
390 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
392 my $wqueue = new FS::queue {
393 'svcnum' => $self->svcnum,
394 'job' => 'FS::svc_acct::send_email'
396 my $error = $wqueue->insert(
398 'from' => $welcome_from,
399 'subject' => $welcome_subject,
400 'mimetype' => $welcome_mimetype,
401 'body' => $welcome_template->fill_in( HASH => {
402 'custnum' => $self->custnum,
403 'username' => $self->username,
404 'password' => $self->_password,
405 'first' => $cust_main->first,
406 'last' => $cust_main->getfield('last'),
407 'pkg' => $cust_pkg->part_pkg->pkg,
411 $dbh->rollback if $oldAutoCommit;
412 return "error queuing welcome email: $error";
415 if ( $options{'depend_jobnum'} ) {
416 warn "$me depend_jobnum found; adding to welcome email dependancies"
418 if ( ref($options{'depend_jobnum'}) ) {
419 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
420 "to welcome email dependancies"
422 push @jobnums, @{ $options{'depend_jobnum'} };
424 warn "$me adding job $options{'depend_jobnum'} ".
425 "to welcome email dependancies"
427 push @jobnums, $options{'depend_jobnum'};
431 foreach my $jobnum ( @jobnums ) {
432 my $error = $wqueue->depend_insert($jobnum);
434 $dbh->rollback if $oldAutoCommit;
435 return "error queuing welcome email job dependancy: $error";
445 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
451 Deletes this account from the database. If there is an error, returns the
452 error, otherwise returns false.
454 The corresponding FS::cust_svc record will be deleted as well.
456 (TODOC: new exports!)
463 if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
464 return "Can't delete an account which has (svc_acct_sm) mail aliases!"
465 if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
468 return "can't delete system account" if $self->_check_system;
470 return "Can't delete an account which is a (svc_forward) source!"
471 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
473 return "Can't delete an account which is a (svc_forward) destination!"
474 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
476 return "Can't delete an account with (svc_www) web service!"
477 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
479 # what about records in session ? (they should refer to history table)
481 local $SIG{HUP} = 'IGNORE';
482 local $SIG{INT} = 'IGNORE';
483 local $SIG{QUIT} = 'IGNORE';
484 local $SIG{TERM} = 'IGNORE';
485 local $SIG{TSTP} = 'IGNORE';
486 local $SIG{PIPE} = 'IGNORE';
488 my $oldAutoCommit = $FS::UID::AutoCommit;
489 local $FS::UID::AutoCommit = 0;
492 foreach my $cust_main_invoice (
493 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
495 unless ( defined($cust_main_invoice) ) {
496 warn "WARNING: something's wrong with qsearch";
499 my %hash = $cust_main_invoice->hash;
500 $hash{'dest'} = $self->email;
501 my $new = new FS::cust_main_invoice \%hash;
502 my $error = $new->replace($cust_main_invoice);
504 $dbh->rollback if $oldAutoCommit;
509 foreach my $svc_domain (
510 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
512 my %hash = new FS::svc_domain->hash;
513 $hash{'catchall'} = '';
514 my $new = new FS::svc_domain \%hash;
515 my $error = $new->replace($svc_domain);
517 $dbh->rollback if $oldAutoCommit;
522 foreach my $radius_usergroup (
523 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
525 my $error = $radius_usergroup->delete;
527 $dbh->rollback if $oldAutoCommit;
532 my $error = $self->SUPER::delete;
534 $dbh->rollback if $oldAutoCommit;
538 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
542 =item replace OLD_RECORD
544 Replaces OLD_RECORD with this one in the database. If there is an error,
545 returns the error, otherwise returns false.
547 The additional field I<usergroup> can optionally be defined; if so it should
548 contain an arrayref of group names. See L<FS::radius_usergroup>.
554 my ( $new, $old ) = ( shift, shift );
556 warn "$me replacing $old with $new\n" if $DEBUG;
558 return "can't modify system account" if $old->_check_system;
560 return "Username in use"
561 if $old->username ne $new->username &&
562 qsearchs( 'svc_acct', { 'username' => $new->username,
563 'domsvc' => $new->domsvc,
566 #no warnings 'numeric'; #alas, a 5.006-ism
568 return "Can't change uid!" if $old->uid != $new->uid;
571 #change homdir when we change username
572 $new->setfield('dir', '') if $old->username ne $new->username;
574 local $SIG{HUP} = 'IGNORE';
575 local $SIG{INT} = 'IGNORE';
576 local $SIG{QUIT} = 'IGNORE';
577 local $SIG{TERM} = 'IGNORE';
578 local $SIG{TSTP} = 'IGNORE';
579 local $SIG{PIPE} = 'IGNORE';
581 my $oldAutoCommit = $FS::UID::AutoCommit;
582 local $FS::UID::AutoCommit = 0;
585 # redundant, but so $new->usergroup gets set
586 $error = $new->check;
587 return $error if $error;
589 $old->usergroup( [ $old->radius_groups ] );
590 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
591 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
592 if ( $new->usergroup ) {
593 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
594 my @newgroups = @{$new->usergroup};
595 foreach my $oldgroup ( @{$old->usergroup} ) {
596 if ( grep { $oldgroup eq $_ } @newgroups ) {
597 @newgroups = grep { $oldgroup ne $_ } @newgroups;
600 my $radius_usergroup = qsearchs('radius_usergroup', {
601 svcnum => $old->svcnum,
602 groupname => $oldgroup,
604 my $error = $radius_usergroup->delete;
606 $dbh->rollback if $oldAutoCommit;
607 return "error deleting radius_usergroup $oldgroup: $error";
611 foreach my $newgroup ( @newgroups ) {
612 my $radius_usergroup = new FS::radius_usergroup ( {
613 svcnum => $new->svcnum,
614 groupname => $newgroup,
616 my $error = $radius_usergroup->insert;
618 $dbh->rollback if $oldAutoCommit;
619 return "error adding radius_usergroup $newgroup: $error";
625 $error = $new->SUPER::replace($old);
627 $dbh->rollback if $oldAutoCommit;
628 return $error if $error;
631 if ( $new->username ne $old->username ) {
632 #false laziness with sub insert (and cust_main)
633 my $queue = new FS::queue {
634 'svcnum' => $new->svcnum,
635 'job' => 'FS::svc_acct::append_fuzzyfiles'
637 $error = $queue->insert($new->username);
639 $dbh->rollback if $oldAutoCommit;
640 return "queueing job (transaction rolled back): $error";
644 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
650 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
651 error, returns the error, otherwise returns false.
653 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
655 Calls any export-specific suspend hooks.
661 return "can't suspend system account" if $self->_check_system;
662 $self->SUPER::suspend;
667 Unsuspends this account by removing *SUSPENDED* from the password. If there is
668 an error, returns the error, otherwise returns false.
670 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
672 Calls any export-specific unsuspend hooks.
678 my %hash = $self->hash;
679 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
680 $hash{_password} = $1;
681 my $new = new FS::svc_acct ( \%hash );
682 my $error = $new->replace($self);
683 return $error if $error;
686 $self->SUPER::unsuspend;
691 Just returns false (no error) for now.
693 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
697 Checks all fields to make sure this is a valid service. If there is an error,
698 returns the error, otherwise returns false. Called by the insert and replace
701 Sets any fixed values; see L<FS::part_svc>.
708 my($recref) = $self->hashref;
710 my $x = $self->setfixed;
711 return $x unless ref($x);
714 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
716 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
719 my $error = $self->ut_numbern('svcnum')
720 #|| $self->ut_number('domsvc')
721 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
722 || $self->ut_textn('sec_phrase')
724 return $error if $error;
726 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
727 if ( $username_uppercase ) {
728 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
729 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
730 $recref->{username} = $1;
732 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
733 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
734 $recref->{username} = $1;
737 if ( $username_letterfirst ) {
738 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
739 } elsif ( $username_letter ) {
740 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
742 if ( $username_noperiod ) {
743 $recref->{username} =~ /\./ and return gettext('illegal_username');
745 if ( $username_nounderscore ) {
746 $recref->{username} =~ /_/ and return gettext('illegal_username');
748 if ( $username_nodash ) {
749 $recref->{username} =~ /\-/ and return gettext('illegal_username');
751 unless ( $username_ampersand ) {
752 $recref->{username} =~ /\&/ and return gettext('illegal_username');
755 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
756 $recref->{popnum} = $1;
757 return "Unknown popnum" unless
758 ! $recref->{popnum} ||
759 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
761 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
763 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
764 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
766 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
767 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
768 #not all systems use gid=uid
769 #you can set a fixed gid in part_svc
771 return "Only root can have uid 0"
772 if $recref->{uid} == 0
773 && $recref->{username} ne 'root'
774 && $recref->{username} ne 'toor';
777 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
778 or return "Illegal directory: ". $recref->{dir};
780 return "Illegal directory"
781 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
782 return "Illegal directory"
783 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
784 unless ( $recref->{dir} ) {
785 $recref->{dir} = $dir_prefix . '/';
786 if ( $dirhash > 0 ) {
787 for my $h ( 1 .. $dirhash ) {
788 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
790 } elsif ( $dirhash < 0 ) {
791 for my $h ( reverse $dirhash .. -1 ) {
792 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
795 $recref->{dir} .= $recref->{username};
799 unless ( $recref->{username} eq 'sync' ) {
800 if ( grep $_ eq $recref->{shell}, @shells ) {
801 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
803 return "Illegal shell \`". $self->shell. "\'; ".
804 $conf->dir. "/shells contains: @shells";
807 $recref->{shell} = '/bin/sync';
811 $recref->{gid} ne '' ?
812 return "Can't have gid without uid" : ( $recref->{gid}='' );
813 $recref->{dir} ne '' ?
814 return "Can't have directory without uid" : ( $recref->{dir}='' );
815 $recref->{shell} ne '' ?
816 return "Can't have shell without uid" : ( $recref->{shell}='' );
819 # $error = $self->ut_textn('finger');
820 # return $error if $error;
821 if ( $self->getfield('finger') eq '' ) {
822 my $cust_pkg = $self->svcnum
823 ? $self->cust_svc->cust_pkg
824 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
826 my $cust_main = $cust_pkg->cust_main;
827 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
830 $self->getfield('finger') =~
831 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
832 or return "Illegal finger: ". $self->getfield('finger');
833 $self->setfield('finger', $1);
835 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
836 $recref->{quota} = $1;
838 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
839 if ( $recref->{slipip} eq '' ) {
840 $recref->{slipip} = '';
841 } elsif ( $recref->{slipip} eq '0e0' ) {
842 $recref->{slipip} = '0e0';
844 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
845 or return "Illegal slipip". $self->slipip;
846 $recref->{slipip} = $1;
851 #arbitrary RADIUS stuff; allow ut_textn for now
852 foreach ( grep /^radius_/, fields('svc_acct') ) {
856 #generate a password if it is blank
857 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
858 unless ( $recref->{_password} );
860 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
861 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
862 $recref->{_password} = $1.$3;
863 #uncomment this to encrypt password immediately upon entry, or run
864 #bin/crypt_pw in cron to give new users a window during which their
865 #password is available to techs, for faxing, etc. (also be aware of
867 #$recref->{password} = $1.
868 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
870 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
871 $recref->{_password} = $1.$3;
872 } elsif ( $recref->{_password} eq '*' ) {
873 $recref->{_password} = '*';
874 } elsif ( $recref->{_password} eq '!' ) {
875 $recref->{_password} = '!';
876 } elsif ( $recref->{_password} eq '!!' ) {
877 $recref->{_password} = '!!';
879 #return "Illegal password";
880 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
881 FS::Msgcat::_gettext('illegal_password_characters').
882 ": ". $recref->{_password};
894 scalar( grep { $self->username eq $_ || $self->email eq $_ }
895 $conf->config('system_usernames')
902 Depriciated, use radius_reply instead.
907 carp "FS::svc_acct::radius depriciated, use radius_reply";
913 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
914 reply attributes of this record.
916 Note that this is now the preferred method for reading RADIUS attributes -
917 accessing the columns directly is discouraged, as the column names are
918 expected to change in the future.
927 my($column, $attrib) = ($1, $2);
928 #$attrib =~ s/_/\-/g;
929 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
930 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
931 if ( $self->slipip && $self->slipip ne '0e0' ) {
932 $reply{$radius_ip} = $self->slipip;
939 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
940 check attributes of this record.
942 Note that this is now the preferred method for reading RADIUS attributes -
943 accessing the columns directly is discouraged, as the column names are
944 expected to change in the future.
950 my $password = $self->_password;
951 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
952 ( $pw_attrib => $self->_password,
955 my($column, $attrib) = ($1, $2);
956 #$attrib =~ s/_/\-/g;
957 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
958 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
964 Returns the domain associated with this account.
970 if ( $self->domsvc ) {
971 #$self->svc_domain->domain;
972 my $svc_domain = $self->svc_domain
973 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
976 $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
982 Returns the FS::svc_domain record for this account's domain (see
991 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
996 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1002 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1007 Returns an email address associated with the account.
1013 $self->username. '@'. $self->domain;
1018 Returns an array of FS::acct_snarf records associated with the account.
1019 If the acct_snarf table does not exist or there are no associated records,
1020 an empty list is returned
1026 return () unless dbdef->table('acct_snarf');
1027 eval "use FS::acct_snarf;";
1029 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1032 =item seconds_since TIMESTAMP
1034 Returns the number of seconds this account has been online since TIMESTAMP,
1035 according to the session monitor (see L<FS::Session>).
1037 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1038 L<Time::Local> and L<Date::Parse> for conversion functions.
1042 #note: POD here, implementation in FS::cust_svc
1045 $self->cust_svc->seconds_since(@_);
1048 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1050 Returns the numbers of seconds this account has been online between
1051 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1052 external SQL radacct table, specified via sqlradius export. Sessions which
1053 started in the specified range but are still open are counted from session
1054 start to the end of the range (unless they are over 1 day old, in which case
1055 they are presumed missing their stop record and not counted). Also, sessions
1056 which end in the range but started earlier are counted from the start of the
1057 range to session end. Finally, sessions which start before the range but end
1058 after are counted for the entire range.
1060 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1061 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1066 #note: POD here, implementation in FS::cust_svc
1067 sub seconds_since_sqlradacct {
1069 $self->cust_svc->seconds_since_sqlradacct(@_);
1072 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1074 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1075 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1076 TIMESTAMP_END (exclusive).
1078 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1079 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1084 #note: POD here, implementation in FS::cust_svc
1085 sub attribute_since_sqlradacct {
1087 $self->cust_svc->attribute_since_sqlradacct(@_);
1091 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1093 Returns an array of hash references of this customers login history for the
1094 given time range. (document this better)
1098 sub get_session_history_sqlradacct {
1100 $self->cust_svc->get_session_history_sqlradacct(@_);
1105 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1111 if ( $self->usergroup ) {
1112 #when provisioning records, export callback runs in svc_Common.pm before
1113 #radius_usergroup records can be inserted...
1114 @{$self->usergroup};
1116 map { $_->groupname }
1117 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1121 =item clone_suspended
1123 Constructor used by FS::part_export::_export_suspend fallback. Document
1128 sub clone_suspended {
1130 my %hash = $self->hash;
1131 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1132 new FS::svc_acct \%hash;
1135 =item clone_kludge_unsuspend
1137 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1142 sub clone_kludge_unsuspend {
1144 my %hash = $self->hash;
1145 $hash{_password} = '';
1146 new FS::svc_acct \%hash;
1149 =item check_password
1151 Checks the supplied password against the (possibly encrypted) password in the
1152 database. Returns true for a sucessful authentication, false for no match.
1154 Currently supported encryptions are: classic DES crypt() and MD5
1158 sub check_password {
1159 my($self, $check_password) = @_;
1161 #remove old-style SUSPENDED kludge, they should be allowed to login to
1162 #self-service and pay up
1163 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1165 #eventually should check a "password-encoding" field
1166 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1168 } elsif ( length($password) < 13 ) { #plaintext
1169 $check_password eq $password;
1170 } elsif ( length($password) == 13 ) { #traditional DES crypt
1171 crypt($check_password, $password) eq $password;
1172 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1173 unix_md5_crypt($check_password, $password) eq $password;
1174 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1175 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1176 $self->svcnum. "\n";
1179 warn "Can't check password: Unrecognized encryption for svcnum ".
1180 $self->svcnum. "\n";
1200 use Mail::Internet 1.44;
1203 $opt{mimetype} ||= 'text/plain';
1204 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1206 $ENV{MAILADDRESS} = $opt{from};
1207 my $header = new Mail::Header ( [
1210 "Sender: $opt{from}",
1211 "Reply-To: $opt{from}",
1212 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1213 "Subject: $opt{subject}",
1214 "Content-Type: $opt{mimetype}",
1216 my $message = new Mail::Internet (
1217 'Header' => $header,
1218 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1221 $message->smtpsend( Host => $smtpmachine )
1222 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1223 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1226 =item check_and_rebuild_fuzzyfiles
1230 sub check_and_rebuild_fuzzyfiles {
1231 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1232 -e "$dir/svc_acct.username"
1233 or &rebuild_fuzzyfiles;
1236 =item rebuild_fuzzyfiles
1240 sub rebuild_fuzzyfiles {
1242 use Fcntl qw(:flock);
1244 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1248 open(USERNAMELOCK,">>$dir/svc_acct.username")
1249 or die "can't open $dir/svc_acct.username: $!";
1250 flock(USERNAMELOCK,LOCK_EX)
1251 or die "can't lock $dir/svc_acct.username: $!";
1253 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1255 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1256 or die "can't open $dir/svc_acct.username.tmp: $!";
1257 print USERNAMECACHE join("\n", @all_username), "\n";
1258 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1260 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1270 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1271 open(USERNAMECACHE,"<$dir/svc_acct.username")
1272 or die "can't open $dir/svc_acct.username: $!";
1273 my @array = map { chomp; $_; } <USERNAMECACHE>;
1274 close USERNAMECACHE;
1278 =item append_fuzzyfiles USERNAME
1282 sub append_fuzzyfiles {
1283 my $username = shift;
1285 &check_and_rebuild_fuzzyfiles;
1287 use Fcntl qw(:flock);
1289 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1291 open(USERNAME,">>$dir/svc_acct.username")
1292 or die "can't open $dir/svc_acct.username: $!";
1293 flock(USERNAME,LOCK_EX)
1294 or die "can't lock $dir/svc_acct.username: $!";
1296 print USERNAME "$username\n";
1298 flock(USERNAME,LOCK_UN)
1299 or die "can't unlock $dir/svc_acct.username: $!";
1307 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1311 sub radius_usergroup_selector {
1312 my $sel_groups = shift;
1313 my %sel_groups = map { $_=>1 } @$sel_groups;
1315 my $selectname = shift || 'radius_usergroup';
1318 my $sth = $dbh->prepare(
1319 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1320 ) or die $dbh->errstr;
1321 $sth->execute() or die $sth->errstr;
1322 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1326 function ${selectname}_doadd(object) {
1327 var myvalue = object.${selectname}_add.value;
1328 var optionName = new Option(myvalue,myvalue,false,true);
1329 var length = object.$selectname.length;
1330 object.$selectname.options[length] = optionName;
1331 object.${selectname}_add.value = "";
1334 <SELECT MULTIPLE NAME="$selectname">
1337 foreach my $group ( @all_groups ) {
1339 if ( $sel_groups{$group} ) {
1340 $html .= ' SELECTED';
1341 $sel_groups{$group} = 0;
1343 $html .= ">$group</OPTION>\n";
1345 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1346 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1348 $html .= '</SELECT>';
1350 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1351 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1360 The $recref stuff in sub check should be cleaned up.
1362 The suspend, unsuspend and cancel methods update the database, but not the
1363 current object. This is probably a bug as it's unexpected and
1366 radius_usergroup_selector? putting web ui components in here? they should
1367 probably live somewhere else...
1369 insertion of RADIUS group stuff in insert could be done with child_objects now
1370 (would probably clean up export of them too)
1374 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1375 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1376 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1377 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1378 schema.html from the base documentation.