4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
9 $username_uppercase $username_percent
10 $password_noampersand $password_noexclamation
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
12 $warning_template $warning_from $warning_subject $warning_mimetype
15 $radius_password $radius_ip
21 use Crypt::PasswdMD5 1.2;
23 use FS::UID qw( datasrc );
25 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
26 use FS::Msgcat qw(gettext);
31 use FS::cust_main_invoice;
35 use FS::radius_usergroup;
42 @ISA = qw( FS::svc_Common );
45 $me = '[FS::svc_acct]';
47 #ask FS::UID to run this stuff for us later
48 $FS::UID::callback{'FS::svc_acct'} = sub {
50 $dir_prefix = $conf->config('home');
51 @shells = $conf->config('shells');
52 $usernamemin = $conf->config('usernamemin') || 2;
53 $usernamemax = $conf->config('usernamemax');
54 $passwordmin = $conf->config('passwordmin') || 6;
55 $passwordmax = $conf->config('passwordmax') || 8;
56 $username_letter = $conf->exists('username-letter');
57 $username_letterfirst = $conf->exists('username-letterfirst');
58 $username_noperiod = $conf->exists('username-noperiod');
59 $username_nounderscore = $conf->exists('username-nounderscore');
60 $username_nodash = $conf->exists('username-nodash');
61 $username_uppercase = $conf->exists('username-uppercase');
62 $username_ampersand = $conf->exists('username-ampersand');
63 $username_percent = $conf->exists('username-percent');
64 $password_noampersand = $conf->exists('password-noexclamation');
65 $password_noexclamation = $conf->exists('password-noexclamation');
66 $dirhash = $conf->config('dirhash') || 0;
67 if ( $conf->exists('welcome_email') ) {
68 $welcome_template = new Text::Template (
70 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
71 ) or warn "can't create welcome email template: $Text::Template::ERROR";
72 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
73 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
74 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
76 $welcome_template = '';
78 $welcome_subject = '';
79 $welcome_mimetype = '';
81 if ( $conf->exists('warning_email') ) {
82 $warning_template = new Text::Template (
84 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
85 ) or warn "can't create warning email template: $Text::Template::ERROR";
86 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
87 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
88 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
89 $warning_cc = $conf->config('warning_email-cc');
91 $warning_template = '';
93 $warning_subject = '';
94 $warning_mimetype = '';
97 $smtpmachine = $conf->config('smtpmachine');
98 $radius_password = $conf->config('radius-password') || 'Password';
99 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
102 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
103 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
107 my ( $hashref, $cache ) = @_;
108 if ( $hashref->{'svc_acct_svcnum'} ) {
109 $self->{'_domsvc'} = FS::svc_domain->new( {
110 'svcnum' => $hashref->{'domsvc'},
111 'domain' => $hashref->{'svc_acct_domain'},
112 'catchall' => $hashref->{'svc_acct_catchall'},
119 FS::svc_acct - Object methods for svc_acct records
125 $record = new FS::svc_acct \%hash;
126 $record = new FS::svc_acct { 'column' => 'value' };
128 $error = $record->insert;
130 $error = $new_record->replace($old_record);
132 $error = $record->delete;
134 $error = $record->check;
136 $error = $record->suspend;
138 $error = $record->unsuspend;
140 $error = $record->cancel;
142 %hash = $record->radius;
144 %hash = $record->radius_reply;
146 %hash = $record->radius_check;
148 $domain = $record->domain;
150 $svc_domain = $record->svc_domain;
152 $email = $record->email;
154 $seconds_since = $record->seconds_since($timestamp);
158 An FS::svc_acct object represents an account. FS::svc_acct inherits from
159 FS::svc_Common. The following fields are currently supported:
163 =item svcnum - primary key (assigned automatcially for new accounts)
167 =item _password - generated if blank
169 =item sec_phrase - security phrase
171 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
179 =item dir - set automatically if blank (and uid is not)
183 =item quota - (unimplementd)
185 =item slipip - IP address
195 =item domsvc - svcnum from svc_domain
197 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
199 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
209 Creates a new account. To add the account to the database, see L<"insert">.
213 sub table { 'svc_acct'; }
217 #false laziness with edit/svc_acct.cgi
219 my( $self, $groups ) = @_;
220 if ( ref($groups) eq 'ARRAY' ) {
222 } elsif ( length($groups) ) {
223 [ split(/\s*,\s*/, $groups) ];
231 =item insert [ , OPTION => VALUE ... ]
233 Adds this account to the database. If there is an error, returns the error,
234 otherwise returns false.
236 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
237 defined. An FS::cust_svc record will be created and inserted.
239 The additional field I<usergroup> can optionally be defined; if so it should
240 contain an arrayref of group names. See L<FS::radius_usergroup>.
242 The additional field I<child_objects> can optionally be defined; if so it
243 should contain an arrayref of FS::tablename objects. They will have their
244 svcnum fields set and will be inserted after this record, but before any
245 exports are run. Each element of the array can also optionally be a
246 two-element array reference containing the child object and the name of an
247 alternate field to be filled in with the newly-inserted svcnum, for example
248 C<[ $svc_forward, 'srcsvc' ]>
250 Currently available options are: I<depend_jobnum>
252 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
253 jobnums), all provisioning jobs will have a dependancy on the supplied
254 jobnum(s) (they will not run until the specific job(s) complete(s)).
256 (TODOC: L<FS::queue> and L<freeside-queued>)
258 (TODOC: new exports!)
267 warn "[$me] insert called on $self: ". Dumper($self).
268 "\nwith options: ". Dumper(%options);
271 local $SIG{HUP} = 'IGNORE';
272 local $SIG{INT} = 'IGNORE';
273 local $SIG{QUIT} = 'IGNORE';
274 local $SIG{TERM} = 'IGNORE';
275 local $SIG{TSTP} = 'IGNORE';
276 local $SIG{PIPE} = 'IGNORE';
278 my $oldAutoCommit = $FS::UID::AutoCommit;
279 local $FS::UID::AutoCommit = 0;
282 my $error = $self->check;
283 return $error if $error;
285 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
286 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
287 unless ( $cust_svc ) {
288 $dbh->rollback if $oldAutoCommit;
289 return "no cust_svc record found for svcnum ". $self->svcnum;
291 $self->pkgnum($cust_svc->pkgnum);
292 $self->svcpart($cust_svc->svcpart);
295 $error = $self->_check_duplicate;
297 $dbh->rollback if $oldAutoCommit;
302 $error = $self->SUPER::insert(
303 'jobnums' => \@jobnums,
304 'child_objects' => $self->child_objects,
308 $dbh->rollback if $oldAutoCommit;
312 if ( $self->usergroup ) {
313 foreach my $groupname ( @{$self->usergroup} ) {
314 my $radius_usergroup = new FS::radius_usergroup ( {
315 svcnum => $self->svcnum,
316 groupname => $groupname,
318 my $error = $radius_usergroup->insert;
320 $dbh->rollback if $oldAutoCommit;
326 unless ( $skip_fuzzyfiles ) {
327 $error = $self->queue_fuzzyfiles_update;
329 $dbh->rollback if $oldAutoCommit;
330 return "updating fuzzy search cache: $error";
334 my $cust_pkg = $self->cust_svc->cust_pkg;
337 my $cust_main = $cust_pkg->cust_main;
339 if ( $conf->exists('emailinvoiceauto') ) {
340 my @invoicing_list = $cust_main->invoicing_list;
341 push @invoicing_list, $self->email;
342 $cust_main->invoicing_list(\@invoicing_list);
347 if ( $welcome_template && $cust_pkg ) {
348 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
350 my $wqueue = new FS::queue {
351 'svcnum' => $self->svcnum,
352 'job' => 'FS::svc_acct::send_email'
354 my $error = $wqueue->insert(
356 'from' => $welcome_from,
357 'subject' => $welcome_subject,
358 'mimetype' => $welcome_mimetype,
359 'body' => $welcome_template->fill_in( HASH => {
360 'custnum' => $self->custnum,
361 'username' => $self->username,
362 'password' => $self->_password,
363 'first' => $cust_main->first,
364 'last' => $cust_main->getfield('last'),
365 'pkg' => $cust_pkg->part_pkg->pkg,
369 $dbh->rollback if $oldAutoCommit;
370 return "error queuing welcome email: $error";
373 if ( $options{'depend_jobnum'} ) {
374 warn "$me depend_jobnum found; adding to welcome email dependancies"
376 if ( ref($options{'depend_jobnum'}) ) {
377 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
378 "to welcome email dependancies"
380 push @jobnums, @{ $options{'depend_jobnum'} };
382 warn "$me adding job $options{'depend_jobnum'} ".
383 "to welcome email dependancies"
385 push @jobnums, $options{'depend_jobnum'};
389 foreach my $jobnum ( @jobnums ) {
390 my $error = $wqueue->depend_insert($jobnum);
392 $dbh->rollback if $oldAutoCommit;
393 return "error queuing welcome email job dependancy: $error";
403 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
409 Deletes this account from the database. If there is an error, returns the
410 error, otherwise returns false.
412 The corresponding FS::cust_svc record will be deleted as well.
414 (TODOC: new exports!)
421 return "can't delete system account" if $self->_check_system;
423 return "Can't delete an account which is a (svc_forward) source!"
424 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
426 return "Can't delete an account which is a (svc_forward) destination!"
427 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
429 return "Can't delete an account with (svc_www) web service!"
430 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
432 # what about records in session ? (they should refer to history table)
434 local $SIG{HUP} = 'IGNORE';
435 local $SIG{INT} = 'IGNORE';
436 local $SIG{QUIT} = 'IGNORE';
437 local $SIG{TERM} = 'IGNORE';
438 local $SIG{TSTP} = 'IGNORE';
439 local $SIG{PIPE} = 'IGNORE';
441 my $oldAutoCommit = $FS::UID::AutoCommit;
442 local $FS::UID::AutoCommit = 0;
445 foreach my $cust_main_invoice (
446 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
448 unless ( defined($cust_main_invoice) ) {
449 warn "WARNING: something's wrong with qsearch";
452 my %hash = $cust_main_invoice->hash;
453 $hash{'dest'} = $self->email;
454 my $new = new FS::cust_main_invoice \%hash;
455 my $error = $new->replace($cust_main_invoice);
457 $dbh->rollback if $oldAutoCommit;
462 foreach my $svc_domain (
463 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
465 my %hash = new FS::svc_domain->hash;
466 $hash{'catchall'} = '';
467 my $new = new FS::svc_domain \%hash;
468 my $error = $new->replace($svc_domain);
470 $dbh->rollback if $oldAutoCommit;
475 foreach my $radius_usergroup (
476 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
478 my $error = $radius_usergroup->delete;
480 $dbh->rollback if $oldAutoCommit;
485 my $error = $self->SUPER::delete;
487 $dbh->rollback if $oldAutoCommit;
491 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
495 =item replace OLD_RECORD
497 Replaces OLD_RECORD with this one in the database. If there is an error,
498 returns the error, otherwise returns false.
500 The additional field I<usergroup> can optionally be defined; if so it should
501 contain an arrayref of group names. See L<FS::radius_usergroup>.
507 my ( $new, $old ) = ( shift, shift );
509 warn "$me replacing $old with $new\n" if $DEBUG;
511 # We absolutely have to have an old vs. new record to make this work.
512 if (!defined($old)) {
513 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
516 return "can't modify system account" if $old->_check_system;
519 #no warnings 'numeric'; #alas, a 5.006-ism
522 foreach my $xid (qw( uid gid )) {
524 return "Can't change $xid!"
525 if ! $conf->exists("svc_acct-edit_$xid")
526 && $old->$xid() != $new->$xid()
527 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
532 #change homdir when we change username
533 $new->setfield('dir', '') if $old->username ne $new->username;
535 local $SIG{HUP} = 'IGNORE';
536 local $SIG{INT} = 'IGNORE';
537 local $SIG{QUIT} = 'IGNORE';
538 local $SIG{TERM} = 'IGNORE';
539 local $SIG{TSTP} = 'IGNORE';
540 local $SIG{PIPE} = 'IGNORE';
542 my $oldAutoCommit = $FS::UID::AutoCommit;
543 local $FS::UID::AutoCommit = 0;
546 # redundant, but so $new->usergroup gets set
547 $error = $new->check;
548 return $error if $error;
550 $old->usergroup( [ $old->radius_groups ] );
552 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
553 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
555 if ( $new->usergroup ) {
556 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
557 my @newgroups = @{$new->usergroup};
558 foreach my $oldgroup ( @{$old->usergroup} ) {
559 if ( grep { $oldgroup eq $_ } @newgroups ) {
560 @newgroups = grep { $oldgroup ne $_ } @newgroups;
563 my $radius_usergroup = qsearchs('radius_usergroup', {
564 svcnum => $old->svcnum,
565 groupname => $oldgroup,
567 my $error = $radius_usergroup->delete;
569 $dbh->rollback if $oldAutoCommit;
570 return "error deleting radius_usergroup $oldgroup: $error";
574 foreach my $newgroup ( @newgroups ) {
575 my $radius_usergroup = new FS::radius_usergroup ( {
576 svcnum => $new->svcnum,
577 groupname => $newgroup,
579 my $error = $radius_usergroup->insert;
581 $dbh->rollback if $oldAutoCommit;
582 return "error adding radius_usergroup $newgroup: $error";
588 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
589 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
590 $error = $new->_check_duplicate;
592 $dbh->rollback if $oldAutoCommit;
597 $error = $new->SUPER::replace($old);
599 $dbh->rollback if $oldAutoCommit;
600 return $error if $error;
603 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
604 $error = $new->queue_fuzzyfiles_update;
606 $dbh->rollback if $oldAutoCommit;
607 return "updating fuzzy search cache: $error";
611 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
615 =item queue_fuzzyfiles_update
617 Used by insert & replace to update the fuzzy search cache
621 sub queue_fuzzyfiles_update {
624 local $SIG{HUP} = 'IGNORE';
625 local $SIG{INT} = 'IGNORE';
626 local $SIG{QUIT} = 'IGNORE';
627 local $SIG{TERM} = 'IGNORE';
628 local $SIG{TSTP} = 'IGNORE';
629 local $SIG{PIPE} = 'IGNORE';
631 my $oldAutoCommit = $FS::UID::AutoCommit;
632 local $FS::UID::AutoCommit = 0;
635 my $queue = new FS::queue {
636 'svcnum' => $self->svcnum,
637 'job' => 'FS::svc_acct::append_fuzzyfiles'
639 my $error = $queue->insert($self->username);
641 $dbh->rollback if $oldAutoCommit;
642 return "queueing job (transaction rolled back): $error";
645 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
653 Suspends this account by calling export-specific suspend hooks. If there is
654 an error, returns the error, otherwise returns false.
656 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
662 return "can't suspend system account" if $self->_check_system;
663 $self->SUPER::suspend;
668 Unsuspends this account by by calling export-specific suspend hooks. If there
669 is an error, returns the error, otherwise returns false.
671 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
677 my %hash = $self->hash;
678 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
679 $hash{_password} = $1;
680 my $new = new FS::svc_acct ( \%hash );
681 my $error = $new->replace($self);
682 return $error if $error;
685 $self->SUPER::unsuspend;
690 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
692 If the B<auto_unset_catchall> configuration option is set, this method will
693 automatically remove any references to the canceled service in the catchall
694 field of svc_domain. This allows packages that contain both a svc_domain and
695 its catchall svc_acct to be canceled in one step.
700 # Only one thing to do at this level
702 foreach my $svc_domain (
703 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
704 if($conf->exists('auto_unset_catchall')) {
705 my %hash = $svc_domain->hash;
706 $hash{catchall} = '';
707 my $new = new FS::svc_domain ( \%hash );
708 my $error = $new->replace($svc_domain);
709 return $error if $error;
711 return "cannot unprovision svc_acct #".$self->svcnum.
712 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
716 $self->SUPER::cancel;
722 Checks all fields to make sure this is a valid service. If there is an error,
723 returns the error, otherwise returns false. Called by the insert and replace
726 Sets any fixed values; see L<FS::part_svc>.
733 my($recref) = $self->hashref;
735 my $x = $self->setfixed( $self->_fieldhandlers );
736 return $x unless ref($x);
739 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
741 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
744 my $error = $self->ut_numbern('svcnum')
745 #|| $self->ut_number('domsvc')
746 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
747 || $self->ut_textn('sec_phrase')
748 || $self->ut_snumbern('seconds')
749 || $self->ut_snumbern('upbytes')
750 || $self->ut_snumbern('downbytes')
751 || $self->ut_snumbern('totalbytes')
753 return $error if $error;
755 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
756 if ( $username_uppercase ) {
757 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
758 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
759 $recref->{username} = $1;
761 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
762 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
763 $recref->{username} = $1;
766 if ( $username_letterfirst ) {
767 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
768 } elsif ( $username_letter ) {
769 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
771 if ( $username_noperiod ) {
772 $recref->{username} =~ /\./ and return gettext('illegal_username');
774 if ( $username_nounderscore ) {
775 $recref->{username} =~ /_/ and return gettext('illegal_username');
777 if ( $username_nodash ) {
778 $recref->{username} =~ /\-/ and return gettext('illegal_username');
780 unless ( $username_ampersand ) {
781 $recref->{username} =~ /\&/ and return gettext('illegal_username');
783 if ( $password_noampersand ) {
784 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
786 if ( $password_noexclamation ) {
787 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
789 unless ( $username_percent ) {
790 $recref->{username} =~ /\%/ and return gettext('illegal_username');
793 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
794 $recref->{popnum} = $1;
795 return "Unknown popnum" unless
796 ! $recref->{popnum} ||
797 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
799 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
801 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
802 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
804 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
805 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
806 #not all systems use gid=uid
807 #you can set a fixed gid in part_svc
809 return "Only root can have uid 0"
810 if $recref->{uid} == 0
811 && $recref->{username} !~ /^(root|toor|smtp)$/;
813 unless ( $recref->{username} eq 'sync' ) {
814 if ( grep $_ eq $recref->{shell}, @shells ) {
815 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
817 return "Illegal shell \`". $self->shell. "\'; ".
818 $conf->dir. "/shells contains: @shells";
821 $recref->{shell} = '/bin/sync';
825 $recref->{gid} ne '' ?
826 return "Can't have gid without uid" : ( $recref->{gid}='' );
827 #$recref->{dir} ne '' ?
828 # return "Can't have directory without uid" : ( $recref->{dir}='' );
829 $recref->{shell} ne '' ?
830 return "Can't have shell without uid" : ( $recref->{shell}='' );
833 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
835 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
836 or return "Illegal directory: ". $recref->{dir};
838 return "Illegal directory"
839 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
840 return "Illegal directory"
841 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
842 unless ( $recref->{dir} ) {
843 $recref->{dir} = $dir_prefix . '/';
844 if ( $dirhash > 0 ) {
845 for my $h ( 1 .. $dirhash ) {
846 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
848 } elsif ( $dirhash < 0 ) {
849 for my $h ( reverse $dirhash .. -1 ) {
850 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
853 $recref->{dir} .= $recref->{username};
859 # $error = $self->ut_textn('finger');
860 # return $error if $error;
861 if ( $self->getfield('finger') eq '' ) {
862 my $cust_pkg = $self->svcnum
863 ? $self->cust_svc->cust_pkg
864 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
866 my $cust_main = $cust_pkg->cust_main;
867 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
870 $self->getfield('finger') =~
871 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
872 or return "Illegal finger: ". $self->getfield('finger');
873 $self->setfield('finger', $1);
875 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
876 $recref->{quota} = $1;
878 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
879 if ( $recref->{slipip} eq '' ) {
880 $recref->{slipip} = '';
881 } elsif ( $recref->{slipip} eq '0e0' ) {
882 $recref->{slipip} = '0e0';
884 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
885 or return "Illegal slipip: ". $self->slipip;
886 $recref->{slipip} = $1;
891 #arbitrary RADIUS stuff; allow ut_textn for now
892 foreach ( grep /^radius_/, fields('svc_acct') ) {
896 #generate a password if it is blank
897 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
898 unless ( $recref->{_password} );
900 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
901 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
902 $recref->{_password} = $1.$3;
903 #uncomment this to encrypt password immediately upon entry, or run
904 #bin/crypt_pw in cron to give new users a window during which their
905 #password is available to techs, for faxing, etc. (also be aware of
907 #$recref->{password} = $1.
908 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
910 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
911 $recref->{_password} = $1.$3;
912 } elsif ( $recref->{_password} eq '*' ) {
913 $recref->{_password} = '*';
914 } elsif ( $recref->{_password} eq '!' ) {
915 $recref->{_password} = '!';
916 } elsif ( $recref->{_password} eq '!!' ) {
917 $recref->{_password} = '!!';
919 #return "Illegal password";
920 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
921 FS::Msgcat::_gettext('illegal_password_characters').
922 ": ". $recref->{_password};
930 Internal function to check the username against the list of system usernames
931 from the I<system_usernames> configuration value. Returns true if the username
932 is listed on the system username list.
938 scalar( grep { $self->username eq $_ || $self->email eq $_ }
939 $conf->config('system_usernames')
943 =item _check_duplicate
945 Internal function to check for duplicates usernames, username@domain pairs and
948 If the I<global_unique-username> configuration value is set to B<username> or
949 B<username@domain>, enforces global username or username@domain uniqueness.
951 In all cases, check for duplicate uids and usernames or username@domain pairs
952 per export and with identical I<svcpart> values.
956 sub _check_duplicate {
959 my $global_unique = $conf->config('global_unique-username') || 'none';
960 return '' if $global_unique eq 'disabled';
962 #this is Pg-specific. what to do for mysql etc?
963 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
964 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
965 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
967 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
969 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
970 unless ( $part_svc ) {
971 return 'unknown svcpart '. $self->svcpart;
974 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
975 qsearch( 'svc_acct', { 'username' => $self->username } );
976 return gettext('username_in_use')
977 if $global_unique eq 'username' && @dup_user;
979 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
980 qsearch( 'svc_acct', { 'username' => $self->username,
981 'domsvc' => $self->domsvc } );
982 return gettext('username_in_use')
983 if $global_unique eq 'username@domain' && @dup_userdomain;
986 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
987 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
988 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
989 qsearch( 'svc_acct', { 'uid' => $self->uid } );
994 if ( @dup_user || @dup_userdomain || @dup_uid ) {
995 my $exports = FS::part_export::export_info('svc_acct');
996 my %conflict_user_svcpart;
997 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
999 foreach my $part_export ( $part_svc->part_export ) {
1001 #this will catch to the same exact export
1002 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1004 #this will catch to exports w/same exporthost+type ???
1005 #my @other_part_export = qsearch('part_export', {
1006 # 'machine' => $part_export->machine,
1007 # 'exporttype' => $part_export->exporttype,
1009 #foreach my $other_part_export ( @other_part_export ) {
1010 # push @svcparts, map { $_->svcpart }
1011 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1014 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1015 #silly kludge to avoid uninitialized value errors
1016 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1017 ? $exports->{$part_export->exporttype}{'nodomain'}
1019 if ( $nodomain =~ /^Y/i ) {
1020 $conflict_user_svcpart{$_} = $part_export->exportnum
1023 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1028 foreach my $dup_user ( @dup_user ) {
1029 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1030 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1031 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1032 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1036 foreach my $dup_userdomain ( @dup_userdomain ) {
1037 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1038 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1039 return "duplicate username\@domain: conflicts with svcnum ".
1040 $dup_userdomain->svcnum. " via exportnum ".
1041 $conflict_userdomain_svcpart{$dup_svcpart};
1045 foreach my $dup_uid ( @dup_uid ) {
1046 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1047 if ( exists($conflict_user_svcpart{$dup_svcpart})
1048 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1049 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1050 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1051 || $conflict_userdomain_svcpart{$dup_svcpart};
1063 Depriciated, use radius_reply instead.
1068 carp "FS::svc_acct::radius depriciated, use radius_reply";
1069 $_[0]->radius_reply;
1074 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1075 reply attributes of this record.
1077 Note that this is now the preferred method for reading RADIUS attributes -
1078 accessing the columns directly is discouraged, as the column names are
1079 expected to change in the future.
1086 return %{ $self->{'radius_reply'} }
1087 if exists $self->{'radius_reply'};
1092 my($column, $attrib) = ($1, $2);
1093 #$attrib =~ s/_/\-/g;
1094 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1095 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1097 if ( $self->slipip && $self->slipip ne '0e0' ) {
1098 $reply{$radius_ip} = $self->slipip;
1101 if ( $self->seconds !~ /^$/ ) {
1102 $reply{'Session-Timeout'} = $self->seconds;
1110 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1111 check attributes of this record.
1113 Note that this is now the preferred method for reading RADIUS attributes -
1114 accessing the columns directly is discouraged, as the column names are
1115 expected to change in the future.
1122 return %{ $self->{'radius_check'} }
1123 if exists $self->{'radius_check'};
1128 my($column, $attrib) = ($1, $2);
1129 #$attrib =~ s/_/\-/g;
1130 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1131 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1133 my $password = $self->_password;
1134 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1136 my $cust_svc = $self->cust_svc;
1137 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1139 my $cust_pkg = $cust_svc->cust_pkg;
1140 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1141 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1150 This method instructs the object to "snapshot" or freeze RADIUS check and
1151 reply attributes to the current values.
1155 #bah, my english is too broken this morning
1156 #Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill. (This is used by
1157 #the FS::cust_pkg's replace method to trigger the correct export updates when
1158 #package dates change)
1163 $self->{$_} = { $self->$_() }
1164 foreach qw( radius_reply radius_check );
1168 =item forget_snapshot
1170 This methos instructs the object to forget any previously snapshotted
1171 RADIUS check and reply attributes.
1175 sub forget_snapshot {
1179 foreach qw( radius_reply radius_check );
1185 Returns the domain associated with this account.
1191 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1192 my $svc_domain = $self->svc_domain(@_)
1193 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1194 $svc_domain->domain;
1199 Returns the FS::svc_domain record for this account's domain (see
1207 ? $self->{'_domsvc'}
1208 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1213 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1217 #inherited from svc_Common
1221 Returns an email address associated with the account.
1227 $self->username. '@'. $self->domain(@_);
1232 Returns an array of FS::acct_snarf records associated with the account.
1233 If the acct_snarf table does not exist or there are no associated records,
1234 an empty list is returned
1240 return () unless dbdef->table('acct_snarf');
1241 eval "use FS::acct_snarf;";
1243 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1246 =item decrement_upbytes OCTETS
1248 Decrements the I<upbytes> field of this record by the given amount. If there
1249 is an error, returns the error, otherwise returns false.
1253 sub decrement_upbytes {
1254 shift->_op_usage('-', 'upbytes', @_);
1257 =item increment_upbytes OCTETS
1259 Increments the I<upbytes> field of this record by the given amount. If there
1260 is an error, returns the error, otherwise returns false.
1264 sub increment_upbytes {
1265 shift->_op_usage('+', 'upbytes', @_);
1268 =item decrement_downbytes OCTETS
1270 Decrements the I<downbytes> field of this record by the given amount. If there
1271 is an error, returns the error, otherwise returns false.
1275 sub decrement_downbytes {
1276 shift->_op_usage('-', 'downbytes', @_);
1279 =item increment_downbytes OCTETS
1281 Increments the I<downbytes> field of this record by the given amount. If there
1282 is an error, returns the error, otherwise returns false.
1286 sub increment_downbytes {
1287 shift->_op_usage('+', 'downbytes', @_);
1290 =item decrement_totalbytes OCTETS
1292 Decrements the I<totalbytes> field of this record by the given amount. If there
1293 is an error, returns the error, otherwise returns false.
1297 sub decrement_totalbytes {
1298 shift->_op_usage('-', 'totalbytes', @_);
1301 =item increment_totalbytes OCTETS
1303 Increments the I<totalbytes> field of this record by the given amount. If there
1304 is an error, returns the error, otherwise returns false.
1308 sub increment_totalbytes {
1309 shift->_op_usage('+', 'totalbytes', @_);
1312 =item decrement_seconds SECONDS
1314 Decrements the I<seconds> field of this record by the given amount. If there
1315 is an error, returns the error, otherwise returns false.
1319 sub decrement_seconds {
1320 shift->_op_usage('-', 'seconds', @_);
1323 =item increment_seconds SECONDS
1325 Increments the I<seconds> field of this record by the given amount. If there
1326 is an error, returns the error, otherwise returns false.
1330 sub increment_seconds {
1331 shift->_op_usage('+', 'seconds', @_);
1339 my %op2condition = (
1340 '-' => sub { my($self, $column, $amount) = @_;
1341 $self->$column - $amount <= 0;
1343 '+' => sub { my($self, $column, $amount) = @_;
1344 $self->$column + $amount > 0;
1347 my %op2warncondition = (
1348 '-' => sub { my($self, $column, $amount) = @_;
1349 my $threshold = $column . '_threshold';
1350 $self->$column - $amount <= $self->$threshold + 0;
1352 '+' => sub { my($self, $column, $amount) = @_;
1353 $self->$column + $amount > 0;
1358 my( $self, $op, $column, $amount ) = @_;
1360 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1361 ' ('. $self->email. "): $op $amount\n"
1364 return '' unless $amount;
1366 local $SIG{HUP} = 'IGNORE';
1367 local $SIG{INT} = 'IGNORE';
1368 local $SIG{QUIT} = 'IGNORE';
1369 local $SIG{TERM} = 'IGNORE';
1370 local $SIG{TSTP} = 'IGNORE';
1371 local $SIG{PIPE} = 'IGNORE';
1373 my $oldAutoCommit = $FS::UID::AutoCommit;
1374 local $FS::UID::AutoCommit = 0;
1377 my $sql = "UPDATE svc_acct SET $column = ".
1378 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1379 " $op ? WHERE svcnum = ?";
1383 my $sth = $dbh->prepare( $sql )
1384 or die "Error preparing $sql: ". $dbh->errstr;
1385 my $rv = $sth->execute($amount, $self->svcnum);
1386 die "Error executing $sql: ". $sth->errstr
1387 unless defined($rv);
1388 die "Can't update $column for svcnum". $self->svcnum
1391 my $action = $op2action{$op};
1393 if ( $conf->exists("svc_acct-usage_$action")
1394 && &{$op2condition{$op}}($self, $column, $amount) ) {
1395 #my $error = $self->$action();
1396 my $error = $self->cust_svc->cust_pkg->$action();
1398 $dbh->rollback if $oldAutoCommit;
1399 return "Error ${action}ing: $error";
1403 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1404 my $wqueue = new FS::queue {
1405 'svcnum' => $self->svcnum,
1406 'job' => 'FS::svc_acct::reached_threshold',
1411 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1415 my $error = $wqueue->insert(
1416 'svcnum' => $self->svcnum,
1418 'column' => $column,
1422 $dbh->rollback if $oldAutoCommit;
1423 return "Error queuing threshold activity: $error";
1427 warn "$me update successful; committing\n"
1429 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1435 my( $self, $valueref ) = @_;
1437 warn "$me set_usage called for svcnum ". $self->svcnum.
1438 ' ('. $self->email. "): ".
1439 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1442 local $SIG{HUP} = 'IGNORE';
1443 local $SIG{INT} = 'IGNORE';
1444 local $SIG{QUIT} = 'IGNORE';
1445 local $SIG{TERM} = 'IGNORE';
1446 local $SIG{TSTP} = 'IGNORE';
1447 local $SIG{PIPE} = 'IGNORE';
1449 my $oldAutoCommit = $FS::UID::AutoCommit;
1450 local $FS::UID::AutoCommit = 0;
1454 foreach my $field (keys %$valueref){
1455 $reset = 1 if $valueref->{$field};
1456 $self->setfield($field, $valueref->{$field});
1457 $self->setfield( $field.'_threshold',
1458 int($self->getfield($field)
1459 * ( $conf->exists('svc_acct-usage_threshold')
1460 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1466 my $error = $self->replace;
1467 die $error if $error;
1469 if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) {
1470 my $error = $self->cust_svc->cust_pkg->unsuspend;
1472 $dbh->rollback if $oldAutoCommit;
1473 return "Error unsuspending: $error";
1477 warn "$me update successful; committing\n"
1479 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1485 =item recharge HASHREF
1487 Increments usage columns by the amount specified in HASHREF as
1488 column=>amount pairs.
1493 my ($self, $vhash) = @_;
1496 warn "[$me] recharge called on $self: ". Dumper($self).
1497 "\nwith vhash: ". Dumper($vhash);
1500 my $oldAutoCommit = $FS::UID::AutoCommit;
1501 local $FS::UID::AutoCommit = 0;
1505 foreach my $column (keys %$vhash){
1506 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1510 $dbh->rollback if $oldAutoCommit;
1512 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1517 =item is_rechargeable
1519 Returns true if this svc_account can be "recharged" and false otherwise.
1523 sub is_rechargable {
1525 $self->seconds ne ''
1526 || $self->upbytes ne ''
1527 || $self->downbytes ne ''
1528 || $self->totalbytes ne '';
1531 =item seconds_since TIMESTAMP
1533 Returns the number of seconds this account has been online since TIMESTAMP,
1534 according to the session monitor (see L<FS::Session>).
1536 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1537 L<Time::Local> and L<Date::Parse> for conversion functions.
1541 #note: POD here, implementation in FS::cust_svc
1544 $self->cust_svc->seconds_since(@_);
1547 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1549 Returns the numbers of seconds this account has been online between
1550 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1551 external SQL radacct table, specified via sqlradius export. Sessions which
1552 started in the specified range but are still open are counted from session
1553 start to the end of the range (unless they are over 1 day old, in which case
1554 they are presumed missing their stop record and not counted). Also, sessions
1555 which end in the range but started earlier are counted from the start of the
1556 range to session end. Finally, sessions which start before the range but end
1557 after are counted for the entire range.
1559 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1560 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1565 #note: POD here, implementation in FS::cust_svc
1566 sub seconds_since_sqlradacct {
1568 $self->cust_svc->seconds_since_sqlradacct(@_);
1571 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1573 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1574 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1575 TIMESTAMP_END (exclusive).
1577 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1578 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1583 #note: POD here, implementation in FS::cust_svc
1584 sub attribute_since_sqlradacct {
1586 $self->cust_svc->attribute_since_sqlradacct(@_);
1589 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1591 Returns an array of hash references of this customers login history for the
1592 given time range. (document this better)
1596 sub get_session_history {
1598 $self->cust_svc->get_session_history(@_);
1601 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1606 my($self, $start, $end, %opt ) = @_;
1608 my $did = $self->username; #yup
1610 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1612 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1614 #SELECT $for_update * FROM cdr
1615 # WHERE calldate >= $start #need a conversion
1616 # AND calldate < $end #ditto
1617 # AND ( charged_party = "$did"
1618 # OR charged_party = "$prefix$did" #if length($prefix);
1619 # OR ( ( charged_party IS NULL OR charged_party = '' )
1621 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1624 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1627 if ( length($prefix) ) {
1629 " AND ( charged_party = '$did'
1630 OR charged_party = '$prefix$did'
1631 OR ( ( charged_party IS NULL OR charged_party = '' )
1633 ( src = '$did' OR src = '$prefix$did' )
1639 " AND ( charged_party = '$did'
1640 OR ( ( charged_party IS NULL OR charged_party = '' )
1650 'select' => "$for_update *",
1653 #( freesidestatus IS NULL OR freesidestatus = '' )
1654 'freesidestatus' => '',
1656 'extra_sql' => $charged_or_src,
1664 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1670 if ( $self->usergroup ) {
1671 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1672 unless ref($self->usergroup) eq 'ARRAY';
1673 #when provisioning records, export callback runs in svc_Common.pm before
1674 #radius_usergroup records can be inserted...
1675 @{$self->usergroup};
1677 map { $_->groupname }
1678 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1682 =item clone_suspended
1684 Constructor used by FS::part_export::_export_suspend fallback. Document
1689 sub clone_suspended {
1691 my %hash = $self->hash;
1692 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1693 new FS::svc_acct \%hash;
1696 =item clone_kludge_unsuspend
1698 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1703 sub clone_kludge_unsuspend {
1705 my %hash = $self->hash;
1706 $hash{_password} = '';
1707 new FS::svc_acct \%hash;
1710 =item check_password
1712 Checks the supplied password against the (possibly encrypted) password in the
1713 database. Returns true for a successful authentication, false for no match.
1715 Currently supported encryptions are: classic DES crypt() and MD5
1719 sub check_password {
1720 my($self, $check_password) = @_;
1722 #remove old-style SUSPENDED kludge, they should be allowed to login to
1723 #self-service and pay up
1724 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1726 #eventually should check a "password-encoding" field
1727 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1729 } elsif ( length($password) < 13 ) { #plaintext
1730 $check_password eq $password;
1731 } elsif ( length($password) == 13 ) { #traditional DES crypt
1732 crypt($check_password, $password) eq $password;
1733 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1734 unix_md5_crypt($check_password, $password) eq $password;
1735 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1736 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1737 $self->svcnum. "\n";
1740 warn "Can't check password: Unrecognized encryption for svcnum ".
1741 $self->svcnum. "\n";
1747 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1749 Returns an encrypted password, either by passing through an encrypted password
1750 in the database or by encrypting a plaintext password from the database.
1752 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1753 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1754 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1755 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1756 encryption type is only used if the password is not already encrypted in the
1761 sub crypt_password {
1763 #eventually should check a "password-encoding" field
1764 if ( length($self->_password) == 13
1765 || $self->_password =~ /^\$(1|2a?)\$/
1766 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1771 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1772 if ( $encryption eq 'crypt' ) {
1775 $saltset[int(rand(64))].$saltset[int(rand(64))]
1777 } elsif ( $encryption eq 'md5' ) {
1778 unix_md5_crypt( $self->_password );
1779 } elsif ( $encryption eq 'blowfish' ) {
1780 croak "unknown encryption method $encryption";
1782 croak "unknown encryption method $encryption";
1787 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
1789 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
1790 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
1791 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
1793 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
1794 to work the same as the B</crypt_password> method.
1800 #eventually should check a "password-encoding" field
1801 if ( length($self->_password) == 13 ) { #crypt
1802 return '{CRYPT}'. $self->_password;
1803 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
1805 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
1806 die "Blowfish encryption not supported in this context, svcnum ".
1807 $self->svcnum. "\n";
1808 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
1809 return '{SSHA}'. $1;
1810 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
1811 return '{NS-MTA-MD5}'. $1;
1813 return '{PLAIN}'. $self->_password;
1814 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1815 #if ( $encryption eq 'crypt' ) {
1816 # return '{CRYPT}'. crypt(
1818 # $saltset[int(rand(64))].$saltset[int(rand(64))]
1820 #} elsif ( $encryption eq 'md5' ) {
1821 # unix_md5_crypt( $self->_password );
1822 #} elsif ( $encryption eq 'blowfish' ) {
1823 # croak "unknown encryption method $encryption";
1825 # croak "unknown encryption method $encryption";
1830 =item domain_slash_username
1832 Returns $domain/$username/
1836 sub domain_slash_username {
1838 $self->domain. '/'. $self->username. '/';
1841 =item virtual_maildir
1843 Returns $domain/maildirs/$username/
1847 sub virtual_maildir {
1849 $self->domain. '/maildirs/'. $self->username. '/';
1860 This is the FS::svc_acct job-queue-able version. It still uses
1861 FS::Misc::send_email under-the-hood.
1868 eval "use FS::Misc qw(send_email)";
1871 $opt{mimetype} ||= 'text/plain';
1872 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1874 my $error = send_email(
1875 'from' => $opt{from},
1877 'subject' => $opt{subject},
1878 'content-type' => $opt{mimetype},
1879 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1881 die $error if $error;
1884 =item check_and_rebuild_fuzzyfiles
1888 sub check_and_rebuild_fuzzyfiles {
1889 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1890 -e "$dir/svc_acct.username"
1891 or &rebuild_fuzzyfiles;
1894 =item rebuild_fuzzyfiles
1898 sub rebuild_fuzzyfiles {
1900 use Fcntl qw(:flock);
1902 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1906 open(USERNAMELOCK,">>$dir/svc_acct.username")
1907 or die "can't open $dir/svc_acct.username: $!";
1908 flock(USERNAMELOCK,LOCK_EX)
1909 or die "can't lock $dir/svc_acct.username: $!";
1911 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1913 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1914 or die "can't open $dir/svc_acct.username.tmp: $!";
1915 print USERNAMECACHE join("\n", @all_username), "\n";
1916 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1918 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1928 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1929 open(USERNAMECACHE,"<$dir/svc_acct.username")
1930 or die "can't open $dir/svc_acct.username: $!";
1931 my @array = map { chomp; $_; } <USERNAMECACHE>;
1932 close USERNAMECACHE;
1936 =item append_fuzzyfiles USERNAME
1940 sub append_fuzzyfiles {
1941 my $username = shift;
1943 &check_and_rebuild_fuzzyfiles;
1945 use Fcntl qw(:flock);
1947 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1949 open(USERNAME,">>$dir/svc_acct.username")
1950 or die "can't open $dir/svc_acct.username: $!";
1951 flock(USERNAME,LOCK_EX)
1952 or die "can't lock $dir/svc_acct.username: $!";
1954 print USERNAME "$username\n";
1956 flock(USERNAME,LOCK_UN)
1957 or die "can't unlock $dir/svc_acct.username: $!";
1965 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1969 sub radius_usergroup_selector {
1970 my $sel_groups = shift;
1971 my %sel_groups = map { $_=>1 } @$sel_groups;
1973 my $selectname = shift || 'radius_usergroup';
1976 my $sth = $dbh->prepare(
1977 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1978 ) or die $dbh->errstr;
1979 $sth->execute() or die $sth->errstr;
1980 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1984 function ${selectname}_doadd(object) {
1985 var myvalue = object.${selectname}_add.value;
1986 var optionName = new Option(myvalue,myvalue,false,true);
1987 var length = object.$selectname.length;
1988 object.$selectname.options[length] = optionName;
1989 object.${selectname}_add.value = "";
1992 <SELECT MULTIPLE NAME="$selectname">
1995 foreach my $group ( @all_groups ) {
1996 $html .= qq(<OPTION VALUE="$group");
1997 if ( $sel_groups{$group} ) {
1998 $html .= ' SELECTED';
1999 $sel_groups{$group} = 0;
2001 $html .= ">$group</OPTION>\n";
2003 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2004 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2006 $html .= '</SELECT>';
2008 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2009 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2014 =item reached_threshold
2016 Performs some activities when svc_acct thresholds (such as number of seconds
2017 remaining) are reached.
2021 sub reached_threshold {
2024 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2025 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2027 if ( $opt{'op'} eq '+' ){
2028 $svc_acct->setfield( $opt{'column'}.'_threshold',
2029 int($svc_acct->getfield($opt{'column'})
2030 * ( $conf->exists('svc_acct-usage_threshold')
2031 ? $conf->config('svc_acct-usage_threshold')/100
2036 my $error = $svc_acct->replace;
2037 die $error if $error;
2038 }elsif ( $opt{'op'} eq '-' ){
2040 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2041 return '' if ($threshold eq '' );
2043 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2044 my $error = $svc_acct->replace;
2045 die $error if $error; # email next time, i guess
2047 if ( $warning_template ) {
2048 eval "use FS::Misc qw(send_email)";
2051 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2052 my $cust_main = $cust_pkg->cust_main;
2054 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2055 $cust_main->invoicing_list,
2057 ($opt{'to'} ? $opt{'to'} : ())
2060 my $mimetype = $warning_mimetype;
2061 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2063 my $body = $warning_template->fill_in( HASH => {
2064 'custnum' => $cust_main->custnum,
2065 'username' => $svc_acct->username,
2066 'password' => $svc_acct->_password,
2067 'first' => $cust_main->first,
2068 'last' => $cust_main->getfield('last'),
2069 'pkg' => $cust_pkg->part_pkg->pkg,
2070 'column' => $opt{'column'},
2071 'amount' => $svc_acct->getfield($opt{'column'}),
2072 'threshold' => $threshold,
2076 my $error = send_email(
2077 'from' => $warning_from,
2079 'subject' => $warning_subject,
2080 'content-type' => $mimetype,
2081 'body' => [ map "$_\n", split("\n", $body) ],
2083 die $error if $error;
2086 die "unknown op: " . $opt{'op'};
2094 The $recref stuff in sub check should be cleaned up.
2096 The suspend, unsuspend and cancel methods update the database, but not the
2097 current object. This is probably a bug as it's unexpected and
2100 radius_usergroup_selector? putting web ui components in here? they should
2101 probably live somewhere else...
2103 insertion of RADIUS group stuff in insert could be done with child_objects now
2104 (would probably clean up export of them too)
2108 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2109 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2110 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2111 L<freeside-queued>), L<FS::svc_acct_pop>,
2112 schema.html from the base documentation.