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
12 $welcome_subject $welcome_subject_template $welcome_mimetype
13 $warning_template $warning_from $warning_subject $warning_mimetype
16 $radius_password $radius_ip
22 use Crypt::PasswdMD5 1.2;
24 use FS::UID qw( datasrc driver_name );
26 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
27 use FS::Msgcat qw(gettext);
28 use FS::UI::bytecount;
33 use FS::cust_main_invoice;
37 use FS::radius_usergroup;
44 @ISA = qw( FS::svc_Common );
47 $me = '[FS::svc_acct]';
49 #ask FS::UID to run this stuff for us later
50 $FS::UID::callback{'FS::svc_acct'} = sub {
52 $dir_prefix = $conf->config('home');
53 @shells = $conf->config('shells');
54 $usernamemin = $conf->config('usernamemin') || 2;
55 $usernamemax = $conf->config('usernamemax');
56 $passwordmin = $conf->config('passwordmin') || 6;
57 $passwordmax = $conf->config('passwordmax') || 8;
58 $username_letter = $conf->exists('username-letter');
59 $username_letterfirst = $conf->exists('username-letterfirst');
60 $username_noperiod = $conf->exists('username-noperiod');
61 $username_nounderscore = $conf->exists('username-nounderscore');
62 $username_nodash = $conf->exists('username-nodash');
63 $username_uppercase = $conf->exists('username-uppercase');
64 $username_ampersand = $conf->exists('username-ampersand');
65 $username_percent = $conf->exists('username-percent');
66 $password_noampersand = $conf->exists('password-noexclamation');
67 $password_noexclamation = $conf->exists('password-noexclamation');
68 $dirhash = $conf->config('dirhash') || 0;
69 if ( $conf->exists('welcome_email') ) {
70 $welcome_template = new Text::Template (
72 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
73 ) or warn "can't create welcome email template: $Text::Template::ERROR";
74 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
75 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
76 $welcome_subject_template = new Text::Template (
78 SOURCE => $welcome_subject,
79 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
80 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
82 $welcome_template = '';
84 $welcome_subject = '';
85 $welcome_mimetype = '';
87 if ( $conf->exists('warning_email') ) {
88 $warning_template = new Text::Template (
90 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
91 ) or warn "can't create warning email template: $Text::Template::ERROR";
92 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
93 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
94 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
95 $warning_cc = $conf->config('warning_email-cc');
97 $warning_template = '';
99 $warning_subject = '';
100 $warning_mimetype = '';
103 $smtpmachine = $conf->config('smtpmachine');
104 $radius_password = $conf->config('radius-password') || 'Password';
105 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
106 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
109 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
110 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
114 my ( $hashref, $cache ) = @_;
115 if ( $hashref->{'svc_acct_svcnum'} ) {
116 $self->{'_domsvc'} = FS::svc_domain->new( {
117 'svcnum' => $hashref->{'domsvc'},
118 'domain' => $hashref->{'svc_acct_domain'},
119 'catchall' => $hashref->{'svc_acct_catchall'},
126 FS::svc_acct - Object methods for svc_acct records
132 $record = new FS::svc_acct \%hash;
133 $record = new FS::svc_acct { 'column' => 'value' };
135 $error = $record->insert;
137 $error = $new_record->replace($old_record);
139 $error = $record->delete;
141 $error = $record->check;
143 $error = $record->suspend;
145 $error = $record->unsuspend;
147 $error = $record->cancel;
149 %hash = $record->radius;
151 %hash = $record->radius_reply;
153 %hash = $record->radius_check;
155 $domain = $record->domain;
157 $svc_domain = $record->svc_domain;
159 $email = $record->email;
161 $seconds_since = $record->seconds_since($timestamp);
165 An FS::svc_acct object represents an account. FS::svc_acct inherits from
166 FS::svc_Common. The following fields are currently supported:
170 =item svcnum - primary key (assigned automatcially for new accounts)
174 =item _password - generated if blank
176 =item sec_phrase - security phrase
178 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
186 =item dir - set automatically if blank (and uid is not)
190 =item quota - (unimplementd)
192 =item slipip - IP address
202 =item domsvc - svcnum from svc_domain
204 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
206 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
216 Creates a new account. To add the account to the database, see L<"insert">.
223 'longname_plural' => 'Access accounts and mailboxes',
224 'sorts' => [ 'username', 'uid', 'last_login', ],
225 'display_weight' => 10,
226 'cancel_weight' => 50,
228 'dir' => 'Home directory',
231 def_label => 'UID (set to fixed and blank for no UIDs)',
234 'slipip' => 'IP address',
235 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
237 label => 'Access number',
239 select_table => 'svc_acct_pop',
240 select_key => 'popnum',
241 select_label => 'city',
247 disable_default => 1,
254 disable_inventory => 1,
257 '_password' => 'Password',
260 def_label => 'GID (when blank, defaults to UID)',
264 #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)',
266 def_label=> 'Shell (set to blank for no shell tracking)',
268 select_list => [ $conf->config('shells') ],
269 disable_inventory => 1,
272 'finger' => 'Real name (GECOS)',
275 #def_label => 'svcnum from svc_domain',
277 select_table => 'svc_domain',
278 select_key => 'svcnum',
279 select_label => 'domain',
280 disable_inventory => 1,
284 label => 'RADIUS groups',
285 type => 'radius_usergroup_selector',
286 disable_inventory => 1,
289 'seconds' => { label => 'Seconds',
291 disable_inventory => 1,
294 'upbytes' => { label => 'Upload',
296 disable_inventory => 1,
298 'format' => \&FS::UI::bytecount::display_bytecount,
299 'parse' => \&FS::UI::bytecount::parse_bytecount,
301 'downbytes' => { label => 'Download',
303 disable_inventory => 1,
305 'format' => \&FS::UI::bytecount::display_bytecount,
306 'parse' => \&FS::UI::bytecount::parse_bytecount,
308 'totalbytes'=> { label => 'Total up and download',
310 disable_inventory => 1,
312 'format' => \&FS::UI::bytecount::display_bytecount,
313 'parse' => \&FS::UI::bytecount::parse_bytecount,
315 'seconds_threshold' => { label => 'Seconds threshold',
317 disable_inventory => 1,
320 'upbytes_threshold' => { label => 'Upload threshold',
322 disable_inventory => 1,
324 'format' => \&FS::UI::bytecount::display_bytecount,
325 'parse' => \&FS::UI::bytecount::parse_bytecount,
327 'downbytes_threshold' => { label => 'Download threshold',
329 disable_inventory => 1,
331 'format' => \&FS::UI::bytecount::display_bytecount,
332 'parse' => \&FS::UI::bytecount::parse_bytecount,
334 'totalbytes_threshold'=> { label => 'Total up and download threshold',
336 disable_inventory => 1,
338 'format' => \&FS::UI::bytecount::display_bytecount,
339 'parse' => \&FS::UI::bytecount::parse_bytecount,
342 label => 'Last login',
346 label => 'Last logout',
353 sub table { 'svc_acct'; }
357 #false laziness with edit/svc_acct.cgi
359 my( $self, $groups ) = @_;
360 if ( ref($groups) eq 'ARRAY' ) {
362 } elsif ( length($groups) ) {
363 [ split(/\s*,\s*/, $groups) ];
372 shift->_lastlog('in', @_);
376 shift->_lastlog('out', @_);
380 my( $self, $op, $time ) = @_;
382 if ( defined($time) ) {
383 warn "$me last_log$op called on svcnum ". $self->svcnum.
384 ' ('. $self->email. "): $time\n"
387 local $SIG{HUP} = 'IGNORE';
388 local $SIG{INT} = 'IGNORE';
389 local $SIG{QUIT} = 'IGNORE';
390 local $SIG{TERM} = 'IGNORE';
391 local $SIG{TSTP} = 'IGNORE';
392 local $SIG{PIPE} = 'IGNORE';
394 my $oldAutoCommit = $FS::UID::AutoCommit;
395 local $FS::UID::AutoCommit = 0;
398 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
402 my $sth = $dbh->prepare( $sql )
403 or die "Error preparing $sql: ". $dbh->errstr;
404 my $rv = $sth->execute($time, $self->svcnum);
405 die "Error executing $sql: ". $sth->errstr
407 die "Can't update last_log$op for svcnum". $self->svcnum
410 warn "$me update successful; committing\n"
412 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
413 $self->{'Hash'}->{"last_log$op"} = $time;
415 $self->getfield("last_log$op");
419 =item search_sql STRING
421 Class method which returns an SQL fragment to search for the given string.
426 my( $class, $string ) = @_;
427 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
428 my( $username, $domain ) = ( $1, $2 );
429 my $q_username = dbh->quote($username);
430 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
432 "svc_acct.username = $q_username AND ( ".
433 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
438 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
440 $class->search_sql_field('slipip', $string ).
442 $class->search_sql_field('username', $string ).
445 $class->search_sql_field('username', $string);
449 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
451 Returns the "username@domain" string for this account.
453 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
465 =item insert [ , OPTION => VALUE ... ]
467 Adds this account to the database. If there is an error, returns the error,
468 otherwise returns false.
470 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
471 defined. An FS::cust_svc record will be created and inserted.
473 The additional field I<usergroup> can optionally be defined; if so it should
474 contain an arrayref of group names. See L<FS::radius_usergroup>.
476 The additional field I<child_objects> can optionally be defined; if so it
477 should contain an arrayref of FS::tablename objects. They will have their
478 svcnum fields set and will be inserted after this record, but before any
479 exports are run. Each element of the array can also optionally be a
480 two-element array reference containing the child object and the name of an
481 alternate field to be filled in with the newly-inserted svcnum, for example
482 C<[ $svc_forward, 'srcsvc' ]>
484 Currently available options are: I<depend_jobnum>
486 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
487 jobnums), all provisioning jobs will have a dependancy on the supplied
488 jobnum(s) (they will not run until the specific job(s) complete(s)).
490 (TODOC: L<FS::queue> and L<freeside-queued>)
492 (TODOC: new exports!)
501 warn "[$me] insert called on $self: ". Dumper($self).
502 "\nwith options: ". Dumper(%options);
505 local $SIG{HUP} = 'IGNORE';
506 local $SIG{INT} = 'IGNORE';
507 local $SIG{QUIT} = 'IGNORE';
508 local $SIG{TERM} = 'IGNORE';
509 local $SIG{TSTP} = 'IGNORE';
510 local $SIG{PIPE} = 'IGNORE';
512 my $oldAutoCommit = $FS::UID::AutoCommit;
513 local $FS::UID::AutoCommit = 0;
516 my $error = $self->check;
517 return $error if $error;
519 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
520 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
521 unless ( $cust_svc ) {
522 $dbh->rollback if $oldAutoCommit;
523 return "no cust_svc record found for svcnum ". $self->svcnum;
525 $self->pkgnum($cust_svc->pkgnum);
526 $self->svcpart($cust_svc->svcpart);
529 $error = $self->_check_duplicate;
531 $dbh->rollback if $oldAutoCommit;
536 $error = $self->SUPER::insert(
537 'jobnums' => \@jobnums,
538 'child_objects' => $self->child_objects,
542 $dbh->rollback if $oldAutoCommit;
546 if ( $self->usergroup ) {
547 foreach my $groupname ( @{$self->usergroup} ) {
548 my $radius_usergroup = new FS::radius_usergroup ( {
549 svcnum => $self->svcnum,
550 groupname => $groupname,
552 my $error = $radius_usergroup->insert;
554 $dbh->rollback if $oldAutoCommit;
560 unless ( $skip_fuzzyfiles ) {
561 $error = $self->queue_fuzzyfiles_update;
563 $dbh->rollback if $oldAutoCommit;
564 return "updating fuzzy search cache: $error";
568 my $cust_pkg = $self->cust_svc->cust_pkg;
571 my $cust_main = $cust_pkg->cust_main;
573 if ( $conf->exists('emailinvoiceautoalways')
574 || $conf->exists('emailinvoiceauto')
575 && ! $cust_main->invoicing_list_emailonly
577 my @invoicing_list = $cust_main->invoicing_list;
578 push @invoicing_list, $self->email;
579 $cust_main->invoicing_list(\@invoicing_list);
584 if ( $welcome_template && $cust_pkg ) {
585 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
589 'custnum' => $self->custnum,
590 'username' => $self->username,
591 'password' => $self->_password,
592 'first' => $cust_main->first,
593 'last' => $cust_main->getfield('last'),
594 'pkg' => $cust_pkg->part_pkg->pkg,
596 my $wqueue = new FS::queue {
597 'svcnum' => $self->svcnum,
598 'job' => 'FS::svc_acct::send_email'
600 my $error = $wqueue->insert(
602 'from' => $welcome_from,
603 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
604 'mimetype' => $welcome_mimetype,
605 'body' => $welcome_template->fill_in( HASH => \%hash, ),
608 $dbh->rollback if $oldAutoCommit;
609 return "error queuing welcome email: $error";
612 if ( $options{'depend_jobnum'} ) {
613 warn "$me depend_jobnum found; adding to welcome email dependancies"
615 if ( ref($options{'depend_jobnum'}) ) {
616 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
617 "to welcome email dependancies"
619 push @jobnums, @{ $options{'depend_jobnum'} };
621 warn "$me adding job $options{'depend_jobnum'} ".
622 "to welcome email dependancies"
624 push @jobnums, $options{'depend_jobnum'};
628 foreach my $jobnum ( @jobnums ) {
629 my $error = $wqueue->depend_insert($jobnum);
631 $dbh->rollback if $oldAutoCommit;
632 return "error queuing welcome email job dependancy: $error";
642 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
648 Deletes this account from the database. If there is an error, returns the
649 error, otherwise returns false.
651 The corresponding FS::cust_svc record will be deleted as well.
653 (TODOC: new exports!)
660 return "can't delete system account" if $self->_check_system;
662 return "Can't delete an account which is a (svc_forward) source!"
663 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
665 return "Can't delete an account which is a (svc_forward) destination!"
666 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
668 return "Can't delete an account with (svc_www) web service!"
669 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
671 # what about records in session ? (they should refer to history table)
673 local $SIG{HUP} = 'IGNORE';
674 local $SIG{INT} = 'IGNORE';
675 local $SIG{QUIT} = 'IGNORE';
676 local $SIG{TERM} = 'IGNORE';
677 local $SIG{TSTP} = 'IGNORE';
678 local $SIG{PIPE} = 'IGNORE';
680 my $oldAutoCommit = $FS::UID::AutoCommit;
681 local $FS::UID::AutoCommit = 0;
684 foreach my $cust_main_invoice (
685 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
687 unless ( defined($cust_main_invoice) ) {
688 warn "WARNING: something's wrong with qsearch";
691 my %hash = $cust_main_invoice->hash;
692 $hash{'dest'} = $self->email;
693 my $new = new FS::cust_main_invoice \%hash;
694 my $error = $new->replace($cust_main_invoice);
696 $dbh->rollback if $oldAutoCommit;
701 foreach my $svc_domain (
702 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
704 my %hash = new FS::svc_domain->hash;
705 $hash{'catchall'} = '';
706 my $new = new FS::svc_domain \%hash;
707 my $error = $new->replace($svc_domain);
709 $dbh->rollback if $oldAutoCommit;
714 my $error = $self->SUPER::delete;
716 $dbh->rollback if $oldAutoCommit;
720 foreach my $radius_usergroup (
721 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
723 my $error = $radius_usergroup->delete;
725 $dbh->rollback if $oldAutoCommit;
730 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
734 =item replace OLD_RECORD
736 Replaces OLD_RECORD with this one in the database. If there is an error,
737 returns the error, otherwise returns false.
739 The additional field I<usergroup> can optionally be defined; if so it should
740 contain an arrayref of group names. See L<FS::radius_usergroup>.
746 my ( $new, $old ) = ( shift, shift );
748 warn "$me replacing $old with $new\n" if $DEBUG;
750 # We absolutely have to have an old vs. new record to make this work.
751 if (!defined($old)) {
752 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
755 return "can't modify system account" if $old->_check_system;
758 #no warnings 'numeric'; #alas, a 5.006-ism
761 foreach my $xid (qw( uid gid )) {
763 return "Can't change $xid!"
764 if ! $conf->exists("svc_acct-edit_$xid")
765 && $old->$xid() != $new->$xid()
766 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
771 #change homdir when we change username
772 $new->setfield('dir', '') if $old->username ne $new->username;
774 local $SIG{HUP} = 'IGNORE';
775 local $SIG{INT} = 'IGNORE';
776 local $SIG{QUIT} = 'IGNORE';
777 local $SIG{TERM} = 'IGNORE';
778 local $SIG{TSTP} = 'IGNORE';
779 local $SIG{PIPE} = 'IGNORE';
781 my $oldAutoCommit = $FS::UID::AutoCommit;
782 local $FS::UID::AutoCommit = 0;
785 # redundant, but so $new->usergroup gets set
786 $error = $new->check;
787 return $error if $error;
789 $old->usergroup( [ $old->radius_groups ] );
791 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
792 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
794 if ( $new->usergroup ) {
795 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
796 my @newgroups = @{$new->usergroup};
797 foreach my $oldgroup ( @{$old->usergroup} ) {
798 if ( grep { $oldgroup eq $_ } @newgroups ) {
799 @newgroups = grep { $oldgroup ne $_ } @newgroups;
802 my $radius_usergroup = qsearchs('radius_usergroup', {
803 svcnum => $old->svcnum,
804 groupname => $oldgroup,
806 my $error = $radius_usergroup->delete;
808 $dbh->rollback if $oldAutoCommit;
809 return "error deleting radius_usergroup $oldgroup: $error";
813 foreach my $newgroup ( @newgroups ) {
814 my $radius_usergroup = new FS::radius_usergroup ( {
815 svcnum => $new->svcnum,
816 groupname => $newgroup,
818 my $error = $radius_usergroup->insert;
820 $dbh->rollback if $oldAutoCommit;
821 return "error adding radius_usergroup $newgroup: $error";
827 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
828 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
829 $error = $new->_check_duplicate;
831 $dbh->rollback if $oldAutoCommit;
836 $error = $new->SUPER::replace($old);
838 $dbh->rollback if $oldAutoCommit;
839 return $error if $error;
842 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
843 $error = $new->queue_fuzzyfiles_update;
845 $dbh->rollback if $oldAutoCommit;
846 return "updating fuzzy search cache: $error";
850 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
854 =item queue_fuzzyfiles_update
856 Used by insert & replace to update the fuzzy search cache
860 sub queue_fuzzyfiles_update {
863 local $SIG{HUP} = 'IGNORE';
864 local $SIG{INT} = 'IGNORE';
865 local $SIG{QUIT} = 'IGNORE';
866 local $SIG{TERM} = 'IGNORE';
867 local $SIG{TSTP} = 'IGNORE';
868 local $SIG{PIPE} = 'IGNORE';
870 my $oldAutoCommit = $FS::UID::AutoCommit;
871 local $FS::UID::AutoCommit = 0;
874 my $queue = new FS::queue {
875 'svcnum' => $self->svcnum,
876 'job' => 'FS::svc_acct::append_fuzzyfiles'
878 my $error = $queue->insert($self->username);
880 $dbh->rollback if $oldAutoCommit;
881 return "queueing job (transaction rolled back): $error";
884 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
892 Suspends this account by calling export-specific suspend hooks. If there is
893 an error, returns the error, otherwise returns false.
895 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
901 return "can't suspend system account" if $self->_check_system;
902 $self->SUPER::suspend;
907 Unsuspends this account by by calling export-specific suspend hooks. If there
908 is an error, returns the error, otherwise returns false.
910 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
916 my %hash = $self->hash;
917 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
918 $hash{_password} = $1;
919 my $new = new FS::svc_acct ( \%hash );
920 my $error = $new->replace($self);
921 return $error if $error;
924 $self->SUPER::unsuspend;
929 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
931 If the B<auto_unset_catchall> configuration option is set, this method will
932 automatically remove any references to the canceled service in the catchall
933 field of svc_domain. This allows packages that contain both a svc_domain and
934 its catchall svc_acct to be canceled in one step.
939 # Only one thing to do at this level
941 foreach my $svc_domain (
942 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
943 if($conf->exists('auto_unset_catchall')) {
944 my %hash = $svc_domain->hash;
945 $hash{catchall} = '';
946 my $new = new FS::svc_domain ( \%hash );
947 my $error = $new->replace($svc_domain);
948 return $error if $error;
950 return "cannot unprovision svc_acct #".$self->svcnum.
951 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
955 $self->SUPER::cancel;
961 Checks all fields to make sure this is a valid service. If there is an error,
962 returns the error, otherwise returns false. Called by the insert and replace
965 Sets any fixed values; see L<FS::part_svc>.
972 my($recref) = $self->hashref;
974 my $x = $self->setfixed( $self->_fieldhandlers );
975 return $x unless ref($x);
978 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
980 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
983 my $error = $self->ut_numbern('svcnum')
984 #|| $self->ut_number('domsvc')
985 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
986 || $self->ut_textn('sec_phrase')
987 || $self->ut_snumbern('seconds')
988 || $self->ut_snumbern('upbytes')
989 || $self->ut_snumbern('downbytes')
990 || $self->ut_snumbern('totalbytes')
992 return $error if $error;
994 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
995 if ( $username_uppercase ) {
996 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
997 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
998 $recref->{username} = $1;
1000 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
1001 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1002 $recref->{username} = $1;
1005 if ( $username_letterfirst ) {
1006 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1007 } elsif ( $username_letter ) {
1008 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1010 if ( $username_noperiod ) {
1011 $recref->{username} =~ /\./ and return gettext('illegal_username');
1013 if ( $username_nounderscore ) {
1014 $recref->{username} =~ /_/ and return gettext('illegal_username');
1016 if ( $username_nodash ) {
1017 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1019 unless ( $username_ampersand ) {
1020 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1022 if ( $password_noampersand ) {
1023 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1025 if ( $password_noexclamation ) {
1026 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1028 unless ( $username_percent ) {
1029 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1032 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1033 $recref->{popnum} = $1;
1034 return "Unknown popnum" unless
1035 ! $recref->{popnum} ||
1036 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1038 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1040 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1041 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1043 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1044 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1045 #not all systems use gid=uid
1046 #you can set a fixed gid in part_svc
1048 return "Only root can have uid 0"
1049 if $recref->{uid} == 0
1050 && $recref->{username} !~ /^(root|toor|smtp)$/;
1052 unless ( $recref->{username} eq 'sync' ) {
1053 if ( grep $_ eq $recref->{shell}, @shells ) {
1054 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1056 return "Illegal shell \`". $self->shell. "\'; ".
1057 $conf->dir. "/shells contains: @shells";
1060 $recref->{shell} = '/bin/sync';
1064 $recref->{gid} ne '' ?
1065 return "Can't have gid without uid" : ( $recref->{gid}='' );
1066 #$recref->{dir} ne '' ?
1067 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1068 $recref->{shell} ne '' ?
1069 return "Can't have shell without uid" : ( $recref->{shell}='' );
1072 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1074 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1075 or return "Illegal directory: ". $recref->{dir};
1076 $recref->{dir} = $1;
1077 return "Illegal directory"
1078 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1079 return "Illegal directory"
1080 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1081 unless ( $recref->{dir} ) {
1082 $recref->{dir} = $dir_prefix . '/';
1083 if ( $dirhash > 0 ) {
1084 for my $h ( 1 .. $dirhash ) {
1085 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1087 } elsif ( $dirhash < 0 ) {
1088 for my $h ( reverse $dirhash .. -1 ) {
1089 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1092 $recref->{dir} .= $recref->{username};
1098 # $error = $self->ut_textn('finger');
1099 # return $error if $error;
1100 if ( $self->getfield('finger') eq '' ) {
1101 my $cust_pkg = $self->svcnum
1102 ? $self->cust_svc->cust_pkg
1103 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1105 my $cust_main = $cust_pkg->cust_main;
1106 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1109 $self->getfield('finger') =~
1110 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1111 or return "Illegal finger: ". $self->getfield('finger');
1112 $self->setfield('finger', $1);
1114 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1115 $recref->{quota} = $1;
1117 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1118 if ( $recref->{slipip} eq '' ) {
1119 $recref->{slipip} = '';
1120 } elsif ( $recref->{slipip} eq '0e0' ) {
1121 $recref->{slipip} = '0e0';
1123 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1124 or return "Illegal slipip: ". $self->slipip;
1125 $recref->{slipip} = $1;
1130 #arbitrary RADIUS stuff; allow ut_textn for now
1131 foreach ( grep /^radius_/, fields('svc_acct') ) {
1132 $self->ut_textn($_);
1135 #generate a password if it is blank
1136 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1137 unless ( $recref->{_password} );
1139 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1140 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1141 $recref->{_password} = $1.$3;
1142 #uncomment this to encrypt password immediately upon entry, or run
1143 #bin/crypt_pw in cron to give new users a window during which their
1144 #password is available to techs, for faxing, etc. (also be aware of
1146 #$recref->{password} = $1.
1147 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
1149 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1150 $recref->{_password} = $1.$3;
1151 } elsif ( $recref->{_password} eq '*' ) {
1152 $recref->{_password} = '*';
1153 } elsif ( $recref->{_password} eq '!' ) {
1154 $recref->{_password} = '!';
1155 } elsif ( $recref->{_password} eq '!!' ) {
1156 $recref->{_password} = '!!';
1158 #return "Illegal password";
1159 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1160 FS::Msgcat::_gettext('illegal_password_characters').
1161 ": ". $recref->{_password};
1164 $self->SUPER::check;
1169 Internal function to check the username against the list of system usernames
1170 from the I<system_usernames> configuration value. Returns true if the username
1171 is listed on the system username list.
1177 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1178 $conf->config('system_usernames')
1182 =item _check_duplicate
1184 Internal function to check for duplicates usernames, username@domain pairs and
1187 If the I<global_unique-username> configuration value is set to B<username> or
1188 B<username@domain>, enforces global username or username@domain uniqueness.
1190 In all cases, check for duplicate uids and usernames or username@domain pairs
1191 per export and with identical I<svcpart> values.
1195 sub _check_duplicate {
1198 my $global_unique = $conf->config('global_unique-username') || 'none';
1199 return '' if $global_unique eq 'disabled';
1201 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1202 if ( driver_name =~ /^Pg/i ) {
1203 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1205 } elsif ( driver_name =~ /^mysql/i ) {
1206 dbh->do("SELECT * FROM duplicate_lock
1207 WHERE lockname = 'svc_acct'
1209 ) or die dbh->errstr;
1211 die "unknown database ". driver_name.
1212 "; don't know how to lock for duplicate search";
1214 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1216 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1217 unless ( $part_svc ) {
1218 return 'unknown svcpart '. $self->svcpart;
1221 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1222 qsearch( 'svc_acct', { 'username' => $self->username } );
1223 return gettext('username_in_use')
1224 if $global_unique eq 'username' && @dup_user;
1226 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1227 qsearch( 'svc_acct', { 'username' => $self->username,
1228 'domsvc' => $self->domsvc } );
1229 return gettext('username_in_use')
1230 if $global_unique eq 'username@domain' && @dup_userdomain;
1233 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1234 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1235 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1236 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1241 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1242 my $exports = FS::part_export::export_info('svc_acct');
1243 my %conflict_user_svcpart;
1244 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1246 foreach my $part_export ( $part_svc->part_export ) {
1248 #this will catch to the same exact export
1249 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1251 #this will catch to exports w/same exporthost+type ???
1252 #my @other_part_export = qsearch('part_export', {
1253 # 'machine' => $part_export->machine,
1254 # 'exporttype' => $part_export->exporttype,
1256 #foreach my $other_part_export ( @other_part_export ) {
1257 # push @svcparts, map { $_->svcpart }
1258 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1261 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1262 #silly kludge to avoid uninitialized value errors
1263 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1264 ? $exports->{$part_export->exporttype}{'nodomain'}
1266 if ( $nodomain =~ /^Y/i ) {
1267 $conflict_user_svcpart{$_} = $part_export->exportnum
1270 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1275 foreach my $dup_user ( @dup_user ) {
1276 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1277 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1278 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1279 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1283 foreach my $dup_userdomain ( @dup_userdomain ) {
1284 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1285 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1286 return "duplicate username\@domain: conflicts with svcnum ".
1287 $dup_userdomain->svcnum. " via exportnum ".
1288 $conflict_userdomain_svcpart{$dup_svcpart};
1292 foreach my $dup_uid ( @dup_uid ) {
1293 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1294 if ( exists($conflict_user_svcpart{$dup_svcpart})
1295 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1296 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1297 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1298 || $conflict_userdomain_svcpart{$dup_svcpart};
1310 Depriciated, use radius_reply instead.
1315 carp "FS::svc_acct::radius depriciated, use radius_reply";
1316 $_[0]->radius_reply;
1321 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1322 reply attributes of this record.
1324 Note that this is now the preferred method for reading RADIUS attributes -
1325 accessing the columns directly is discouraged, as the column names are
1326 expected to change in the future.
1333 return %{ $self->{'radius_reply'} }
1334 if exists $self->{'radius_reply'};
1339 my($column, $attrib) = ($1, $2);
1340 #$attrib =~ s/_/\-/g;
1341 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1342 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1344 if ( $self->slipip && $self->slipip ne '0e0' ) {
1345 $reply{$radius_ip} = $self->slipip;
1348 if ( $self->seconds !~ /^$/ ) {
1349 $reply{'Session-Timeout'} = $self->seconds;
1357 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1358 check attributes of this record.
1360 Note that this is now the preferred method for reading RADIUS attributes -
1361 accessing the columns directly is discouraged, as the column names are
1362 expected to change in the future.
1369 return %{ $self->{'radius_check'} }
1370 if exists $self->{'radius_check'};
1375 my($column, $attrib) = ($1, $2);
1376 #$attrib =~ s/_/\-/g;
1377 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1378 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1380 my $password = $self->_password;
1381 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1383 my $cust_svc = $self->cust_svc;
1384 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1386 my $cust_pkg = $cust_svc->cust_pkg;
1387 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1388 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1397 This method instructs the object to "snapshot" or freeze RADIUS check and
1398 reply attributes to the current values.
1402 #bah, my english is too broken this morning
1403 #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
1404 #the FS::cust_pkg's replace method to trigger the correct export updates when
1405 #package dates change)
1410 $self->{$_} = { $self->$_() }
1411 foreach qw( radius_reply radius_check );
1415 =item forget_snapshot
1417 This methos instructs the object to forget any previously snapshotted
1418 RADIUS check and reply attributes.
1422 sub forget_snapshot {
1426 foreach qw( radius_reply radius_check );
1430 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1432 Returns the domain associated with this account.
1434 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1441 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1442 my $svc_domain = $self->svc_domain(@_)
1443 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1444 $svc_domain->domain;
1449 Returns the FS::svc_domain record for this account's domain (see
1454 # FS::h_svc_acct has a history-aware svc_domain override
1459 ? $self->{'_domsvc'}
1460 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1465 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1469 #inherited from svc_Common
1471 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1473 Returns an email address associated with the account.
1475 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1482 $self->username. '@'. $self->domain(@_);
1487 Returns an array of FS::acct_snarf records associated with the account.
1488 If the acct_snarf table does not exist or there are no associated records,
1489 an empty list is returned
1495 return () unless dbdef->table('acct_snarf');
1496 eval "use FS::acct_snarf;";
1498 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1501 =item decrement_upbytes OCTETS
1503 Decrements the I<upbytes> field of this record by the given amount. If there
1504 is an error, returns the error, otherwise returns false.
1508 sub decrement_upbytes {
1509 shift->_op_usage('-', 'upbytes', @_);
1512 =item increment_upbytes OCTETS
1514 Increments the I<upbytes> field of this record by the given amount. If there
1515 is an error, returns the error, otherwise returns false.
1519 sub increment_upbytes {
1520 shift->_op_usage('+', 'upbytes', @_);
1523 =item decrement_downbytes OCTETS
1525 Decrements the I<downbytes> field of this record by the given amount. If there
1526 is an error, returns the error, otherwise returns false.
1530 sub decrement_downbytes {
1531 shift->_op_usage('-', 'downbytes', @_);
1534 =item increment_downbytes OCTETS
1536 Increments the I<downbytes> field of this record by the given amount. If there
1537 is an error, returns the error, otherwise returns false.
1541 sub increment_downbytes {
1542 shift->_op_usage('+', 'downbytes', @_);
1545 =item decrement_totalbytes OCTETS
1547 Decrements the I<totalbytes> field of this record by the given amount. If there
1548 is an error, returns the error, otherwise returns false.
1552 sub decrement_totalbytes {
1553 shift->_op_usage('-', 'totalbytes', @_);
1556 =item increment_totalbytes OCTETS
1558 Increments the I<totalbytes> field of this record by the given amount. If there
1559 is an error, returns the error, otherwise returns false.
1563 sub increment_totalbytes {
1564 shift->_op_usage('+', 'totalbytes', @_);
1567 =item decrement_seconds SECONDS
1569 Decrements the I<seconds> field of this record by the given amount. If there
1570 is an error, returns the error, otherwise returns false.
1574 sub decrement_seconds {
1575 shift->_op_usage('-', 'seconds', @_);
1578 =item increment_seconds SECONDS
1580 Increments the I<seconds> field of this record by the given amount. If there
1581 is an error, returns the error, otherwise returns false.
1585 sub increment_seconds {
1586 shift->_op_usage('+', 'seconds', @_);
1594 my %op2condition = (
1595 '-' => sub { my($self, $column, $amount) = @_;
1596 $self->$column - $amount <= 0;
1598 '+' => sub { my($self, $column, $amount) = @_;
1599 $self->$column + $amount > 0;
1602 my %op2warncondition = (
1603 '-' => sub { my($self, $column, $amount) = @_;
1604 my $threshold = $column . '_threshold';
1605 $self->$column - $amount <= $self->$threshold + 0;
1607 '+' => sub { my($self, $column, $amount) = @_;
1608 $self->$column + $amount > 0;
1613 my( $self, $op, $column, $amount ) = @_;
1615 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1616 ' ('. $self->email. "): $op $amount\n"
1619 return '' unless $amount;
1621 local $SIG{HUP} = 'IGNORE';
1622 local $SIG{INT} = 'IGNORE';
1623 local $SIG{QUIT} = 'IGNORE';
1624 local $SIG{TERM} = 'IGNORE';
1625 local $SIG{TSTP} = 'IGNORE';
1626 local $SIG{PIPE} = 'IGNORE';
1628 my $oldAutoCommit = $FS::UID::AutoCommit;
1629 local $FS::UID::AutoCommit = 0;
1632 my $sql = "UPDATE svc_acct SET $column = ".
1633 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1634 " $op ? WHERE svcnum = ?";
1638 my $sth = $dbh->prepare( $sql )
1639 or die "Error preparing $sql: ". $dbh->errstr;
1640 my $rv = $sth->execute($amount, $self->svcnum);
1641 die "Error executing $sql: ". $sth->errstr
1642 unless defined($rv);
1643 die "Can't update $column for svcnum". $self->svcnum
1646 my $action = $op2action{$op};
1648 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1649 ( $action eq 'suspend' && !$self->overlimit
1650 || $action eq 'unsuspend' && $self->overlimit )
1652 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1653 if ($part_export->option('overlimit_groups')) {
1655 my $other = new FS::svc_acct $self->hashref;
1656 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1657 ($self, $part_export->option('overlimit_groups'));
1658 $other->usergroup( $groups );
1659 if ($action eq 'suspend'){
1660 $new = $other; $old = $self;
1662 $new = $self; $old = $other;
1664 my $error = $part_export->export_replace($new, $old);
1665 $error ||= $self->overlimit($action);
1667 $dbh->rollback if $oldAutoCommit;
1668 return "Error replacing radius groups in export, ${op}: $error";
1674 if ( $conf->exists("svc_acct-usage_$action")
1675 && &{$op2condition{$op}}($self, $column, $amount) ) {
1676 #my $error = $self->$action();
1677 my $error = $self->cust_svc->cust_pkg->$action();
1678 # $error ||= $self->overlimit($action);
1680 $dbh->rollback if $oldAutoCommit;
1681 return "Error ${action}ing: $error";
1685 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1686 my $wqueue = new FS::queue {
1687 'svcnum' => $self->svcnum,
1688 'job' => 'FS::svc_acct::reached_threshold',
1693 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1697 my $error = $wqueue->insert(
1698 'svcnum' => $self->svcnum,
1700 'column' => $column,
1704 $dbh->rollback if $oldAutoCommit;
1705 return "Error queuing threshold activity: $error";
1709 warn "$me update successful; committing\n"
1711 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1717 my( $self, $valueref ) = @_;
1719 warn "$me set_usage called for svcnum ". $self->svcnum.
1720 ' ('. $self->email. "): ".
1721 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1724 local $SIG{HUP} = 'IGNORE';
1725 local $SIG{INT} = 'IGNORE';
1726 local $SIG{QUIT} = 'IGNORE';
1727 local $SIG{TERM} = 'IGNORE';
1728 local $SIG{TSTP} = 'IGNORE';
1729 local $SIG{PIPE} = 'IGNORE';
1731 local $FS::svc_Common::noexport_hack = 1;
1732 my $oldAutoCommit = $FS::UID::AutoCommit;
1733 local $FS::UID::AutoCommit = 0;
1738 foreach my $field (keys %$valueref){
1739 $reset = 1 if $valueref->{$field};
1740 $self->setfield($field, $valueref->{$field});
1741 $self->setfield( $field.'_threshold',
1742 int($self->getfield($field)
1743 * ( $conf->exists('svc_acct-usage_threshold')
1744 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1749 $handyhash{$field} = $self->getfield($field);
1750 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1752 #my $error = $self->replace; #NO! we avoid the call to ->check for
1753 #die $error if $error; #services not explicity changed via the UI
1755 my $sql = "UPDATE svc_acct SET " .
1756 join (',', map { "$_ = ?" } (keys %handyhash) ).
1757 " WHERE svcnum = ?";
1762 if (scalar(keys %handyhash)) {
1763 my $sth = $dbh->prepare( $sql )
1764 or die "Error preparing $sql: ". $dbh->errstr;
1765 my $rv = $sth->execute((values %handyhash), $self->svcnum);
1766 die "Error executing $sql: ". $sth->errstr
1767 unless defined($rv);
1768 die "Can't update usage for svcnum ". $self->svcnum
1775 if ($self->overlimit) {
1776 $error = $self->overlimit('unsuspend');
1777 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1778 if ($part_export->option('overlimit_groups')) {
1779 my $old = new FS::svc_acct $self->hashref;
1780 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1781 ($self, $part_export->option('overlimit_groups'));
1782 $old->usergroup( $groups );
1783 $error ||= $part_export->export_replace($self, $old);
1788 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1789 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1792 $dbh->rollback if $oldAutoCommit;
1793 return "Error unsuspending: $error";
1797 warn "$me update successful; committing\n"
1799 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1805 =item recharge HASHREF
1807 Increments usage columns by the amount specified in HASHREF as
1808 column=>amount pairs.
1813 my ($self, $vhash) = @_;
1816 warn "[$me] recharge called on $self: ". Dumper($self).
1817 "\nwith vhash: ". Dumper($vhash);
1820 my $oldAutoCommit = $FS::UID::AutoCommit;
1821 local $FS::UID::AutoCommit = 0;
1825 foreach my $column (keys %$vhash){
1826 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1830 $dbh->rollback if $oldAutoCommit;
1832 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1837 =item is_rechargeable
1839 Returns true if this svc_account can be "recharged" and false otherwise.
1843 sub is_rechargable {
1845 $self->seconds ne ''
1846 || $self->upbytes ne ''
1847 || $self->downbytes ne ''
1848 || $self->totalbytes ne '';
1851 =item seconds_since TIMESTAMP
1853 Returns the number of seconds this account has been online since TIMESTAMP,
1854 according to the session monitor (see L<FS::Session>).
1856 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1857 L<Time::Local> and L<Date::Parse> for conversion functions.
1861 #note: POD here, implementation in FS::cust_svc
1864 $self->cust_svc->seconds_since(@_);
1867 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1869 Returns the numbers of seconds this account has been online between
1870 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1871 external SQL radacct table, specified via sqlradius export. Sessions which
1872 started in the specified range but are still open are counted from session
1873 start to the end of the range (unless they are over 1 day old, in which case
1874 they are presumed missing their stop record and not counted). Also, sessions
1875 which end in the range but started earlier are counted from the start of the
1876 range to session end. Finally, sessions which start before the range but end
1877 after are counted for the entire range.
1879 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1880 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1885 #note: POD here, implementation in FS::cust_svc
1886 sub seconds_since_sqlradacct {
1888 $self->cust_svc->seconds_since_sqlradacct(@_);
1891 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1893 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1894 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1895 TIMESTAMP_END (exclusive).
1897 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1898 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1903 #note: POD here, implementation in FS::cust_svc
1904 sub attribute_since_sqlradacct {
1906 $self->cust_svc->attribute_since_sqlradacct(@_);
1909 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1911 Returns an array of hash references of this customers login history for the
1912 given time range. (document this better)
1916 sub get_session_history {
1918 $self->cust_svc->get_session_history(@_);
1921 =item last_login_text
1923 Returns text describing the time of last login.
1927 sub last_login_text {
1929 $self->last_login ? ctime($self->last_login) : 'unknown';
1932 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1937 my($self, $start, $end, %opt ) = @_;
1939 my $did = $self->username; #yup
1941 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1943 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1945 #SELECT $for_update * FROM cdr
1946 # WHERE calldate >= $start #need a conversion
1947 # AND calldate < $end #ditto
1948 # AND ( charged_party = "$did"
1949 # OR charged_party = "$prefix$did" #if length($prefix);
1950 # OR ( ( charged_party IS NULL OR charged_party = '' )
1952 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1955 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1958 if ( length($prefix) ) {
1960 " AND ( charged_party = '$did'
1961 OR charged_party = '$prefix$did'
1962 OR ( ( charged_party IS NULL OR charged_party = '' )
1964 ( src = '$did' OR src = '$prefix$did' )
1970 " AND ( charged_party = '$did'
1971 OR ( ( charged_party IS NULL OR charged_party = '' )
1981 'select' => "$for_update *",
1984 #( freesidestatus IS NULL OR freesidestatus = '' )
1985 'freesidestatus' => '',
1987 'extra_sql' => $charged_or_src,
1995 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2001 if ( $self->usergroup ) {
2002 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2003 unless ref($self->usergroup) eq 'ARRAY';
2004 #when provisioning records, export callback runs in svc_Common.pm before
2005 #radius_usergroup records can be inserted...
2006 @{$self->usergroup};
2008 map { $_->groupname }
2009 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2013 =item clone_suspended
2015 Constructor used by FS::part_export::_export_suspend fallback. Document
2020 sub clone_suspended {
2022 my %hash = $self->hash;
2023 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2024 new FS::svc_acct \%hash;
2027 =item clone_kludge_unsuspend
2029 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2034 sub clone_kludge_unsuspend {
2036 my %hash = $self->hash;
2037 $hash{_password} = '';
2038 new FS::svc_acct \%hash;
2041 =item check_password
2043 Checks the supplied password against the (possibly encrypted) password in the
2044 database. Returns true for a successful authentication, false for no match.
2046 Currently supported encryptions are: classic DES crypt() and MD5
2050 sub check_password {
2051 my($self, $check_password) = @_;
2053 #remove old-style SUSPENDED kludge, they should be allowed to login to
2054 #self-service and pay up
2055 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2057 #eventually should check a "password-encoding" field
2058 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2060 } elsif ( length($password) < 13 ) { #plaintext
2061 $check_password eq $password;
2062 } elsif ( length($password) == 13 ) { #traditional DES crypt
2063 crypt($check_password, $password) eq $password;
2064 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2065 unix_md5_crypt($check_password, $password) eq $password;
2066 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2067 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
2068 $self->svcnum. "\n";
2071 warn "Can't check password: Unrecognized encryption for svcnum ".
2072 $self->svcnum. "\n";
2078 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2080 Returns an encrypted password, either by passing through an encrypted password
2081 in the database or by encrypting a plaintext password from the database.
2083 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2084 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2085 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2086 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2087 encryption type is only used if the password is not already encrypted in the
2092 sub crypt_password {
2094 #eventually should check a "password-encoding" field
2095 if ( length($self->_password) == 13
2096 || $self->_password =~ /^\$(1|2a?)\$/
2097 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2102 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2103 if ( $encryption eq 'crypt' ) {
2106 $saltset[int(rand(64))].$saltset[int(rand(64))]
2108 } elsif ( $encryption eq 'md5' ) {
2109 unix_md5_crypt( $self->_password );
2110 } elsif ( $encryption eq 'blowfish' ) {
2111 croak "unknown encryption method $encryption";
2113 croak "unknown encryption method $encryption";
2118 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2120 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2121 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
2122 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
2124 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2125 to work the same as the B</crypt_password> method.
2131 #eventually should check a "password-encoding" field
2132 if ( length($self->_password) == 13 ) { #crypt
2133 return '{CRYPT}'. $self->_password;
2134 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2136 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2137 die "Blowfish encryption not supported in this context, svcnum ".
2138 $self->svcnum. "\n";
2139 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2140 return '{SSHA}'. $1;
2141 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2142 return '{NS-MTA-MD5}'. $1;
2144 return '{PLAIN}'. $self->_password;
2145 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2146 #if ( $encryption eq 'crypt' ) {
2147 # return '{CRYPT}'. crypt(
2149 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2151 #} elsif ( $encryption eq 'md5' ) {
2152 # unix_md5_crypt( $self->_password );
2153 #} elsif ( $encryption eq 'blowfish' ) {
2154 # croak "unknown encryption method $encryption";
2156 # croak "unknown encryption method $encryption";
2161 =item domain_slash_username
2163 Returns $domain/$username/
2167 sub domain_slash_username {
2169 $self->domain. '/'. $self->username. '/';
2172 =item virtual_maildir
2174 Returns $domain/maildirs/$username/
2178 sub virtual_maildir {
2180 $self->domain. '/maildirs/'. $self->username. '/';
2191 This is the FS::svc_acct job-queue-able version. It still uses
2192 FS::Misc::send_email under-the-hood.
2199 eval "use FS::Misc qw(send_email)";
2202 $opt{mimetype} ||= 'text/plain';
2203 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2205 my $error = send_email(
2206 'from' => $opt{from},
2208 'subject' => $opt{subject},
2209 'content-type' => $opt{mimetype},
2210 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2212 die $error if $error;
2215 =item check_and_rebuild_fuzzyfiles
2219 sub check_and_rebuild_fuzzyfiles {
2220 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2221 -e "$dir/svc_acct.username"
2222 or &rebuild_fuzzyfiles;
2225 =item rebuild_fuzzyfiles
2229 sub rebuild_fuzzyfiles {
2231 use Fcntl qw(:flock);
2233 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2237 open(USERNAMELOCK,">>$dir/svc_acct.username")
2238 or die "can't open $dir/svc_acct.username: $!";
2239 flock(USERNAMELOCK,LOCK_EX)
2240 or die "can't lock $dir/svc_acct.username: $!";
2242 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2244 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2245 or die "can't open $dir/svc_acct.username.tmp: $!";
2246 print USERNAMECACHE join("\n", @all_username), "\n";
2247 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2249 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2259 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2260 open(USERNAMECACHE,"<$dir/svc_acct.username")
2261 or die "can't open $dir/svc_acct.username: $!";
2262 my @array = map { chomp; $_; } <USERNAMECACHE>;
2263 close USERNAMECACHE;
2267 =item append_fuzzyfiles USERNAME
2271 sub append_fuzzyfiles {
2272 my $username = shift;
2274 &check_and_rebuild_fuzzyfiles;
2276 use Fcntl qw(:flock);
2278 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2280 open(USERNAME,">>$dir/svc_acct.username")
2281 or die "can't open $dir/svc_acct.username: $!";
2282 flock(USERNAME,LOCK_EX)
2283 or die "can't lock $dir/svc_acct.username: $!";
2285 print USERNAME "$username\n";
2287 flock(USERNAME,LOCK_UN)
2288 or die "can't unlock $dir/svc_acct.username: $!";
2296 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2300 sub radius_usergroup_selector {
2301 my $sel_groups = shift;
2302 my %sel_groups = map { $_=>1 } @$sel_groups;
2304 my $selectname = shift || 'radius_usergroup';
2307 my $sth = $dbh->prepare(
2308 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2309 ) or die $dbh->errstr;
2310 $sth->execute() or die $sth->errstr;
2311 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2315 function ${selectname}_doadd(object) {
2316 var myvalue = object.${selectname}_add.value;
2317 var optionName = new Option(myvalue,myvalue,false,true);
2318 var length = object.$selectname.length;
2319 object.$selectname.options[length] = optionName;
2320 object.${selectname}_add.value = "";
2323 <SELECT MULTIPLE NAME="$selectname">
2326 foreach my $group ( @all_groups ) {
2327 $html .= qq(<OPTION VALUE="$group");
2328 if ( $sel_groups{$group} ) {
2329 $html .= ' SELECTED';
2330 $sel_groups{$group} = 0;
2332 $html .= ">$group</OPTION>\n";
2334 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2335 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2337 $html .= '</SELECT>';
2339 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2340 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2345 =item reached_threshold
2347 Performs some activities when svc_acct thresholds (such as number of seconds
2348 remaining) are reached.
2352 sub reached_threshold {
2355 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2356 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2358 if ( $opt{'op'} eq '+' ){
2359 $svc_acct->setfield( $opt{'column'}.'_threshold',
2360 int($svc_acct->getfield($opt{'column'})
2361 * ( $conf->exists('svc_acct-usage_threshold')
2362 ? $conf->config('svc_acct-usage_threshold')/100
2367 my $error = $svc_acct->replace;
2368 die $error if $error;
2369 }elsif ( $opt{'op'} eq '-' ){
2371 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2372 return '' if ($threshold eq '' );
2374 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2375 my $error = $svc_acct->replace;
2376 die $error if $error; # email next time, i guess
2378 if ( $warning_template ) {
2379 eval "use FS::Misc qw(send_email)";
2382 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2383 my $cust_main = $cust_pkg->cust_main;
2385 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2386 $cust_main->invoicing_list,
2387 ($opt{'to'} ? $opt{'to'} : ())
2390 my $mimetype = $warning_mimetype;
2391 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2393 my $body = $warning_template->fill_in( HASH => {
2394 'custnum' => $cust_main->custnum,
2395 'username' => $svc_acct->username,
2396 'password' => $svc_acct->_password,
2397 'first' => $cust_main->first,
2398 'last' => $cust_main->getfield('last'),
2399 'pkg' => $cust_pkg->part_pkg->pkg,
2400 'column' => $opt{'column'},
2401 'amount' => $opt{'column'} =~/bytes/
2402 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2403 : $svc_acct->getfield($opt{'column'}),
2404 'threshold' => $opt{'column'} =~/bytes/
2405 ? FS::UI::bytecount::display_bytecount($threshold)
2410 my $error = send_email(
2411 'from' => $warning_from,
2413 'subject' => $warning_subject,
2414 'content-type' => $mimetype,
2415 'body' => [ map "$_\n", split("\n", $body) ],
2417 die $error if $error;
2420 die "unknown op: " . $opt{'op'};
2428 The $recref stuff in sub check should be cleaned up.
2430 The suspend, unsuspend and cancel methods update the database, but not the
2431 current object. This is probably a bug as it's unexpected and
2434 radius_usergroup_selector? putting web ui components in here? they should
2435 probably live somewhere else...
2437 insertion of RADIUS group stuff in insert could be done with child_objects now
2438 (would probably clean up export of them too)
2442 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2443 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2444 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2445 L<freeside-queued>), L<FS::svc_acct_pop>,
2446 schema.html from the base documentation.
2450 =item domain_select_hash %OPTIONS
2452 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2453 may at present purchase.
2455 Currently available options are: I<pkgnum> I<svcpart>
2459 sub domain_select_hash {
2460 my ($self, %options) = @_;
2466 $part_svc = $self->part_svc;
2467 $cust_pkg = $self->cust_svc->cust_pkg
2471 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2472 if $options{'svcpart'};
2474 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2475 if $options{'pkgnum'};
2477 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2478 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2479 %domains = map { $_->svcnum => $_->domain }
2480 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2481 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2482 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2483 %domains = map { $_->svcnum => $_->domain }
2484 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2485 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2486 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2488 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2491 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2492 my $svc_domain = qsearchs('svc_domain',
2493 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2494 if ( $svc_domain ) {
2495 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2497 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2498 $part_svc->part_svc_column('domsvc')->columnvalue;