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 =item is_rechargeable
1437 Returns true if this svc_account can be "rechaged" and false otherwise.
1441 sub is_rechargable {
1443 $self->seconds ne ''
1444 || $self->upbytes ne ''
1445 || $self->downbytes ne ''
1446 || $self->totalbytes ne '';
1449 =item seconds_since TIMESTAMP
1451 Returns the number of seconds this account has been online since TIMESTAMP,
1452 according to the session monitor (see L<FS::Session>).
1454 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1455 L<Time::Local> and L<Date::Parse> for conversion functions.
1459 #note: POD here, implementation in FS::cust_svc
1462 $self->cust_svc->seconds_since(@_);
1465 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1467 Returns the numbers of seconds this account has been online between
1468 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1469 external SQL radacct table, specified via sqlradius export. Sessions which
1470 started in the specified range but are still open are counted from session
1471 start to the end of the range (unless they are over 1 day old, in which case
1472 they are presumed missing their stop record and not counted). Also, sessions
1473 which end in the range but started earlier are counted from the start of the
1474 range to session end. Finally, sessions which start before the range but end
1475 after are counted for the entire range.
1477 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1478 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1483 #note: POD here, implementation in FS::cust_svc
1484 sub seconds_since_sqlradacct {
1486 $self->cust_svc->seconds_since_sqlradacct(@_);
1489 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1491 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1492 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1493 TIMESTAMP_END (exclusive).
1495 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1496 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1501 #note: POD here, implementation in FS::cust_svc
1502 sub attribute_since_sqlradacct {
1504 $self->cust_svc->attribute_since_sqlradacct(@_);
1507 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1509 Returns an array of hash references of this customers login history for the
1510 given time range. (document this better)
1514 sub get_session_history {
1516 $self->cust_svc->get_session_history(@_);
1519 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1524 my($self, $start, $end, %opt ) = @_;
1526 my $did = $self->username; #yup
1528 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1530 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1532 #SELECT $for_update * FROM cdr
1533 # WHERE calldate >= $start #need a conversion
1534 # AND calldate < $end #ditto
1535 # AND ( charged_party = "$did"
1536 # OR charged_party = "$prefix$did" #if length($prefix);
1537 # OR ( ( charged_party IS NULL OR charged_party = '' )
1539 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1542 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1545 if ( length($prefix) ) {
1547 " AND ( charged_party = '$did'
1548 OR charged_party = '$prefix$did'
1549 OR ( ( charged_party IS NULL OR charged_party = '' )
1551 ( src = '$did' OR src = '$prefix$did' )
1557 " AND ( charged_party = '$did'
1558 OR ( ( charged_party IS NULL OR charged_party = '' )
1568 'select' => "$for_update *",
1571 #( freesidestatus IS NULL OR freesidestatus = '' )
1572 'freesidestatus' => '',
1574 'extra_sql' => $charged_or_src,
1582 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1588 if ( $self->usergroup ) {
1589 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1590 unless ref($self->usergroup) eq 'ARRAY';
1591 #when provisioning records, export callback runs in svc_Common.pm before
1592 #radius_usergroup records can be inserted...
1593 @{$self->usergroup};
1595 map { $_->groupname }
1596 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1600 =item clone_suspended
1602 Constructor used by FS::part_export::_export_suspend fallback. Document
1607 sub clone_suspended {
1609 my %hash = $self->hash;
1610 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1611 new FS::svc_acct \%hash;
1614 =item clone_kludge_unsuspend
1616 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1621 sub clone_kludge_unsuspend {
1623 my %hash = $self->hash;
1624 $hash{_password} = '';
1625 new FS::svc_acct \%hash;
1628 =item check_password
1630 Checks the supplied password against the (possibly encrypted) password in the
1631 database. Returns true for a successful authentication, false for no match.
1633 Currently supported encryptions are: classic DES crypt() and MD5
1637 sub check_password {
1638 my($self, $check_password) = @_;
1640 #remove old-style SUSPENDED kludge, they should be allowed to login to
1641 #self-service and pay up
1642 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1644 #eventually should check a "password-encoding" field
1645 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1647 } elsif ( length($password) < 13 ) { #plaintext
1648 $check_password eq $password;
1649 } elsif ( length($password) == 13 ) { #traditional DES crypt
1650 crypt($check_password, $password) eq $password;
1651 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1652 unix_md5_crypt($check_password, $password) eq $password;
1653 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1654 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1655 $self->svcnum. "\n";
1658 warn "Can't check password: Unrecognized encryption for svcnum ".
1659 $self->svcnum. "\n";
1665 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1667 Returns an encrypted password, either by passing through an encrypted password
1668 in the database or by encrypting a plaintext password from the database.
1670 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1671 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1672 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1673 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1674 encryption type is only used if the password is not already encrypted in the
1679 sub crypt_password {
1681 #eventually should check a "password-encoding" field
1682 if ( length($self->_password) == 13
1683 || $self->_password =~ /^\$(1|2a?)\$/
1684 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1689 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1690 if ( $encryption eq 'crypt' ) {
1693 $saltset[int(rand(64))].$saltset[int(rand(64))]
1695 } elsif ( $encryption eq 'md5' ) {
1696 unix_md5_crypt( $self->_password );
1697 } elsif ( $encryption eq 'blowfish' ) {
1698 croak "unknown encryption method $encryption";
1700 croak "unknown encryption method $encryption";
1705 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
1707 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
1708 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
1709 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
1711 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
1712 to work the same as the B</crypt_password> method.
1718 #eventually should check a "password-encoding" field
1719 if ( length($self->_password) == 13 ) { #crypt
1720 return '{CRYPT}'. $self->_password;
1721 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
1723 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
1724 die "Blowfish encryption not supported in this context, svcnum ".
1725 $self->svcnum. "\n";
1726 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
1727 return '{SSHA}'. $1;
1728 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
1729 return '{NS-MTA-MD5}'. $1;
1731 return '{PLAIN}'. $self->_password;
1732 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1733 #if ( $encryption eq 'crypt' ) {
1734 # return '{CRYPT}'. crypt(
1736 # $saltset[int(rand(64))].$saltset[int(rand(64))]
1738 #} elsif ( $encryption eq 'md5' ) {
1739 # unix_md5_crypt( $self->_password );
1740 #} elsif ( $encryption eq 'blowfish' ) {
1741 # croak "unknown encryption method $encryption";
1743 # croak "unknown encryption method $encryption";
1748 =item domain_slash_username
1750 Returns $domain/$username/
1754 sub domain_slash_username {
1756 $self->domain. '/'. $self->username. '/';
1759 =item virtual_maildir
1761 Returns $domain/maildirs/$username/
1765 sub virtual_maildir {
1767 $self->domain. '/maildirs/'. $self->username. '/';
1778 This is the FS::svc_acct job-queue-able version. It still uses
1779 FS::Misc::send_email under-the-hood.
1786 eval "use FS::Misc qw(send_email)";
1789 $opt{mimetype} ||= 'text/plain';
1790 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1792 my $error = send_email(
1793 'from' => $opt{from},
1795 'subject' => $opt{subject},
1796 'content-type' => $opt{mimetype},
1797 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1799 die $error if $error;
1802 =item check_and_rebuild_fuzzyfiles
1806 sub check_and_rebuild_fuzzyfiles {
1807 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1808 -e "$dir/svc_acct.username"
1809 or &rebuild_fuzzyfiles;
1812 =item rebuild_fuzzyfiles
1816 sub rebuild_fuzzyfiles {
1818 use Fcntl qw(:flock);
1820 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1824 open(USERNAMELOCK,">>$dir/svc_acct.username")
1825 or die "can't open $dir/svc_acct.username: $!";
1826 flock(USERNAMELOCK,LOCK_EX)
1827 or die "can't lock $dir/svc_acct.username: $!";
1829 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1831 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1832 or die "can't open $dir/svc_acct.username.tmp: $!";
1833 print USERNAMECACHE join("\n", @all_username), "\n";
1834 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1836 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1846 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1847 open(USERNAMECACHE,"<$dir/svc_acct.username")
1848 or die "can't open $dir/svc_acct.username: $!";
1849 my @array = map { chomp; $_; } <USERNAMECACHE>;
1850 close USERNAMECACHE;
1854 =item append_fuzzyfiles USERNAME
1858 sub append_fuzzyfiles {
1859 my $username = shift;
1861 &check_and_rebuild_fuzzyfiles;
1863 use Fcntl qw(:flock);
1865 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1867 open(USERNAME,">>$dir/svc_acct.username")
1868 or die "can't open $dir/svc_acct.username: $!";
1869 flock(USERNAME,LOCK_EX)
1870 or die "can't lock $dir/svc_acct.username: $!";
1872 print USERNAME "$username\n";
1874 flock(USERNAME,LOCK_UN)
1875 or die "can't unlock $dir/svc_acct.username: $!";
1883 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1887 sub radius_usergroup_selector {
1888 my $sel_groups = shift;
1889 my %sel_groups = map { $_=>1 } @$sel_groups;
1891 my $selectname = shift || 'radius_usergroup';
1894 my $sth = $dbh->prepare(
1895 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1896 ) or die $dbh->errstr;
1897 $sth->execute() or die $sth->errstr;
1898 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1902 function ${selectname}_doadd(object) {
1903 var myvalue = object.${selectname}_add.value;
1904 var optionName = new Option(myvalue,myvalue,false,true);
1905 var length = object.$selectname.length;
1906 object.$selectname.options[length] = optionName;
1907 object.${selectname}_add.value = "";
1910 <SELECT MULTIPLE NAME="$selectname">
1913 foreach my $group ( @all_groups ) {
1914 $html .= qq(<OPTION VALUE="$group");
1915 if ( $sel_groups{$group} ) {
1916 $html .= ' SELECTED';
1917 $sel_groups{$group} = 0;
1919 $html .= ">$group</OPTION>\n";
1921 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1922 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1924 $html .= '</SELECT>';
1926 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1927 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1932 =item reached_threshold
1934 Performs some activities when svc_acct thresholds (such as number of seconds
1935 remaining) are reached.
1939 sub reached_threshold {
1942 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
1943 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
1945 if ( $opt{'op'} eq '+' ){
1946 $svc_acct->setfield( $opt{'column'}.'_threshold',
1947 int($svc_acct->getfield($opt{'column'})
1948 * ( $conf->exists('svc_acct-usage_threshold')
1949 ? $conf->config('svc_acct-usage_threshold')/100
1954 my $error = $svc_acct->replace;
1955 die $error if $error;
1956 }elsif ( $opt{'op'} eq '-' ){
1958 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
1959 return '' if ($threshold eq '' && opt{'column'} eq 'totalbytes');
1961 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
1962 my $error = $svc_acct->replace;
1963 die $error if $error; # email next time, i guess
1965 if ( $warning_template ) {
1966 eval "use FS::Misc qw(send_email)";
1969 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
1970 my $cust_main = $cust_pkg->cust_main;
1972 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
1973 $cust_main->invoicing_list,
1975 ($opt{'to'} ? $opt{'to'} : ())
1978 my $mimetype = $warning_mimetype;
1979 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1981 my $body = $warning_template->fill_in( HASH => {
1982 'custnum' => $cust_main->custnum,
1983 'username' => $svc_acct->username,
1984 'password' => $svc_acct->_password,
1985 'first' => $cust_main->first,
1986 'last' => $cust_main->getfield('last'),
1987 'pkg' => $cust_pkg->part_pkg->pkg,
1988 'column' => $opt{'column'},
1989 'amount' => $svc_acct->getfield($opt{'column'}),
1990 'threshold' => $threshold,
1994 my $error = send_email(
1995 'from' => $warning_from,
1997 'subject' => $warning_subject,
1998 'content-type' => $mimetype,
1999 'body' => [ map "$_\n", split("\n", $body) ],
2001 die $error if $error;
2004 die "unknown op: " . $opt{'op'};
2012 The $recref stuff in sub check should be cleaned up.
2014 The suspend, unsuspend and cancel methods update the database, but not the
2015 current object. This is probably a bug as it's unexpected and
2018 radius_usergroup_selector? putting web ui components in here? they should
2019 probably live somewhere else...
2021 insertion of RADIUS group stuff in insert could be done with child_objects now
2022 (would probably clean up export of them too)
2026 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2027 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2028 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2029 L<freeside-queued>), L<FS::svc_acct_pop>,
2030 schema.html from the base documentation.