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 unless ( $recref->{slipip} eq '0e0' ) {
807 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
808 or return "Illegal slipip". $self->slipip;
809 $recref->{slipip} = $1;
811 $recref->{slipip} = '0e0';
816 #arbitrary RADIUS stuff; allow ut_textn for now
817 foreach ( grep /^radius_/, fields('svc_acct') ) {
821 #generate a password if it is blank
822 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
823 unless ( $recref->{_password} );
825 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
826 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
827 $recref->{_password} = $1.$3;
828 #uncomment this to encrypt password immediately upon entry, or run
829 #bin/crypt_pw in cron to give new users a window during which their
830 #password is available to techs, for faxing, etc. (also be aware of
832 #$recref->{password} = $1.
833 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
835 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
836 $recref->{_password} = $1.$3;
837 } elsif ( $recref->{_password} eq '*' ) {
838 $recref->{_password} = '*';
839 } elsif ( $recref->{_password} eq '!' ) {
840 $recref->{_password} = '!';
841 } elsif ( $recref->{_password} eq '!!' ) {
842 $recref->{_password} = '!!';
844 #return "Illegal password";
845 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
846 FS::Msgcat::_gettext('illegal_password_characters').
847 ": ". $recref->{_password};
855 Depriciated, use radius_reply instead.
860 carp "FS::svc_acct::radius depriciated, use radius_reply";
866 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
867 reply attributes of this record.
869 Note that this is now the preferred method for reading RADIUS attributes -
870 accessing the columns directly is discouraged, as the column names are
871 expected to change in the future.
880 my($column, $attrib) = ($1, $2);
881 #$attrib =~ s/_/\-/g;
882 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
883 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
884 if ( $self->slipip && $self->slipip ne '0e0' ) {
885 $reply{$radius_ip} = $self->slipip;
892 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
893 check attributes of this record.
895 Note that this is now the preferred method for reading RADIUS attributes -
896 accessing the columns directly is discouraged, as the column names are
897 expected to change in the future.
903 my $password = $self->_password;
904 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
905 ( $pw_attrib => $self->_password,
908 my($column, $attrib) = ($1, $2);
909 #$attrib =~ s/_/\-/g;
910 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
911 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
917 Returns the domain associated with this account.
923 if ( $self->domsvc ) {
924 #$self->svc_domain->domain;
925 my $svc_domain = $self->svc_domain
926 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
929 $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
935 Returns the FS::svc_domain record for this account's domain (see
944 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
949 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
955 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
960 Returns an email address associated with the account.
966 $self->username. '@'. $self->domain;
971 Returns an array of FS::acct_snarf records associated with the account.
972 If the acct_snarf table does not exist or there are no associated records,
973 an empty list is returned
979 return () unless dbdef->table('acct_snarf');
980 eval "use FS::acct_snarf;";
982 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
985 =item seconds_since TIMESTAMP
987 Returns the number of seconds this account has been online since TIMESTAMP,
988 according to the session monitor (see L<FS::Session>).
990 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
991 L<Time::Local> and L<Date::Parse> for conversion functions.
995 #note: POD here, implementation in FS::cust_svc
998 $self->cust_svc->seconds_since(@_);
1001 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1003 Returns the numbers of seconds this account has been online between
1004 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1005 external SQL radacct table, specified via sqlradius export. Sessions which
1006 started in the specified range but are still open are counted from session
1007 start to the end of the range (unless they are over 1 day old, in which case
1008 they are presumed missing their stop record and not counted). Also, sessions
1009 which end in the range but started earlier are counted from the start of the
1010 range to session end. Finally, sessions which start before the range but end
1011 after are counted for the entire range.
1013 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1014 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1019 #note: POD here, implementation in FS::cust_svc
1020 sub seconds_since_sqlradacct {
1022 $self->cust_svc->seconds_since_sqlradacct(@_);
1025 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1027 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1028 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1029 TIMESTAMP_END (exclusive).
1031 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1032 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1037 #note: POD here, implementation in FS::cust_svc
1038 sub attribute_since_sqlradacct {
1040 $self->cust_svc->attribute_since_sqlradacct(@_);
1044 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1046 Returns an array of hash references of this customers login history for the
1047 given time range. (document this better)
1051 sub get_session_history_sqlradacct {
1053 $self->cust_svc->get_session_history_sqlradacct(@_);
1058 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1064 if ( $self->usergroup ) {
1065 #when provisioning records, export callback runs in svc_Common.pm before
1066 #radius_usergroup records can be inserted...
1067 @{$self->usergroup};
1069 map { $_->groupname }
1070 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1088 use Mail::Internet 1.44;
1091 $opt{mimetype} ||= 'text/plain';
1092 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1094 $ENV{MAILADDRESS} = $opt{from};
1095 my $header = new Mail::Header ( [
1098 "Sender: $opt{from}",
1099 "Reply-To: $opt{from}",
1100 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1101 "Subject: $opt{subject}",
1102 "Content-Type: $opt{mimetype}",
1104 my $message = new Mail::Internet (
1105 'Header' => $header,
1106 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1109 $message->smtpsend( Host => $smtpmachine )
1110 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1111 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1114 =item check_and_rebuild_fuzzyfiles
1118 sub check_and_rebuild_fuzzyfiles {
1119 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1120 -e "$dir/svc_acct.username"
1121 or &rebuild_fuzzyfiles;
1124 =item rebuild_fuzzyfiles
1128 sub rebuild_fuzzyfiles {
1130 use Fcntl qw(:flock);
1132 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1136 open(USERNAMELOCK,">>$dir/svc_acct.username")
1137 or die "can't open $dir/svc_acct.username: $!";
1138 flock(USERNAMELOCK,LOCK_EX)
1139 or die "can't lock $dir/svc_acct.username: $!";
1141 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1143 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1144 or die "can't open $dir/svc_acct.username.tmp: $!";
1145 print USERNAMECACHE join("\n", @all_username), "\n";
1146 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1148 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1158 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1159 open(USERNAMECACHE,"<$dir/svc_acct.username")
1160 or die "can't open $dir/svc_acct.username: $!";
1161 my @array = map { chomp; $_; } <USERNAMECACHE>;
1162 close USERNAMECACHE;
1166 =item append_fuzzyfiles USERNAME
1170 sub append_fuzzyfiles {
1171 my $username = shift;
1173 &check_and_rebuild_fuzzyfiles;
1175 use Fcntl qw(:flock);
1177 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1179 open(USERNAME,">>$dir/svc_acct.username")
1180 or die "can't open $dir/svc_acct.username: $!";
1181 flock(USERNAME,LOCK_EX)
1182 or die "can't lock $dir/svc_acct.username: $!";
1184 print USERNAME "$username\n";
1186 flock(USERNAME,LOCK_UN)
1187 or die "can't unlock $dir/svc_acct.username: $!";
1195 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1199 sub radius_usergroup_selector {
1200 my $sel_groups = shift;
1201 my %sel_groups = map { $_=>1 } @$sel_groups;
1203 my $selectname = shift || 'radius_usergroup';
1206 my $sth = $dbh->prepare(
1207 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1208 ) or die $dbh->errstr;
1209 $sth->execute() or die $sth->errstr;
1210 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1214 function ${selectname}_doadd(object) {
1215 var myvalue = object.${selectname}_add.value;
1216 var optionName = new Option(myvalue,myvalue,false,true);
1217 var length = object.$selectname.length;
1218 object.$selectname.options[length] = optionName;
1219 object.${selectname}_add.value = "";
1222 <SELECT MULTIPLE NAME="$selectname">
1225 foreach my $group ( @all_groups ) {
1227 if ( $sel_groups{$group} ) {
1228 $html .= ' SELECTED';
1229 $sel_groups{$group} = 0;
1231 $html .= ">$group</OPTION>\n";
1233 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1234 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1236 $html .= '</SELECT>';
1238 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1239 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1248 The $recref stuff in sub check should be cleaned up.
1250 The suspend, unsuspend and cancel methods update the database, but not the
1251 current object. This is probably a bug as it's unexpected and
1254 radius_usergroup_selector? putting web ui components in here? they should
1255 probably live somewhere else...
1259 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1260 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1261 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1262 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1263 schema.html from the base documentation.