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">.
216 'longname_plural' => 'Access accounts and mailboxes',
217 'sorts' => [ 'username', 'uid', ],
218 'display_weight' => 10,
219 'cancel_weight' => 50,
221 'dir' => 'Home directory',
224 def_label => 'UID (set to fixed and blank for no UIDs)',
227 'slipip' => 'IP address',
228 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
230 label => 'Access number',
232 select_table => 'svc_acct_pop',
233 select_key => 'popnum',
234 select_label => 'city',
239 disable_default => 1,
245 disable_inventory => 1,
247 '_password' => 'Password',
250 def_label => 'GID (when blank, defaults to UID)',
254 #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
256 def_label=> 'Shell (set to blank for no shell tracking)',
258 select_list => [ $conf->config('shells') ],
259 disable_inventory => 1,
261 'finger' => 'Real name (GECOS)',
264 def_label => 'svcnum from svc_domain',
266 select_table => 'svc_domain',
267 select_key => 'svcnum',
268 select_label => 'domain',
269 disable_inventory => 1,
272 label => 'RADIUS groups',
273 type => 'radius_usergroup_selector',
274 disable_inventory => 1,
276 'seconds' => { label => 'Seconds',
278 disable_inventory => 1,
284 sub table { 'svc_acct'; }
288 #false laziness with edit/svc_acct.cgi
290 my( $self, $groups ) = @_;
291 if ( ref($groups) eq 'ARRAY' ) {
293 } elsif ( length($groups) ) {
294 [ split(/\s*,\s*/, $groups) ];
302 =item search_sql STRING
304 Class method which returns an SQL fragment to search for the given string.
309 my( $class, $string ) = @_;
310 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
311 my( $username, $domain ) = ( $1, $2 );
312 my $q_username = dbh->quote($username);
313 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
315 "svc_acct.username = $q_username AND ( ".
316 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
321 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
323 $class->search_sql_field('slipip', $string ).
325 $class->search_sql_field('username', $string ).
328 $class->search_sql_field('username', $string);
332 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
334 Returns the "username@domain" string for this account.
336 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
348 =item insert [ , OPTION => VALUE ... ]
350 Adds this account to the database. If there is an error, returns the error,
351 otherwise returns false.
353 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
354 defined. An FS::cust_svc record will be created and inserted.
356 The additional field I<usergroup> can optionally be defined; if so it should
357 contain an arrayref of group names. See L<FS::radius_usergroup>.
359 The additional field I<child_objects> can optionally be defined; if so it
360 should contain an arrayref of FS::tablename objects. They will have their
361 svcnum fields set and will be inserted after this record, but before any
362 exports are run. Each element of the array can also optionally be a
363 two-element array reference containing the child object and the name of an
364 alternate field to be filled in with the newly-inserted svcnum, for example
365 C<[ $svc_forward, 'srcsvc' ]>
367 Currently available options are: I<depend_jobnum>
369 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
370 jobnums), all provisioning jobs will have a dependancy on the supplied
371 jobnum(s) (they will not run until the specific job(s) complete(s)).
373 (TODOC: L<FS::queue> and L<freeside-queued>)
375 (TODOC: new exports!)
384 warn "[$me] insert called on $self: ". Dumper($self).
385 "\nwith options: ". Dumper(%options);
388 local $SIG{HUP} = 'IGNORE';
389 local $SIG{INT} = 'IGNORE';
390 local $SIG{QUIT} = 'IGNORE';
391 local $SIG{TERM} = 'IGNORE';
392 local $SIG{TSTP} = 'IGNORE';
393 local $SIG{PIPE} = 'IGNORE';
395 my $oldAutoCommit = $FS::UID::AutoCommit;
396 local $FS::UID::AutoCommit = 0;
399 my $error = $self->check;
400 return $error if $error;
402 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
403 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
404 unless ( $cust_svc ) {
405 $dbh->rollback if $oldAutoCommit;
406 return "no cust_svc record found for svcnum ". $self->svcnum;
408 $self->pkgnum($cust_svc->pkgnum);
409 $self->svcpart($cust_svc->svcpart);
412 $error = $self->_check_duplicate;
414 $dbh->rollback if $oldAutoCommit;
419 $error = $self->SUPER::insert(
420 'jobnums' => \@jobnums,
421 'child_objects' => $self->child_objects,
425 $dbh->rollback if $oldAutoCommit;
429 if ( $self->usergroup ) {
430 foreach my $groupname ( @{$self->usergroup} ) {
431 my $radius_usergroup = new FS::radius_usergroup ( {
432 svcnum => $self->svcnum,
433 groupname => $groupname,
435 my $error = $radius_usergroup->insert;
437 $dbh->rollback if $oldAutoCommit;
443 unless ( $skip_fuzzyfiles ) {
444 $error = $self->queue_fuzzyfiles_update;
446 $dbh->rollback if $oldAutoCommit;
447 return "updating fuzzy search cache: $error";
451 my $cust_pkg = $self->cust_svc->cust_pkg;
454 my $cust_main = $cust_pkg->cust_main;
456 if ( $conf->exists('emailinvoiceauto') ) {
457 my @invoicing_list = $cust_main->invoicing_list;
458 push @invoicing_list, $self->email;
459 $cust_main->invoicing_list(\@invoicing_list);
464 if ( $welcome_template && $cust_pkg ) {
465 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
467 my $wqueue = new FS::queue {
468 'svcnum' => $self->svcnum,
469 'job' => 'FS::svc_acct::send_email'
471 my $error = $wqueue->insert(
473 'from' => $welcome_from,
474 'subject' => $welcome_subject,
475 'mimetype' => $welcome_mimetype,
476 'body' => $welcome_template->fill_in( HASH => {
477 'custnum' => $self->custnum,
478 'username' => $self->username,
479 'password' => $self->_password,
480 'first' => $cust_main->first,
481 'last' => $cust_main->getfield('last'),
482 'pkg' => $cust_pkg->part_pkg->pkg,
486 $dbh->rollback if $oldAutoCommit;
487 return "error queuing welcome email: $error";
490 if ( $options{'depend_jobnum'} ) {
491 warn "$me depend_jobnum found; adding to welcome email dependancies"
493 if ( ref($options{'depend_jobnum'}) ) {
494 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
495 "to welcome email dependancies"
497 push @jobnums, @{ $options{'depend_jobnum'} };
499 warn "$me adding job $options{'depend_jobnum'} ".
500 "to welcome email dependancies"
502 push @jobnums, $options{'depend_jobnum'};
506 foreach my $jobnum ( @jobnums ) {
507 my $error = $wqueue->depend_insert($jobnum);
509 $dbh->rollback if $oldAutoCommit;
510 return "error queuing welcome email job dependancy: $error";
520 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
526 Deletes this account from the database. If there is an error, returns the
527 error, otherwise returns false.
529 The corresponding FS::cust_svc record will be deleted as well.
531 (TODOC: new exports!)
538 return "can't delete system account" if $self->_check_system;
540 return "Can't delete an account which is a (svc_forward) source!"
541 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
543 return "Can't delete an account which is a (svc_forward) destination!"
544 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
546 return "Can't delete an account with (svc_www) web service!"
547 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
549 # what about records in session ? (they should refer to history table)
551 local $SIG{HUP} = 'IGNORE';
552 local $SIG{INT} = 'IGNORE';
553 local $SIG{QUIT} = 'IGNORE';
554 local $SIG{TERM} = 'IGNORE';
555 local $SIG{TSTP} = 'IGNORE';
556 local $SIG{PIPE} = 'IGNORE';
558 my $oldAutoCommit = $FS::UID::AutoCommit;
559 local $FS::UID::AutoCommit = 0;
562 foreach my $cust_main_invoice (
563 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
565 unless ( defined($cust_main_invoice) ) {
566 warn "WARNING: something's wrong with qsearch";
569 my %hash = $cust_main_invoice->hash;
570 $hash{'dest'} = $self->email;
571 my $new = new FS::cust_main_invoice \%hash;
572 my $error = $new->replace($cust_main_invoice);
574 $dbh->rollback if $oldAutoCommit;
579 foreach my $svc_domain (
580 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
582 my %hash = new FS::svc_domain->hash;
583 $hash{'catchall'} = '';
584 my $new = new FS::svc_domain \%hash;
585 my $error = $new->replace($svc_domain);
587 $dbh->rollback if $oldAutoCommit;
592 foreach my $radius_usergroup (
593 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
595 my $error = $radius_usergroup->delete;
597 $dbh->rollback if $oldAutoCommit;
602 my $error = $self->SUPER::delete;
604 $dbh->rollback if $oldAutoCommit;
608 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
612 =item replace OLD_RECORD
614 Replaces OLD_RECORD with this one in the database. If there is an error,
615 returns the error, otherwise returns false.
617 The additional field I<usergroup> can optionally be defined; if so it should
618 contain an arrayref of group names. See L<FS::radius_usergroup>.
624 my ( $new, $old ) = ( shift, shift );
626 warn "$me replacing $old with $new\n" if $DEBUG;
628 # We absolutely have to have an old vs. new record to make this work.
629 if (!defined($old)) {
630 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
633 return "can't modify system account" if $old->_check_system;
636 #no warnings 'numeric'; #alas, a 5.006-ism
639 foreach my $xid (qw( uid gid )) {
641 return "Can't change $xid!"
642 if ! $conf->exists("svc_acct-edit_$xid")
643 && $old->$xid() != $new->$xid()
644 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
649 #change homdir when we change username
650 $new->setfield('dir', '') if $old->username ne $new->username;
652 local $SIG{HUP} = 'IGNORE';
653 local $SIG{INT} = 'IGNORE';
654 local $SIG{QUIT} = 'IGNORE';
655 local $SIG{TERM} = 'IGNORE';
656 local $SIG{TSTP} = 'IGNORE';
657 local $SIG{PIPE} = 'IGNORE';
659 my $oldAutoCommit = $FS::UID::AutoCommit;
660 local $FS::UID::AutoCommit = 0;
663 # redundant, but so $new->usergroup gets set
664 $error = $new->check;
665 return $error if $error;
667 $old->usergroup( [ $old->radius_groups ] );
669 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
670 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
672 if ( $new->usergroup ) {
673 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
674 my @newgroups = @{$new->usergroup};
675 foreach my $oldgroup ( @{$old->usergroup} ) {
676 if ( grep { $oldgroup eq $_ } @newgroups ) {
677 @newgroups = grep { $oldgroup ne $_ } @newgroups;
680 my $radius_usergroup = qsearchs('radius_usergroup', {
681 svcnum => $old->svcnum,
682 groupname => $oldgroup,
684 my $error = $radius_usergroup->delete;
686 $dbh->rollback if $oldAutoCommit;
687 return "error deleting radius_usergroup $oldgroup: $error";
691 foreach my $newgroup ( @newgroups ) {
692 my $radius_usergroup = new FS::radius_usergroup ( {
693 svcnum => $new->svcnum,
694 groupname => $newgroup,
696 my $error = $radius_usergroup->insert;
698 $dbh->rollback if $oldAutoCommit;
699 return "error adding radius_usergroup $newgroup: $error";
705 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
706 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
707 $error = $new->_check_duplicate;
709 $dbh->rollback if $oldAutoCommit;
714 $error = $new->SUPER::replace($old);
716 $dbh->rollback if $oldAutoCommit;
717 return $error if $error;
720 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
721 $error = $new->queue_fuzzyfiles_update;
723 $dbh->rollback if $oldAutoCommit;
724 return "updating fuzzy search cache: $error";
728 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
732 =item queue_fuzzyfiles_update
734 Used by insert & replace to update the fuzzy search cache
738 sub queue_fuzzyfiles_update {
741 local $SIG{HUP} = 'IGNORE';
742 local $SIG{INT} = 'IGNORE';
743 local $SIG{QUIT} = 'IGNORE';
744 local $SIG{TERM} = 'IGNORE';
745 local $SIG{TSTP} = 'IGNORE';
746 local $SIG{PIPE} = 'IGNORE';
748 my $oldAutoCommit = $FS::UID::AutoCommit;
749 local $FS::UID::AutoCommit = 0;
752 my $queue = new FS::queue {
753 'svcnum' => $self->svcnum,
754 'job' => 'FS::svc_acct::append_fuzzyfiles'
756 my $error = $queue->insert($self->username);
758 $dbh->rollback if $oldAutoCommit;
759 return "queueing job (transaction rolled back): $error";
762 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
770 Suspends this account by calling export-specific suspend hooks. If there is
771 an error, returns the error, otherwise returns false.
773 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
779 return "can't suspend system account" if $self->_check_system;
780 $self->SUPER::suspend;
785 Unsuspends this account by by calling export-specific suspend hooks. If there
786 is an error, returns the error, otherwise returns false.
788 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
794 my %hash = $self->hash;
795 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
796 $hash{_password} = $1;
797 my $new = new FS::svc_acct ( \%hash );
798 my $error = $new->replace($self);
799 return $error if $error;
802 $self->SUPER::unsuspend;
807 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
809 If the B<auto_unset_catchall> configuration option is set, this method will
810 automatically remove any references to the canceled service in the catchall
811 field of svc_domain. This allows packages that contain both a svc_domain and
812 its catchall svc_acct to be canceled in one step.
817 # Only one thing to do at this level
819 foreach my $svc_domain (
820 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
821 if($conf->exists('auto_unset_catchall')) {
822 my %hash = $svc_domain->hash;
823 $hash{catchall} = '';
824 my $new = new FS::svc_domain ( \%hash );
825 my $error = $new->replace($svc_domain);
826 return $error if $error;
828 return "cannot unprovision svc_acct #".$self->svcnum.
829 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
833 $self->SUPER::cancel;
839 Checks all fields to make sure this is a valid service. If there is an error,
840 returns the error, otherwise returns false. Called by the insert and replace
843 Sets any fixed values; see L<FS::part_svc>.
850 my($recref) = $self->hashref;
852 my $x = $self->setfixed( $self->_fieldhandlers );
853 return $x unless ref($x);
856 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
858 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
861 my $error = $self->ut_numbern('svcnum')
862 #|| $self->ut_number('domsvc')
863 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
864 || $self->ut_textn('sec_phrase')
865 || $self->ut_snumbern('seconds')
866 || $self->ut_snumbern('upbytes')
867 || $self->ut_snumbern('downbytes')
868 || $self->ut_snumbern('totalbytes')
870 return $error if $error;
872 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
873 if ( $username_uppercase ) {
874 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
875 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
876 $recref->{username} = $1;
878 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
879 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
880 $recref->{username} = $1;
883 if ( $username_letterfirst ) {
884 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
885 } elsif ( $username_letter ) {
886 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
888 if ( $username_noperiod ) {
889 $recref->{username} =~ /\./ and return gettext('illegal_username');
891 if ( $username_nounderscore ) {
892 $recref->{username} =~ /_/ and return gettext('illegal_username');
894 if ( $username_nodash ) {
895 $recref->{username} =~ /\-/ and return gettext('illegal_username');
897 unless ( $username_ampersand ) {
898 $recref->{username} =~ /\&/ and return gettext('illegal_username');
900 if ( $password_noampersand ) {
901 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
903 if ( $password_noexclamation ) {
904 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
906 unless ( $username_percent ) {
907 $recref->{username} =~ /\%/ and return gettext('illegal_username');
910 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
911 $recref->{popnum} = $1;
912 return "Unknown popnum" unless
913 ! $recref->{popnum} ||
914 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
916 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
918 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
919 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
921 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
922 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
923 #not all systems use gid=uid
924 #you can set a fixed gid in part_svc
926 return "Only root can have uid 0"
927 if $recref->{uid} == 0
928 && $recref->{username} !~ /^(root|toor|smtp)$/;
930 unless ( $recref->{username} eq 'sync' ) {
931 if ( grep $_ eq $recref->{shell}, @shells ) {
932 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
934 return "Illegal shell \`". $self->shell. "\'; ".
935 $conf->dir. "/shells contains: @shells";
938 $recref->{shell} = '/bin/sync';
942 $recref->{gid} ne '' ?
943 return "Can't have gid without uid" : ( $recref->{gid}='' );
944 #$recref->{dir} ne '' ?
945 # return "Can't have directory without uid" : ( $recref->{dir}='' );
946 $recref->{shell} ne '' ?
947 return "Can't have shell without uid" : ( $recref->{shell}='' );
950 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
952 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
953 or return "Illegal directory: ". $recref->{dir};
955 return "Illegal directory"
956 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
957 return "Illegal directory"
958 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
959 unless ( $recref->{dir} ) {
960 $recref->{dir} = $dir_prefix . '/';
961 if ( $dirhash > 0 ) {
962 for my $h ( 1 .. $dirhash ) {
963 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
965 } elsif ( $dirhash < 0 ) {
966 for my $h ( reverse $dirhash .. -1 ) {
967 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
970 $recref->{dir} .= $recref->{username};
976 # $error = $self->ut_textn('finger');
977 # return $error if $error;
978 if ( $self->getfield('finger') eq '' ) {
979 my $cust_pkg = $self->svcnum
980 ? $self->cust_svc->cust_pkg
981 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
983 my $cust_main = $cust_pkg->cust_main;
984 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
987 $self->getfield('finger') =~
988 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
989 or return "Illegal finger: ". $self->getfield('finger');
990 $self->setfield('finger', $1);
992 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
993 $recref->{quota} = $1;
995 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
996 if ( $recref->{slipip} eq '' ) {
997 $recref->{slipip} = '';
998 } elsif ( $recref->{slipip} eq '0e0' ) {
999 $recref->{slipip} = '0e0';
1001 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1002 or return "Illegal slipip: ". $self->slipip;
1003 $recref->{slipip} = $1;
1008 #arbitrary RADIUS stuff; allow ut_textn for now
1009 foreach ( grep /^radius_/, fields('svc_acct') ) {
1010 $self->ut_textn($_);
1013 #generate a password if it is blank
1014 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1015 unless ( $recref->{_password} );
1017 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1018 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1019 $recref->{_password} = $1.$3;
1020 #uncomment this to encrypt password immediately upon entry, or run
1021 #bin/crypt_pw in cron to give new users a window during which their
1022 #password is available to techs, for faxing, etc. (also be aware of
1024 #$recref->{password} = $1.
1025 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
1027 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1028 $recref->{_password} = $1.$3;
1029 } elsif ( $recref->{_password} eq '*' ) {
1030 $recref->{_password} = '*';
1031 } elsif ( $recref->{_password} eq '!' ) {
1032 $recref->{_password} = '!';
1033 } elsif ( $recref->{_password} eq '!!' ) {
1034 $recref->{_password} = '!!';
1036 #return "Illegal password";
1037 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1038 FS::Msgcat::_gettext('illegal_password_characters').
1039 ": ". $recref->{_password};
1042 $self->SUPER::check;
1047 Internal function to check the username against the list of system usernames
1048 from the I<system_usernames> configuration value. Returns true if the username
1049 is listed on the system username list.
1055 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1056 $conf->config('system_usernames')
1060 =item _check_duplicate
1062 Internal function to check for duplicates usernames, username@domain pairs and
1065 If the I<global_unique-username> configuration value is set to B<username> or
1066 B<username@domain>, enforces global username or username@domain uniqueness.
1068 In all cases, check for duplicate uids and usernames or username@domain pairs
1069 per export and with identical I<svcpart> values.
1073 sub _check_duplicate {
1076 my $global_unique = $conf->config('global_unique-username') || 'none';
1077 return '' if $global_unique eq 'disabled';
1079 #this is Pg-specific. what to do for mysql etc?
1080 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
1081 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1082 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1084 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1086 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1087 unless ( $part_svc ) {
1088 return 'unknown svcpart '. $self->svcpart;
1091 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1092 qsearch( 'svc_acct', { 'username' => $self->username } );
1093 return gettext('username_in_use')
1094 if $global_unique eq 'username' && @dup_user;
1096 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1097 qsearch( 'svc_acct', { 'username' => $self->username,
1098 'domsvc' => $self->domsvc } );
1099 return gettext('username_in_use')
1100 if $global_unique eq 'username@domain' && @dup_userdomain;
1103 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1104 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1105 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1106 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1111 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1112 my $exports = FS::part_export::export_info('svc_acct');
1113 my %conflict_user_svcpart;
1114 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1116 foreach my $part_export ( $part_svc->part_export ) {
1118 #this will catch to the same exact export
1119 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1121 #this will catch to exports w/same exporthost+type ???
1122 #my @other_part_export = qsearch('part_export', {
1123 # 'machine' => $part_export->machine,
1124 # 'exporttype' => $part_export->exporttype,
1126 #foreach my $other_part_export ( @other_part_export ) {
1127 # push @svcparts, map { $_->svcpart }
1128 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1131 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1132 #silly kludge to avoid uninitialized value errors
1133 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1134 ? $exports->{$part_export->exporttype}{'nodomain'}
1136 if ( $nodomain =~ /^Y/i ) {
1137 $conflict_user_svcpart{$_} = $part_export->exportnum
1140 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1145 foreach my $dup_user ( @dup_user ) {
1146 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1147 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1148 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1149 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1153 foreach my $dup_userdomain ( @dup_userdomain ) {
1154 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1155 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1156 return "duplicate username\@domain: conflicts with svcnum ".
1157 $dup_userdomain->svcnum. " via exportnum ".
1158 $conflict_userdomain_svcpart{$dup_svcpart};
1162 foreach my $dup_uid ( @dup_uid ) {
1163 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1164 if ( exists($conflict_user_svcpart{$dup_svcpart})
1165 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1166 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1167 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1168 || $conflict_userdomain_svcpart{$dup_svcpart};
1180 Depriciated, use radius_reply instead.
1185 carp "FS::svc_acct::radius depriciated, use radius_reply";
1186 $_[0]->radius_reply;
1191 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1192 reply attributes of this record.
1194 Note that this is now the preferred method for reading RADIUS attributes -
1195 accessing the columns directly is discouraged, as the column names are
1196 expected to change in the future.
1203 return %{ $self->{'radius_reply'} }
1204 if exists $self->{'radius_reply'};
1209 my($column, $attrib) = ($1, $2);
1210 #$attrib =~ s/_/\-/g;
1211 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1212 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1214 if ( $self->slipip && $self->slipip ne '0e0' ) {
1215 $reply{$radius_ip} = $self->slipip;
1218 if ( $self->seconds !~ /^$/ ) {
1219 $reply{'Session-Timeout'} = $self->seconds;
1227 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1228 check attributes of this record.
1230 Note that this is now the preferred method for reading RADIUS attributes -
1231 accessing the columns directly is discouraged, as the column names are
1232 expected to change in the future.
1239 return %{ $self->{'radius_check'} }
1240 if exists $self->{'radius_check'};
1245 my($column, $attrib) = ($1, $2);
1246 #$attrib =~ s/_/\-/g;
1247 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1248 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1250 my $password = $self->_password;
1251 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1253 my $cust_svc = $self->cust_svc;
1254 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1256 my $cust_pkg = $cust_svc->cust_pkg;
1257 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1258 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1267 This method instructs the object to "snapshot" or freeze RADIUS check and
1268 reply attributes to the current values.
1272 #bah, my english is too broken this morning
1273 #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
1274 #the FS::cust_pkg's replace method to trigger the correct export updates when
1275 #package dates change)
1280 $self->{$_} = { $self->$_() }
1281 foreach qw( radius_reply radius_check );
1285 =item forget_snapshot
1287 This methos instructs the object to forget any previously snapshotted
1288 RADIUS check and reply attributes.
1292 sub forget_snapshot {
1296 foreach qw( radius_reply radius_check );
1300 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1302 Returns the domain associated with this account.
1304 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1311 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1312 my $svc_domain = $self->svc_domain(@_)
1313 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1314 $svc_domain->domain;
1319 Returns the FS::svc_domain record for this account's domain (see
1324 # FS::h_svc_acct has a history-aware svc_domain override
1329 ? $self->{'_domsvc'}
1330 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1335 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1339 #inherited from svc_Common
1341 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1343 Returns an email address associated with the account.
1345 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1352 $self->username. '@'. $self->domain(@_);
1357 Returns an array of FS::acct_snarf records associated with the account.
1358 If the acct_snarf table does not exist or there are no associated records,
1359 an empty list is returned
1365 return () unless dbdef->table('acct_snarf');
1366 eval "use FS::acct_snarf;";
1368 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1371 =item decrement_upbytes OCTETS
1373 Decrements the I<upbytes> field of this record by the given amount. If there
1374 is an error, returns the error, otherwise returns false.
1378 sub decrement_upbytes {
1379 shift->_op_usage('-', 'upbytes', @_);
1382 =item increment_upbytes OCTETS
1384 Increments the I<upbytes> field of this record by the given amount. If there
1385 is an error, returns the error, otherwise returns false.
1389 sub increment_upbytes {
1390 shift->_op_usage('+', 'upbytes', @_);
1393 =item decrement_downbytes OCTETS
1395 Decrements the I<downbytes> field of this record by the given amount. If there
1396 is an error, returns the error, otherwise returns false.
1400 sub decrement_downbytes {
1401 shift->_op_usage('-', 'downbytes', @_);
1404 =item increment_downbytes OCTETS
1406 Increments the I<downbytes> field of this record by the given amount. If there
1407 is an error, returns the error, otherwise returns false.
1411 sub increment_downbytes {
1412 shift->_op_usage('+', 'downbytes', @_);
1415 =item decrement_totalbytes OCTETS
1417 Decrements the I<totalbytes> field of this record by the given amount. If there
1418 is an error, returns the error, otherwise returns false.
1422 sub decrement_totalbytes {
1423 shift->_op_usage('-', 'totalbytes', @_);
1426 =item increment_totalbytes OCTETS
1428 Increments the I<totalbytes> field of this record by the given amount. If there
1429 is an error, returns the error, otherwise returns false.
1433 sub increment_totalbytes {
1434 shift->_op_usage('+', 'totalbytes', @_);
1437 =item decrement_seconds SECONDS
1439 Decrements the I<seconds> field of this record by the given amount. If there
1440 is an error, returns the error, otherwise returns false.
1444 sub decrement_seconds {
1445 shift->_op_usage('-', 'seconds', @_);
1448 =item increment_seconds SECONDS
1450 Increments the I<seconds> field of this record by the given amount. If there
1451 is an error, returns the error, otherwise returns false.
1455 sub increment_seconds {
1456 shift->_op_usage('+', 'seconds', @_);
1464 my %op2condition = (
1465 '-' => sub { my($self, $column, $amount) = @_;
1466 $self->$column - $amount <= 0;
1468 '+' => sub { my($self, $column, $amount) = @_;
1469 $self->$column + $amount > 0;
1472 my %op2warncondition = (
1473 '-' => sub { my($self, $column, $amount) = @_;
1474 my $threshold = $column . '_threshold';
1475 $self->$column - $amount <= $self->$threshold + 0;
1477 '+' => sub { my($self, $column, $amount) = @_;
1478 $self->$column + $amount > 0;
1483 my( $self, $op, $column, $amount ) = @_;
1485 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1486 ' ('. $self->email. "): $op $amount\n"
1489 return '' unless $amount;
1491 local $SIG{HUP} = 'IGNORE';
1492 local $SIG{INT} = 'IGNORE';
1493 local $SIG{QUIT} = 'IGNORE';
1494 local $SIG{TERM} = 'IGNORE';
1495 local $SIG{TSTP} = 'IGNORE';
1496 local $SIG{PIPE} = 'IGNORE';
1498 my $oldAutoCommit = $FS::UID::AutoCommit;
1499 local $FS::UID::AutoCommit = 0;
1502 my $sql = "UPDATE svc_acct SET $column = ".
1503 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1504 " $op ? WHERE svcnum = ?";
1508 my $sth = $dbh->prepare( $sql )
1509 or die "Error preparing $sql: ". $dbh->errstr;
1510 my $rv = $sth->execute($amount, $self->svcnum);
1511 die "Error executing $sql: ". $sth->errstr
1512 unless defined($rv);
1513 die "Can't update $column for svcnum". $self->svcnum
1516 my $action = $op2action{$op};
1518 if ( $conf->exists("svc_acct-usage_$action")
1519 && &{$op2condition{$op}}($self, $column, $amount) ) {
1520 #my $error = $self->$action();
1521 my $error = $self->cust_svc->cust_pkg->$action();
1523 $dbh->rollback if $oldAutoCommit;
1524 return "Error ${action}ing: $error";
1528 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1529 my $wqueue = new FS::queue {
1530 'svcnum' => $self->svcnum,
1531 'job' => 'FS::svc_acct::reached_threshold',
1536 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1540 my $error = $wqueue->insert(
1541 'svcnum' => $self->svcnum,
1543 'column' => $column,
1547 $dbh->rollback if $oldAutoCommit;
1548 return "Error queuing threshold activity: $error";
1552 warn "$me update successful; committing\n"
1554 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1560 my( $self, $valueref ) = @_;
1562 warn "$me set_usage called for svcnum ". $self->svcnum.
1563 ' ('. $self->email. "): ".
1564 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1567 local $SIG{HUP} = 'IGNORE';
1568 local $SIG{INT} = 'IGNORE';
1569 local $SIG{QUIT} = 'IGNORE';
1570 local $SIG{TERM} = 'IGNORE';
1571 local $SIG{TSTP} = 'IGNORE';
1572 local $SIG{PIPE} = 'IGNORE';
1574 local $FS::svc_Common::noexport_hack = 1;
1575 my $oldAutoCommit = $FS::UID::AutoCommit;
1576 local $FS::UID::AutoCommit = 0;
1580 foreach my $field (keys %$valueref){
1581 $reset = 1 if $valueref->{$field};
1582 $self->setfield($field, $valueref->{$field});
1583 $self->setfield( $field.'_threshold',
1584 int($self->getfield($field)
1585 * ( $conf->exists('svc_acct-usage_threshold')
1586 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1592 my $error = $self->replace;
1593 die $error if $error;
1595 if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) {
1596 my $error = $self->cust_svc->cust_pkg->unsuspend;
1598 $dbh->rollback if $oldAutoCommit;
1599 return "Error unsuspending: $error";
1603 warn "$me update successful; committing\n"
1605 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1611 =item recharge HASHREF
1613 Increments usage columns by the amount specified in HASHREF as
1614 column=>amount pairs.
1619 my ($self, $vhash) = @_;
1622 warn "[$me] recharge called on $self: ". Dumper($self).
1623 "\nwith vhash: ". Dumper($vhash);
1626 my $oldAutoCommit = $FS::UID::AutoCommit;
1627 local $FS::UID::AutoCommit = 0;
1631 foreach my $column (keys %$vhash){
1632 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1636 $dbh->rollback if $oldAutoCommit;
1638 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1643 =item is_rechargeable
1645 Returns true if this svc_account can be "recharged" and false otherwise.
1649 sub is_rechargable {
1651 $self->seconds ne ''
1652 || $self->upbytes ne ''
1653 || $self->downbytes ne ''
1654 || $self->totalbytes ne '';
1657 =item seconds_since TIMESTAMP
1659 Returns the number of seconds this account has been online since TIMESTAMP,
1660 according to the session monitor (see L<FS::Session>).
1662 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1663 L<Time::Local> and L<Date::Parse> for conversion functions.
1667 #note: POD here, implementation in FS::cust_svc
1670 $self->cust_svc->seconds_since(@_);
1673 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1675 Returns the numbers of seconds this account has been online between
1676 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1677 external SQL radacct table, specified via sqlradius export. Sessions which
1678 started in the specified range but are still open are counted from session
1679 start to the end of the range (unless they are over 1 day old, in which case
1680 they are presumed missing their stop record and not counted). Also, sessions
1681 which end in the range but started earlier are counted from the start of the
1682 range to session end. Finally, sessions which start before the range but end
1683 after are counted for the entire range.
1685 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1686 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1691 #note: POD here, implementation in FS::cust_svc
1692 sub seconds_since_sqlradacct {
1694 $self->cust_svc->seconds_since_sqlradacct(@_);
1697 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1699 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1700 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1701 TIMESTAMP_END (exclusive).
1703 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1704 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1709 #note: POD here, implementation in FS::cust_svc
1710 sub attribute_since_sqlradacct {
1712 $self->cust_svc->attribute_since_sqlradacct(@_);
1715 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1717 Returns an array of hash references of this customers login history for the
1718 given time range. (document this better)
1722 sub get_session_history {
1724 $self->cust_svc->get_session_history(@_);
1727 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1732 my($self, $start, $end, %opt ) = @_;
1734 my $did = $self->username; #yup
1736 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1738 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1740 #SELECT $for_update * FROM cdr
1741 # WHERE calldate >= $start #need a conversion
1742 # AND calldate < $end #ditto
1743 # AND ( charged_party = "$did"
1744 # OR charged_party = "$prefix$did" #if length($prefix);
1745 # OR ( ( charged_party IS NULL OR charged_party = '' )
1747 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1750 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1753 if ( length($prefix) ) {
1755 " AND ( charged_party = '$did'
1756 OR charged_party = '$prefix$did'
1757 OR ( ( charged_party IS NULL OR charged_party = '' )
1759 ( src = '$did' OR src = '$prefix$did' )
1765 " AND ( charged_party = '$did'
1766 OR ( ( charged_party IS NULL OR charged_party = '' )
1776 'select' => "$for_update *",
1779 #( freesidestatus IS NULL OR freesidestatus = '' )
1780 'freesidestatus' => '',
1782 'extra_sql' => $charged_or_src,
1790 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1796 if ( $self->usergroup ) {
1797 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1798 unless ref($self->usergroup) eq 'ARRAY';
1799 #when provisioning records, export callback runs in svc_Common.pm before
1800 #radius_usergroup records can be inserted...
1801 @{$self->usergroup};
1803 map { $_->groupname }
1804 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1808 =item clone_suspended
1810 Constructor used by FS::part_export::_export_suspend fallback. Document
1815 sub clone_suspended {
1817 my %hash = $self->hash;
1818 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1819 new FS::svc_acct \%hash;
1822 =item clone_kludge_unsuspend
1824 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1829 sub clone_kludge_unsuspend {
1831 my %hash = $self->hash;
1832 $hash{_password} = '';
1833 new FS::svc_acct \%hash;
1836 =item check_password
1838 Checks the supplied password against the (possibly encrypted) password in the
1839 database. Returns true for a successful authentication, false for no match.
1841 Currently supported encryptions are: classic DES crypt() and MD5
1845 sub check_password {
1846 my($self, $check_password) = @_;
1848 #remove old-style SUSPENDED kludge, they should be allowed to login to
1849 #self-service and pay up
1850 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1852 #eventually should check a "password-encoding" field
1853 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1855 } elsif ( length($password) < 13 ) { #plaintext
1856 $check_password eq $password;
1857 } elsif ( length($password) == 13 ) { #traditional DES crypt
1858 crypt($check_password, $password) eq $password;
1859 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1860 unix_md5_crypt($check_password, $password) eq $password;
1861 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1862 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1863 $self->svcnum. "\n";
1866 warn "Can't check password: Unrecognized encryption for svcnum ".
1867 $self->svcnum. "\n";
1873 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1875 Returns an encrypted password, either by passing through an encrypted password
1876 in the database or by encrypting a plaintext password from the database.
1878 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1879 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1880 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1881 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1882 encryption type is only used if the password is not already encrypted in the
1887 sub crypt_password {
1889 #eventually should check a "password-encoding" field
1890 if ( length($self->_password) == 13
1891 || $self->_password =~ /^\$(1|2a?)\$/
1892 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1897 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1898 if ( $encryption eq 'crypt' ) {
1901 $saltset[int(rand(64))].$saltset[int(rand(64))]
1903 } elsif ( $encryption eq 'md5' ) {
1904 unix_md5_crypt( $self->_password );
1905 } elsif ( $encryption eq 'blowfish' ) {
1906 croak "unknown encryption method $encryption";
1908 croak "unknown encryption method $encryption";
1913 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
1915 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
1916 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
1917 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
1919 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
1920 to work the same as the B</crypt_password> method.
1926 #eventually should check a "password-encoding" field
1927 if ( length($self->_password) == 13 ) { #crypt
1928 return '{CRYPT}'. $self->_password;
1929 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
1931 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
1932 die "Blowfish encryption not supported in this context, svcnum ".
1933 $self->svcnum. "\n";
1934 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
1935 return '{SSHA}'. $1;
1936 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
1937 return '{NS-MTA-MD5}'. $1;
1939 return '{PLAIN}'. $self->_password;
1940 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1941 #if ( $encryption eq 'crypt' ) {
1942 # return '{CRYPT}'. crypt(
1944 # $saltset[int(rand(64))].$saltset[int(rand(64))]
1946 #} elsif ( $encryption eq 'md5' ) {
1947 # unix_md5_crypt( $self->_password );
1948 #} elsif ( $encryption eq 'blowfish' ) {
1949 # croak "unknown encryption method $encryption";
1951 # croak "unknown encryption method $encryption";
1956 =item domain_slash_username
1958 Returns $domain/$username/
1962 sub domain_slash_username {
1964 $self->domain. '/'. $self->username. '/';
1967 =item virtual_maildir
1969 Returns $domain/maildirs/$username/
1973 sub virtual_maildir {
1975 $self->domain. '/maildirs/'. $self->username. '/';
1986 This is the FS::svc_acct job-queue-able version. It still uses
1987 FS::Misc::send_email under-the-hood.
1994 eval "use FS::Misc qw(send_email)";
1997 $opt{mimetype} ||= 'text/plain';
1998 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2000 my $error = send_email(
2001 'from' => $opt{from},
2003 'subject' => $opt{subject},
2004 'content-type' => $opt{mimetype},
2005 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2007 die $error if $error;
2010 =item check_and_rebuild_fuzzyfiles
2014 sub check_and_rebuild_fuzzyfiles {
2015 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2016 -e "$dir/svc_acct.username"
2017 or &rebuild_fuzzyfiles;
2020 =item rebuild_fuzzyfiles
2024 sub rebuild_fuzzyfiles {
2026 use Fcntl qw(:flock);
2028 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2032 open(USERNAMELOCK,">>$dir/svc_acct.username")
2033 or die "can't open $dir/svc_acct.username: $!";
2034 flock(USERNAMELOCK,LOCK_EX)
2035 or die "can't lock $dir/svc_acct.username: $!";
2037 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2039 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2040 or die "can't open $dir/svc_acct.username.tmp: $!";
2041 print USERNAMECACHE join("\n", @all_username), "\n";
2042 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2044 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2054 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2055 open(USERNAMECACHE,"<$dir/svc_acct.username")
2056 or die "can't open $dir/svc_acct.username: $!";
2057 my @array = map { chomp; $_; } <USERNAMECACHE>;
2058 close USERNAMECACHE;
2062 =item append_fuzzyfiles USERNAME
2066 sub append_fuzzyfiles {
2067 my $username = shift;
2069 &check_and_rebuild_fuzzyfiles;
2071 use Fcntl qw(:flock);
2073 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2075 open(USERNAME,">>$dir/svc_acct.username")
2076 or die "can't open $dir/svc_acct.username: $!";
2077 flock(USERNAME,LOCK_EX)
2078 or die "can't lock $dir/svc_acct.username: $!";
2080 print USERNAME "$username\n";
2082 flock(USERNAME,LOCK_UN)
2083 or die "can't unlock $dir/svc_acct.username: $!";
2091 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2095 sub radius_usergroup_selector {
2096 my $sel_groups = shift;
2097 my %sel_groups = map { $_=>1 } @$sel_groups;
2099 my $selectname = shift || 'radius_usergroup';
2102 my $sth = $dbh->prepare(
2103 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2104 ) or die $dbh->errstr;
2105 $sth->execute() or die $sth->errstr;
2106 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2110 function ${selectname}_doadd(object) {
2111 var myvalue = object.${selectname}_add.value;
2112 var optionName = new Option(myvalue,myvalue,false,true);
2113 var length = object.$selectname.length;
2114 object.$selectname.options[length] = optionName;
2115 object.${selectname}_add.value = "";
2118 <SELECT MULTIPLE NAME="$selectname">
2121 foreach my $group ( @all_groups ) {
2122 $html .= qq(<OPTION VALUE="$group");
2123 if ( $sel_groups{$group} ) {
2124 $html .= ' SELECTED';
2125 $sel_groups{$group} = 0;
2127 $html .= ">$group</OPTION>\n";
2129 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2130 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2132 $html .= '</SELECT>';
2134 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2135 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2140 =item reached_threshold
2142 Performs some activities when svc_acct thresholds (such as number of seconds
2143 remaining) are reached.
2147 sub reached_threshold {
2150 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2151 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2153 if ( $opt{'op'} eq '+' ){
2154 $svc_acct->setfield( $opt{'column'}.'_threshold',
2155 int($svc_acct->getfield($opt{'column'})
2156 * ( $conf->exists('svc_acct-usage_threshold')
2157 ? $conf->config('svc_acct-usage_threshold')/100
2162 my $error = $svc_acct->replace;
2163 die $error if $error;
2164 }elsif ( $opt{'op'} eq '-' ){
2166 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2167 return '' if ($threshold eq '' );
2169 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2170 my $error = $svc_acct->replace;
2171 die $error if $error; # email next time, i guess
2173 if ( $warning_template ) {
2174 eval "use FS::Misc qw(send_email)";
2177 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2178 my $cust_main = $cust_pkg->cust_main;
2180 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2181 $cust_main->invoicing_list,
2183 ($opt{'to'} ? $opt{'to'} : ())
2186 my $mimetype = $warning_mimetype;
2187 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2189 my $body = $warning_template->fill_in( HASH => {
2190 'custnum' => $cust_main->custnum,
2191 'username' => $svc_acct->username,
2192 'password' => $svc_acct->_password,
2193 'first' => $cust_main->first,
2194 'last' => $cust_main->getfield('last'),
2195 'pkg' => $cust_pkg->part_pkg->pkg,
2196 'column' => $opt{'column'},
2197 'amount' => $svc_acct->getfield($opt{'column'}),
2198 'threshold' => $threshold,
2202 my $error = send_email(
2203 'from' => $warning_from,
2205 'subject' => $warning_subject,
2206 'content-type' => $mimetype,
2207 'body' => [ map "$_\n", split("\n", $body) ],
2209 die $error if $error;
2212 die "unknown op: " . $opt{'op'};
2220 The $recref stuff in sub check should be cleaned up.
2222 The suspend, unsuspend and cancel methods update the database, but not the
2223 current object. This is probably a bug as it's unexpected and
2226 radius_usergroup_selector? putting web ui components in here? they should
2227 probably live somewhere else...
2229 insertion of RADIUS group stuff in insert could be done with child_objects now
2230 (would probably clean up export of them too)
2234 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2235 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2236 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2237 L<freeside-queued>), L<FS::svc_acct_pop>,
2238 schema.html from the base documentation.