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
18 use FS::UID qw( datasrc );
20 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
27 use FS::cust_main_invoice;
31 use FS::radius_usergroup;
34 use FS::Msgcat qw(gettext);
36 @ISA = qw( FS::svc_Common );
39 $me = '[FS::svc_acct]';
41 #ask FS::UID to run this stuff for us later
42 $FS::UID::callback{'FS::svc_acct'} = sub {
44 $dir_prefix = $conf->config('home');
45 @shells = $conf->config('shells');
46 $usernamemin = $conf->config('usernamemin') || 2;
47 $usernamemax = $conf->config('usernamemax');
48 $passwordmin = $conf->config('passwordmin') || 6;
49 $passwordmax = $conf->config('passwordmax') || 8;
50 $username_letter = $conf->exists('username-letter');
51 $username_letterfirst = $conf->exists('username-letterfirst');
52 $username_noperiod = $conf->exists('username-noperiod');
53 $username_nounderscore = $conf->exists('username-nounderscore');
54 $username_nodash = $conf->exists('username-nodash');
55 $username_uppercase = $conf->exists('username-uppercase');
56 $username_ampersand = $conf->exists('username-ampersand');
57 $mydomain = $conf->config('domain');
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'; }
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>. (used in
193 sqlradius export only)
195 The additional field I<child_objects> can optionally be defined; if so it
196 should contain an arrayref of FS::tablename objects. They will have their
197 svcnum fields set and will be inserted after this record, but before any
200 (TODOC: L<FS::queue> and L<freeside-queued>)
202 (TODOC: new exports!)
211 local $SIG{HUP} = 'IGNORE';
212 local $SIG{INT} = 'IGNORE';
213 local $SIG{QUIT} = 'IGNORE';
214 local $SIG{TERM} = 'IGNORE';
215 local $SIG{TSTP} = 'IGNORE';
216 local $SIG{PIPE} = 'IGNORE';
218 my $oldAutoCommit = $FS::UID::AutoCommit;
219 local $FS::UID::AutoCommit = 0;
222 $error = $self->check;
223 return $error if $error;
225 #no, duplicate checking just got a whole lot more complicated
226 #(perhaps keep this check with a config option to turn on?)
228 #return gettext('username_in_use'). ": ". $self->username
229 # if qsearchs( 'svc_acct', { 'username' => $self->username,
230 # 'domsvc' => $self->domsvc,
233 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
234 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
235 unless ( $cust_svc ) {
236 $dbh->rollback if $oldAutoCommit;
237 return "no cust_svc record found for svcnum ". $self->svcnum;
239 $self->pkgnum($cust_svc->pkgnum);
240 $self->svcpart($cust_svc->svcpart);
243 #new duplicate username checking
245 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
246 unless ( $part_svc ) {
247 $dbh->rollback if $oldAutoCommit;
248 return 'unknown svcpart '. $self->svcpart;
251 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
252 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
253 'domsvc' => $self->domsvc } );
255 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
256 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
257 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
262 if ( @dup_user || @dup_userdomain || @dup_uid ) {
263 my $exports = FS::part_export::export_info('svc_acct');
264 my %conflict_user_svcpart;
265 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
267 foreach my $part_export ( $part_svc->part_export ) {
269 #this will catch to the same exact export
270 my @svcparts = map { $_->svcpart }
271 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
273 #this will catch to exports w/same exporthost+type ???
274 #my @other_part_export = qsearch('part_export', {
275 # 'machine' => $part_export->machine,
276 # 'exporttype' => $part_export->exporttype,
278 #foreach my $other_part_export ( @other_part_export ) {
279 # push @svcparts, map { $_->svcpart }
280 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
283 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
284 #silly kludge to avoid uninitialized value errors
285 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
286 ? $exports->{$part_export->exporttype}{'nodomain'}
288 if ( $nodomain =~ /^Y/i ) {
289 $conflict_user_svcpart{$_} = $part_export->exportnum
292 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
297 foreach my $dup_user ( @dup_user ) {
298 my $dup_svcpart = $dup_user->cust_svc->svcpart;
299 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
300 $dbh->rollback if $oldAutoCommit;
301 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
302 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
306 foreach my $dup_userdomain ( @dup_userdomain ) {
307 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
308 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
309 $dbh->rollback if $oldAutoCommit;
310 return "duplicate username\@domain: conflicts with svcnum ".
311 $dup_userdomain->svcnum. " via exportnum ".
312 $conflict_userdomain_svcpart{$dup_svcpart};
316 foreach my $dup_uid ( @dup_uid ) {
317 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
318 if ( exists($conflict_user_svcpart{$dup_svcpart})
319 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
320 $dbh->rollback if $oldAutoCommit;
321 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
322 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
323 || $conflict_userdomain_svcpart{$dup_svcpart};
329 #see? i told you it was more complicated
332 $error = $self->SUPER::insert(\@jobnums, $self->child_objects || [] );
334 $dbh->rollback if $oldAutoCommit;
338 if ( $self->usergroup ) {
339 foreach my $groupname ( @{$self->usergroup} ) {
340 my $radius_usergroup = new FS::radius_usergroup ( {
341 svcnum => $self->svcnum,
342 groupname => $groupname,
344 my $error = $radius_usergroup->insert;
346 $dbh->rollback if $oldAutoCommit;
352 #false laziness with sub replace (and cust_main)
353 my $queue = new FS::queue {
354 'svcnum' => $self->svcnum,
355 'job' => 'FS::svc_acct::append_fuzzyfiles'
357 $error = $queue->insert($self->username);
359 $dbh->rollback if $oldAutoCommit;
360 return "queueing job (transaction rolled back): $error";
363 my $cust_pkg = $self->cust_svc->cust_pkg;
366 my $cust_main = $cust_pkg->cust_main;
368 if ( $conf->exists('emailinvoiceauto') ) {
369 my @invoicing_list = $cust_main->invoicing_list;
370 push @invoicing_list, $self->email;
371 $cust_main->invoicing_list(\@invoicing_list);
376 if ( $welcome_template && $cust_pkg ) {
377 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
379 my $wqueue = new FS::queue {
380 'svcnum' => $self->svcnum,
381 'job' => 'FS::svc_acct::send_email'
383 my $error = $wqueue->insert(
385 'from' => $welcome_from,
386 'subject' => $welcome_subject,
387 'mimetype' => $welcome_mimetype,
388 'body' => $welcome_template->fill_in( HASH => {
389 'custnum' => $self->custnum,
390 'username' => $self->username,
391 'password' => $self->_password,
392 'first' => $cust_main->first,
393 'last' => $cust_main->getfield('last'),
394 'pkg' => $cust_pkg->part_pkg->pkg,
398 $dbh->rollback if $oldAutoCommit;
399 return "error queuing welcome email: $error";
402 foreach my $jobnum ( @jobnums ) {
403 my $error = $wqueue->depend_insert($jobnum);
405 $dbh->rollback if $oldAutoCommit;
406 return "error queuing welcome email job dependancy: $error";
416 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
422 Deletes this account from the database. If there is an error, returns the
423 error, otherwise returns false.
425 The corresponding FS::cust_svc record will be deleted as well.
427 (TODOC: new exports!)
434 if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
435 return "Can't delete an account which has (svc_acct_sm) mail aliases!"
436 if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
439 return "Can't delete an account which is a (svc_forward) source!"
440 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
442 return "Can't delete an account which is a (svc_forward) destination!"
443 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
445 return "Can't delete an account with (svc_www) web service!"
446 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
448 # what about records in session ? (they should refer to history table)
450 local $SIG{HUP} = 'IGNORE';
451 local $SIG{INT} = 'IGNORE';
452 local $SIG{QUIT} = 'IGNORE';
453 local $SIG{TERM} = 'IGNORE';
454 local $SIG{TSTP} = 'IGNORE';
455 local $SIG{PIPE} = 'IGNORE';
457 my $oldAutoCommit = $FS::UID::AutoCommit;
458 local $FS::UID::AutoCommit = 0;
461 foreach my $cust_main_invoice (
462 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
464 unless ( defined($cust_main_invoice) ) {
465 warn "WARNING: something's wrong with qsearch";
468 my %hash = $cust_main_invoice->hash;
469 $hash{'dest'} = $self->email;
470 my $new = new FS::cust_main_invoice \%hash;
471 my $error = $new->replace($cust_main_invoice);
473 $dbh->rollback if $oldAutoCommit;
478 foreach my $svc_domain (
479 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
481 my %hash = new FS::svc_domain->hash;
482 $hash{'catchall'} = '';
483 my $new = new FS::svc_domain \%hash;
484 my $error = $new->replace($svc_domain);
486 $dbh->rollback if $oldAutoCommit;
491 foreach my $radius_usergroup (
492 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
494 my $error = $radius_usergroup->delete;
496 $dbh->rollback if $oldAutoCommit;
501 my $error = $self->SUPER::delete;
503 $dbh->rollback if $oldAutoCommit;
507 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
511 =item replace OLD_RECORD
513 Replaces OLD_RECORD with this one in the database. If there is an error,
514 returns the error, otherwise returns false.
516 The additional field I<usergroup> can optionally be defined; if so it should
517 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
518 sqlradius export only)
523 my ( $new, $old ) = ( shift, shift );
525 warn "$me replacing $old with $new\n" if $DEBUG;
527 return "Username in use"
528 if $old->username ne $new->username &&
529 qsearchs( 'svc_acct', { 'username' => $new->username,
530 'domsvc' => $new->domsvc,
533 #no warnings 'numeric'; #alas, a 5.006-ism
535 return "Can't change uid!" if $old->uid != $new->uid;
538 #change homdir when we change username
539 $new->setfield('dir', '') if $old->username ne $new->username;
541 local $SIG{HUP} = 'IGNORE';
542 local $SIG{INT} = 'IGNORE';
543 local $SIG{QUIT} = 'IGNORE';
544 local $SIG{TERM} = 'IGNORE';
545 local $SIG{TSTP} = 'IGNORE';
546 local $SIG{PIPE} = 'IGNORE';
548 my $oldAutoCommit = $FS::UID::AutoCommit;
549 local $FS::UID::AutoCommit = 0;
552 # redundant, but so $new->usergroup gets set
553 $error = $new->check;
554 return $error if $error;
556 $old->usergroup( [ $old->radius_groups ] );
557 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
558 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
559 if ( $new->usergroup ) {
560 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
561 my @newgroups = @{$new->usergroup};
562 foreach my $oldgroup ( @{$old->usergroup} ) {
563 if ( grep { $oldgroup eq $_ } @newgroups ) {
564 @newgroups = grep { $oldgroup ne $_ } @newgroups;
567 my $radius_usergroup = qsearchs('radius_usergroup', {
568 svcnum => $old->svcnum,
569 groupname => $oldgroup,
571 my $error = $radius_usergroup->delete;
573 $dbh->rollback if $oldAutoCommit;
574 return "error deleting radius_usergroup $oldgroup: $error";
578 foreach my $newgroup ( @newgroups ) {
579 my $radius_usergroup = new FS::radius_usergroup ( {
580 svcnum => $new->svcnum,
581 groupname => $newgroup,
583 my $error = $radius_usergroup->insert;
585 $dbh->rollback if $oldAutoCommit;
586 return "error adding radius_usergroup $newgroup: $error";
592 $error = $new->SUPER::replace($old);
594 $dbh->rollback if $oldAutoCommit;
595 return $error if $error;
598 if ( $new->username ne $old->username ) {
599 #false laziness with sub insert (and cust_main)
600 my $queue = new FS::queue {
601 'svcnum' => $new->svcnum,
602 'job' => 'FS::svc_acct::append_fuzzyfiles'
604 $error = $queue->insert($new->username);
606 $dbh->rollback if $oldAutoCommit;
607 return "queueing job (transaction rolled back): $error";
611 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
617 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
618 error, returns the error, otherwise returns false.
620 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
622 Calls any export-specific suspend hooks.
628 my %hash = $self->hash;
629 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
630 || $hash{_password} eq '*'
632 $hash{_password} = '*SUSPENDED* '.$hash{_password};
633 my $new = new FS::svc_acct ( \%hash );
634 my $error = $new->replace($self);
635 return $error if $error;
638 $self->SUPER::suspend;
643 Unsuspends this account by removing *SUSPENDED* from the password. If there is
644 an error, returns the error, otherwise returns false.
646 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
648 Calls any export-specific unsuspend hooks.
654 my %hash = $self->hash;
655 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
656 $hash{_password} = $1;
657 my $new = new FS::svc_acct ( \%hash );
658 my $error = $new->replace($self);
659 return $error if $error;
662 $self->SUPER::unsuspend;
667 Just returns false (no error) for now.
669 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
673 Checks all fields to make sure this is a valid service. If there is an error,
674 returns the error, otherwise returns false. Called by the insert and replace
677 Sets any fixed values; see L<FS::part_svc>.
684 my($recref) = $self->hashref;
686 my $x = $self->setfixed;
687 return $x unless ref($x);
690 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
692 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
695 my $error = $self->ut_numbern('svcnum')
696 #|| $self->ut_number('domsvc')
697 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
698 || $self->ut_textn('sec_phrase')
700 return $error if $error;
702 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
703 if ( $username_uppercase ) {
704 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
705 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
706 $recref->{username} = $1;
708 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
709 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
710 $recref->{username} = $1;
713 if ( $username_letterfirst ) {
714 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
715 } elsif ( $username_letter ) {
716 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
718 if ( $username_noperiod ) {
719 $recref->{username} =~ /\./ and return gettext('illegal_username');
721 if ( $username_nounderscore ) {
722 $recref->{username} =~ /_/ and return gettext('illegal_username');
724 if ( $username_nodash ) {
725 $recref->{username} =~ /\-/ and return gettext('illegal_username');
727 unless ( $username_ampersand ) {
728 $recref->{username} =~ /\&/ and return gettext('illegal_username');
731 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
732 $recref->{popnum} = $1;
733 return "Unknown popnum" unless
734 ! $recref->{popnum} ||
735 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
737 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
739 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
740 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
742 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
743 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
744 #not all systems use gid=uid
745 #you can set a fixed gid in part_svc
747 return "Only root can have uid 0"
748 if $recref->{uid} == 0
749 && $recref->{username} ne 'root'
750 && $recref->{username} ne 'toor';
753 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
754 or return "Illegal directory: ". $recref->{dir};
756 return "Illegal directory"
757 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
758 return "Illegal directory"
759 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
760 unless ( $recref->{dir} ) {
761 $recref->{dir} = $dir_prefix . '/';
762 if ( $dirhash > 0 ) {
763 for my $h ( 1 .. $dirhash ) {
764 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
766 } elsif ( $dirhash < 0 ) {
767 for my $h ( reverse $dirhash .. -1 ) {
768 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
771 $recref->{dir} .= $recref->{username};
775 unless ( $recref->{username} eq 'sync' ) {
776 if ( grep $_ eq $recref->{shell}, @shells ) {
777 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
779 return "Illegal shell \`". $self->shell. "\'; ".
780 $conf->dir. "/shells contains: @shells";
783 $recref->{shell} = '/bin/sync';
787 $recref->{gid} ne '' ?
788 return "Can't have gid without uid" : ( $recref->{gid}='' );
789 $recref->{dir} ne '' ?
790 return "Can't have directory without uid" : ( $recref->{dir}='' );
791 $recref->{shell} ne '' ?
792 return "Can't have shell without uid" : ( $recref->{shell}='' );
795 # $error = $self->ut_textn('finger');
796 # return $error if $error;
797 $self->getfield('finger') =~
798 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
799 or return "Illegal finger: ". $self->getfield('finger');
800 $self->setfield('finger', $1);
802 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
803 $recref->{quota} = $1;
805 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
806 if ( $recref->{slipip} eq '' ) {
807 $recref->{slipip} = '';
808 } elsif ( $recref->{slipip} eq '0e0' ) {
809 $recref->{slipip} = '0e0';
811 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
812 or return "Illegal slipip". $self->slipip;
813 $recref->{slipip} = $1;
818 #arbitrary RADIUS stuff; allow ut_textn for now
819 foreach ( grep /^radius_/, fields('svc_acct') ) {
823 #generate a password if it is blank
824 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
825 unless ( $recref->{_password} );
827 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
828 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
829 $recref->{_password} = $1.$3;
830 #uncomment this to encrypt password immediately upon entry, or run
831 #bin/crypt_pw in cron to give new users a window during which their
832 #password is available to techs, for faxing, etc. (also be aware of
834 #$recref->{password} = $1.
835 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
837 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
838 $recref->{_password} = $1.$3;
839 } elsif ( $recref->{_password} eq '*' ) {
840 $recref->{_password} = '*';
841 } elsif ( $recref->{_password} eq '!' ) {
842 $recref->{_password} = '!';
843 } elsif ( $recref->{_password} eq '!!' ) {
844 $recref->{_password} = '!!';
846 #return "Illegal password";
847 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
848 FS::Msgcat::_gettext('illegal_password_characters').
849 ": ". $recref->{_password};
857 Depriciated, use radius_reply instead.
862 carp "FS::svc_acct::radius depriciated, use radius_reply";
868 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
869 reply attributes of this record.
871 Note that this is now the preferred method for reading RADIUS attributes -
872 accessing the columns directly is discouraged, as the column names are
873 expected to change in the future.
882 my($column, $attrib) = ($1, $2);
883 #$attrib =~ s/_/\-/g;
884 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
885 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
886 if ( $self->slipip && $self->slipip ne '0e0' ) {
887 $reply{$radius_ip} = $self->slipip;
894 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
895 check attributes of this record.
897 Note that this is now the preferred method for reading RADIUS attributes -
898 accessing the columns directly is discouraged, as the column names are
899 expected to change in the future.
905 my $password = $self->_password;
906 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
907 ( $pw_attrib => $self->_password,
910 my($column, $attrib) = ($1, $2);
911 #$attrib =~ s/_/\-/g;
912 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
913 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
919 Returns the domain associated with this account.
925 if ( $self->domsvc ) {
926 #$self->svc_domain->domain;
927 my $svc_domain = $self->svc_domain
928 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
931 $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
937 Returns the FS::svc_domain record for this account's domain (see
946 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
951 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
957 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
962 Returns an email address associated with the account.
968 $self->username. '@'. $self->domain;
973 Returns an array of FS::acct_snarf records associated with the account.
974 If the acct_snarf table does not exist or there are no associated records,
975 an empty list is returned
981 return () unless dbdef->table('acct_snarf');
982 eval "use FS::acct_snarf;";
984 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
987 =item seconds_since TIMESTAMP
989 Returns the number of seconds this account has been online since TIMESTAMP,
990 according to the session monitor (see L<FS::Session>).
992 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
993 L<Time::Local> and L<Date::Parse> for conversion functions.
997 #note: POD here, implementation in FS::cust_svc
1000 $self->cust_svc->seconds_since(@_);
1003 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1005 Returns the numbers of seconds this account has been online between
1006 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1007 external SQL radacct table, specified via sqlradius export. Sessions which
1008 started in the specified range but are still open are counted from session
1009 start to the end of the range (unless they are over 1 day old, in which case
1010 they are presumed missing their stop record and not counted). Also, sessions
1011 which end in the range but started earlier are counted from the start of the
1012 range to session end. Finally, sessions which start before the range but end
1013 after are counted for the entire range.
1015 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1016 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1021 #note: POD here, implementation in FS::cust_svc
1022 sub seconds_since_sqlradacct {
1024 $self->cust_svc->seconds_since_sqlradacct(@_);
1027 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1029 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1030 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1031 TIMESTAMP_END (exclusive).
1033 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1034 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1039 #note: POD here, implementation in FS::cust_svc
1040 sub attribute_since_sqlradacct {
1042 $self->cust_svc->attribute_since_sqlradacct(@_);
1046 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1048 Returns an array of hash references of this customers login history for the
1049 given time range. (document this better)
1053 sub get_session_history_sqlradacct {
1055 $self->cust_svc->get_session_history_sqlradacct(@_);
1060 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1066 if ( $self->usergroup ) {
1067 #when provisioning records, export callback runs in svc_Common.pm before
1068 #radius_usergroup records can be inserted...
1069 @{$self->usergroup};
1071 map { $_->groupname }
1072 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1090 use Mail::Internet 1.44;
1093 $opt{mimetype} ||= 'text/plain';
1094 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1096 $ENV{MAILADDRESS} = $opt{from};
1097 my $header = new Mail::Header ( [
1100 "Sender: $opt{from}",
1101 "Reply-To: $opt{from}",
1102 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1103 "Subject: $opt{subject}",
1104 "Content-Type: $opt{mimetype}",
1106 my $message = new Mail::Internet (
1107 'Header' => $header,
1108 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1111 $message->smtpsend( Host => $smtpmachine )
1112 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1113 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1116 =item check_and_rebuild_fuzzyfiles
1120 sub check_and_rebuild_fuzzyfiles {
1121 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1122 -e "$dir/svc_acct.username"
1123 or &rebuild_fuzzyfiles;
1126 =item rebuild_fuzzyfiles
1130 sub rebuild_fuzzyfiles {
1132 use Fcntl qw(:flock);
1134 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1138 open(USERNAMELOCK,">>$dir/svc_acct.username")
1139 or die "can't open $dir/svc_acct.username: $!";
1140 flock(USERNAMELOCK,LOCK_EX)
1141 or die "can't lock $dir/svc_acct.username: $!";
1143 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1145 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1146 or die "can't open $dir/svc_acct.username.tmp: $!";
1147 print USERNAMECACHE join("\n", @all_username), "\n";
1148 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1150 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1160 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1161 open(USERNAMECACHE,"<$dir/svc_acct.username")
1162 or die "can't open $dir/svc_acct.username: $!";
1163 my @array = map { chomp; $_; } <USERNAMECACHE>;
1164 close USERNAMECACHE;
1168 =item append_fuzzyfiles USERNAME
1172 sub append_fuzzyfiles {
1173 my $username = shift;
1175 &check_and_rebuild_fuzzyfiles;
1177 use Fcntl qw(:flock);
1179 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1181 open(USERNAME,">>$dir/svc_acct.username")
1182 or die "can't open $dir/svc_acct.username: $!";
1183 flock(USERNAME,LOCK_EX)
1184 or die "can't lock $dir/svc_acct.username: $!";
1186 print USERNAME "$username\n";
1188 flock(USERNAME,LOCK_UN)
1189 or die "can't unlock $dir/svc_acct.username: $!";
1197 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1201 sub radius_usergroup_selector {
1202 my $sel_groups = shift;
1203 my %sel_groups = map { $_=>1 } @$sel_groups;
1205 my $selectname = shift || 'radius_usergroup';
1208 my $sth = $dbh->prepare(
1209 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1210 ) or die $dbh->errstr;
1211 $sth->execute() or die $sth->errstr;
1212 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1216 function ${selectname}_doadd(object) {
1217 var myvalue = object.${selectname}_add.value;
1218 var optionName = new Option(myvalue,myvalue,false,true);
1219 var length = object.$selectname.length;
1220 object.$selectname.options[length] = optionName;
1221 object.${selectname}_add.value = "";
1224 <SELECT MULTIPLE NAME="$selectname">
1227 foreach my $group ( @all_groups ) {
1229 if ( $sel_groups{$group} ) {
1230 $html .= ' SELECTED';
1231 $sel_groups{$group} = 0;
1233 $html .= ">$group</OPTION>\n";
1235 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1236 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1238 $html .= '</SELECT>';
1240 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1241 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1250 The $recref stuff in sub check should be cleaned up.
1252 The suspend, unsuspend and cancel methods update the database, but not the
1253 current object. This is probably a bug as it's unexpected and
1256 radius_usergroup_selector? putting web ui components in here? they should
1257 probably live somewhere else...
1261 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1262 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1263 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1264 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1265 schema.html from the base documentation.