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"
389 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
393 my $sth = $dbh->prepare( $sql )
394 or die "Error preparing $sql: ". $dbh->errstr;
395 my $rv = $sth->execute($time, $self->svcnum);
396 die "Error executing $sql: ". $sth->errstr
398 die "Can't update last_log$op for svcnum". $self->svcnum
401 $self->{'Hash'}->{"last_log$op"} = $time;
403 $self->getfield("last_log$op");
407 =item search_sql STRING
409 Class method which returns an SQL fragment to search for the given string.
414 my( $class, $string ) = @_;
415 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
416 my( $username, $domain ) = ( $1, $2 );
417 my $q_username = dbh->quote($username);
418 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
420 "svc_acct.username = $q_username AND ( ".
421 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
426 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
428 $class->search_sql_field('slipip', $string ).
430 $class->search_sql_field('username', $string ).
433 $class->search_sql_field('username', $string);
437 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
439 Returns the "username@domain" string for this account.
441 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
451 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
453 Returns a longer string label for this acccount ("Real Name <username@domain>"
454 if available, or "username@domain").
456 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
463 ( $self->finger =~ /\S/ )
464 ? $self->finger. ' <'.$self->label(@_).'>'
468 =item insert [ , OPTION => VALUE ... ]
470 Adds this account to the database. If there is an error, returns the error,
471 otherwise returns false.
473 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
474 defined. An FS::cust_svc record will be created and inserted.
476 The additional field I<usergroup> can optionally be defined; if so it should
477 contain an arrayref of group names. See L<FS::radius_usergroup>.
479 The additional field I<child_objects> can optionally be defined; if so it
480 should contain an arrayref of FS::tablename objects. They will have their
481 svcnum fields set and will be inserted after this record, but before any
482 exports are run. Each element of the array can also optionally be a
483 two-element array reference containing the child object and the name of an
484 alternate field to be filled in with the newly-inserted svcnum, for example
485 C<[ $svc_forward, 'srcsvc' ]>
487 Currently available options are: I<depend_jobnum>
489 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
490 jobnums), all provisioning jobs will have a dependancy on the supplied
491 jobnum(s) (they will not run until the specific job(s) complete(s)).
493 (TODOC: L<FS::queue> and L<freeside-queued>)
495 (TODOC: new exports!)
504 warn "[$me] insert called on $self: ". Dumper($self).
505 "\nwith options: ". Dumper(%options);
508 local $SIG{HUP} = 'IGNORE';
509 local $SIG{INT} = 'IGNORE';
510 local $SIG{QUIT} = 'IGNORE';
511 local $SIG{TERM} = 'IGNORE';
512 local $SIG{TSTP} = 'IGNORE';
513 local $SIG{PIPE} = 'IGNORE';
515 my $oldAutoCommit = $FS::UID::AutoCommit;
516 local $FS::UID::AutoCommit = 0;
519 my $error = $self->check;
520 return $error if $error;
522 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
523 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
524 unless ( $cust_svc ) {
525 $dbh->rollback if $oldAutoCommit;
526 return "no cust_svc record found for svcnum ". $self->svcnum;
528 $self->pkgnum($cust_svc->pkgnum);
529 $self->svcpart($cust_svc->svcpart);
532 $error = $self->_check_duplicate;
534 $dbh->rollback if $oldAutoCommit;
539 $error = $self->SUPER::insert(
540 'jobnums' => \@jobnums,
541 'child_objects' => $self->child_objects,
545 $dbh->rollback if $oldAutoCommit;
549 if ( $self->usergroup ) {
550 foreach my $groupname ( @{$self->usergroup} ) {
551 my $radius_usergroup = new FS::radius_usergroup ( {
552 svcnum => $self->svcnum,
553 groupname => $groupname,
555 my $error = $radius_usergroup->insert;
557 $dbh->rollback if $oldAutoCommit;
563 unless ( $skip_fuzzyfiles ) {
564 $error = $self->queue_fuzzyfiles_update;
566 $dbh->rollback if $oldAutoCommit;
567 return "updating fuzzy search cache: $error";
571 my $cust_pkg = $self->cust_svc->cust_pkg;
574 my $cust_main = $cust_pkg->cust_main;
576 if ( $conf->exists('emailinvoiceautoalways')
577 || $conf->exists('emailinvoiceauto')
578 && ! $cust_main->invoicing_list_emailonly
580 my @invoicing_list = $cust_main->invoicing_list;
581 push @invoicing_list, $self->email;
582 $cust_main->invoicing_list(\@invoicing_list);
587 if ( $welcome_template && $cust_pkg ) {
588 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
592 'custnum' => $self->custnum,
593 'username' => $self->username,
594 'password' => $self->_password,
595 'first' => $cust_main->first,
596 'last' => $cust_main->getfield('last'),
597 'pkg' => $cust_pkg->part_pkg->pkg,
599 my $wqueue = new FS::queue {
600 'svcnum' => $self->svcnum,
601 'job' => 'FS::svc_acct::send_email'
603 my $error = $wqueue->insert(
605 'from' => $welcome_from,
606 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
607 'mimetype' => $welcome_mimetype,
608 'body' => $welcome_template->fill_in( HASH => \%hash, ),
611 $dbh->rollback if $oldAutoCommit;
612 return "error queuing welcome email: $error";
615 if ( $options{'depend_jobnum'} ) {
616 warn "$me depend_jobnum found; adding to welcome email dependancies"
618 if ( ref($options{'depend_jobnum'}) ) {
619 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
620 "to welcome email dependancies"
622 push @jobnums, @{ $options{'depend_jobnum'} };
624 warn "$me adding job $options{'depend_jobnum'} ".
625 "to welcome email dependancies"
627 push @jobnums, $options{'depend_jobnum'};
631 foreach my $jobnum ( @jobnums ) {
632 my $error = $wqueue->depend_insert($jobnum);
634 $dbh->rollback if $oldAutoCommit;
635 return "error queuing welcome email job dependancy: $error";
645 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
651 Deletes this account from the database. If there is an error, returns the
652 error, otherwise returns false.
654 The corresponding FS::cust_svc record will be deleted as well.
656 (TODOC: new exports!)
663 return "can't delete system account" if $self->_check_system;
665 return "Can't delete an account which is a (svc_forward) source!"
666 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
668 return "Can't delete an account which is a (svc_forward) destination!"
669 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
671 return "Can't delete an account with (svc_www) web service!"
672 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
674 # what about records in session ? (they should refer to history table)
676 local $SIG{HUP} = 'IGNORE';
677 local $SIG{INT} = 'IGNORE';
678 local $SIG{QUIT} = 'IGNORE';
679 local $SIG{TERM} = 'IGNORE';
680 local $SIG{TSTP} = 'IGNORE';
681 local $SIG{PIPE} = 'IGNORE';
683 my $oldAutoCommit = $FS::UID::AutoCommit;
684 local $FS::UID::AutoCommit = 0;
687 foreach my $cust_main_invoice (
688 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
690 unless ( defined($cust_main_invoice) ) {
691 warn "WARNING: something's wrong with qsearch";
694 my %hash = $cust_main_invoice->hash;
695 $hash{'dest'} = $self->email;
696 my $new = new FS::cust_main_invoice \%hash;
697 my $error = $new->replace($cust_main_invoice);
699 $dbh->rollback if $oldAutoCommit;
704 foreach my $svc_domain (
705 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
707 my %hash = new FS::svc_domain->hash;
708 $hash{'catchall'} = '';
709 my $new = new FS::svc_domain \%hash;
710 my $error = $new->replace($svc_domain);
712 $dbh->rollback if $oldAutoCommit;
717 my $error = $self->SUPER::delete;
719 $dbh->rollback if $oldAutoCommit;
723 foreach my $radius_usergroup (
724 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
726 my $error = $radius_usergroup->delete;
728 $dbh->rollback if $oldAutoCommit;
733 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
737 =item replace OLD_RECORD
739 Replaces OLD_RECORD with this one in the database. If there is an error,
740 returns the error, otherwise returns false.
742 The additional field I<usergroup> can optionally be defined; if so it should
743 contain an arrayref of group names. See L<FS::radius_usergroup>.
749 my ( $new, $old ) = ( shift, shift );
751 warn "$me replacing $old with $new\n" if $DEBUG;
753 # We absolutely have to have an old vs. new record to make this work.
754 if (!defined($old)) {
755 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
758 return "can't modify system account" if $old->_check_system;
761 #no warnings 'numeric'; #alas, a 5.006-ism
764 foreach my $xid (qw( uid gid )) {
766 return "Can't change $xid!"
767 if ! $conf->exists("svc_acct-edit_$xid")
768 && $old->$xid() != $new->$xid()
769 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
774 #change homdir when we change username
775 $new->setfield('dir', '') if $old->username ne $new->username;
777 local $SIG{HUP} = 'IGNORE';
778 local $SIG{INT} = 'IGNORE';
779 local $SIG{QUIT} = 'IGNORE';
780 local $SIG{TERM} = 'IGNORE';
781 local $SIG{TSTP} = 'IGNORE';
782 local $SIG{PIPE} = 'IGNORE';
784 my $oldAutoCommit = $FS::UID::AutoCommit;
785 local $FS::UID::AutoCommit = 0;
788 # redundant, but so $new->usergroup gets set
789 $error = $new->check;
790 return $error if $error;
792 $old->usergroup( [ $old->radius_groups ] );
794 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
795 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
797 if ( $new->usergroup ) {
798 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
799 my @newgroups = @{$new->usergroup};
800 foreach my $oldgroup ( @{$old->usergroup} ) {
801 if ( grep { $oldgroup eq $_ } @newgroups ) {
802 @newgroups = grep { $oldgroup ne $_ } @newgroups;
805 my $radius_usergroup = qsearchs('radius_usergroup', {
806 svcnum => $old->svcnum,
807 groupname => $oldgroup,
809 my $error = $radius_usergroup->delete;
811 $dbh->rollback if $oldAutoCommit;
812 return "error deleting radius_usergroup $oldgroup: $error";
816 foreach my $newgroup ( @newgroups ) {
817 my $radius_usergroup = new FS::radius_usergroup ( {
818 svcnum => $new->svcnum,
819 groupname => $newgroup,
821 my $error = $radius_usergroup->insert;
823 $dbh->rollback if $oldAutoCommit;
824 return "error adding radius_usergroup $newgroup: $error";
830 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
831 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
832 $error = $new->_check_duplicate;
834 $dbh->rollback if $oldAutoCommit;
839 $error = $new->SUPER::replace($old);
841 $dbh->rollback if $oldAutoCommit;
842 return $error if $error;
845 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
846 $error = $new->queue_fuzzyfiles_update;
848 $dbh->rollback if $oldAutoCommit;
849 return "updating fuzzy search cache: $error";
853 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
857 =item queue_fuzzyfiles_update
859 Used by insert & replace to update the fuzzy search cache
863 sub queue_fuzzyfiles_update {
866 local $SIG{HUP} = 'IGNORE';
867 local $SIG{INT} = 'IGNORE';
868 local $SIG{QUIT} = 'IGNORE';
869 local $SIG{TERM} = 'IGNORE';
870 local $SIG{TSTP} = 'IGNORE';
871 local $SIG{PIPE} = 'IGNORE';
873 my $oldAutoCommit = $FS::UID::AutoCommit;
874 local $FS::UID::AutoCommit = 0;
877 my $queue = new FS::queue {
878 'svcnum' => $self->svcnum,
879 'job' => 'FS::svc_acct::append_fuzzyfiles'
881 my $error = $queue->insert($self->username);
883 $dbh->rollback if $oldAutoCommit;
884 return "queueing job (transaction rolled back): $error";
887 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
895 Suspends this account by calling export-specific suspend hooks. If there is
896 an error, returns the error, otherwise returns false.
898 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
904 return "can't suspend system account" if $self->_check_system;
905 $self->SUPER::suspend;
910 Unsuspends this account by by calling export-specific suspend hooks. If there
911 is an error, returns the error, otherwise returns false.
913 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
919 my %hash = $self->hash;
920 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
921 $hash{_password} = $1;
922 my $new = new FS::svc_acct ( \%hash );
923 my $error = $new->replace($self);
924 return $error if $error;
927 $self->SUPER::unsuspend;
932 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
934 If the B<auto_unset_catchall> configuration option is set, this method will
935 automatically remove any references to the canceled service in the catchall
936 field of svc_domain. This allows packages that contain both a svc_domain and
937 its catchall svc_acct to be canceled in one step.
942 # Only one thing to do at this level
944 foreach my $svc_domain (
945 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
946 if($conf->exists('auto_unset_catchall')) {
947 my %hash = $svc_domain->hash;
948 $hash{catchall} = '';
949 my $new = new FS::svc_domain ( \%hash );
950 my $error = $new->replace($svc_domain);
951 return $error if $error;
953 return "cannot unprovision svc_acct #".$self->svcnum.
954 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
958 $self->SUPER::cancel;
964 Checks all fields to make sure this is a valid service. If there is an error,
965 returns the error, otherwise returns false. Called by the insert and replace
968 Sets any fixed values; see L<FS::part_svc>.
975 my($recref) = $self->hashref;
977 my $x = $self->setfixed( $self->_fieldhandlers );
978 return $x unless ref($x);
981 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
983 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
986 my $error = $self->ut_numbern('svcnum')
987 #|| $self->ut_number('domsvc')
988 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
989 || $self->ut_textn('sec_phrase')
990 || $self->ut_snumbern('seconds')
991 || $self->ut_snumbern('upbytes')
992 || $self->ut_snumbern('downbytes')
993 || $self->ut_snumbern('totalbytes')
995 return $error if $error;
997 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
998 if ( $username_uppercase ) {
999 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
1000 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1001 $recref->{username} = $1;
1003 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
1004 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1005 $recref->{username} = $1;
1008 if ( $username_letterfirst ) {
1009 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1010 } elsif ( $username_letter ) {
1011 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1013 if ( $username_noperiod ) {
1014 $recref->{username} =~ /\./ and return gettext('illegal_username');
1016 if ( $username_nounderscore ) {
1017 $recref->{username} =~ /_/ and return gettext('illegal_username');
1019 if ( $username_nodash ) {
1020 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1022 unless ( $username_ampersand ) {
1023 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1025 if ( $password_noampersand ) {
1026 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1028 if ( $password_noexclamation ) {
1029 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1031 unless ( $username_percent ) {
1032 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1035 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1036 $recref->{popnum} = $1;
1037 return "Unknown popnum" unless
1038 ! $recref->{popnum} ||
1039 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1041 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1043 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1044 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1046 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1047 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1048 #not all systems use gid=uid
1049 #you can set a fixed gid in part_svc
1051 return "Only root can have uid 0"
1052 if $recref->{uid} == 0
1053 && $recref->{username} !~ /^(root|toor|smtp)$/;
1055 unless ( $recref->{username} eq 'sync' ) {
1056 if ( grep $_ eq $recref->{shell}, @shells ) {
1057 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1059 return "Illegal shell \`". $self->shell. "\'; ".
1060 $conf->dir. "/shells contains: @shells";
1063 $recref->{shell} = '/bin/sync';
1067 $recref->{gid} ne '' ?
1068 return "Can't have gid without uid" : ( $recref->{gid}='' );
1069 #$recref->{dir} ne '' ?
1070 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1071 $recref->{shell} ne '' ?
1072 return "Can't have shell without uid" : ( $recref->{shell}='' );
1075 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1077 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1078 or return "Illegal directory: ". $recref->{dir};
1079 $recref->{dir} = $1;
1080 return "Illegal directory"
1081 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1082 return "Illegal directory"
1083 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1084 unless ( $recref->{dir} ) {
1085 $recref->{dir} = $dir_prefix . '/';
1086 if ( $dirhash > 0 ) {
1087 for my $h ( 1 .. $dirhash ) {
1088 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1090 } elsif ( $dirhash < 0 ) {
1091 for my $h ( reverse $dirhash .. -1 ) {
1092 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1095 $recref->{dir} .= $recref->{username};
1101 # $error = $self->ut_textn('finger');
1102 # return $error if $error;
1103 if ( $self->getfield('finger') eq '' ) {
1104 my $cust_pkg = $self->svcnum
1105 ? $self->cust_svc->cust_pkg
1106 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1108 my $cust_main = $cust_pkg->cust_main;
1109 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1112 $self->getfield('finger') =~
1113 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1114 or return "Illegal finger: ". $self->getfield('finger');
1115 $self->setfield('finger', $1);
1117 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1118 $recref->{quota} = $1;
1120 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1121 if ( $recref->{slipip} eq '' ) {
1122 $recref->{slipip} = '';
1123 } elsif ( $recref->{slipip} eq '0e0' ) {
1124 $recref->{slipip} = '0e0';
1126 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1127 or return "Illegal slipip: ". $self->slipip;
1128 $recref->{slipip} = $1;
1133 #arbitrary RADIUS stuff; allow ut_textn for now
1134 foreach ( grep /^radius_/, fields('svc_acct') ) {
1135 $self->ut_textn($_);
1138 #generate a password if it is blank
1139 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1140 unless ( $recref->{_password} );
1142 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1143 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1144 $recref->{_password} = $1.$3;
1145 #uncomment this to encrypt password immediately upon entry, or run
1146 #bin/crypt_pw in cron to give new users a window during which their
1147 #password is available to techs, for faxing, etc. (also be aware of
1149 #$recref->{password} = $1.
1150 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
1152 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1153 $recref->{_password} = $1.$3;
1154 } elsif ( $recref->{_password} eq '*' ) {
1155 $recref->{_password} = '*';
1156 } elsif ( $recref->{_password} eq '!' ) {
1157 $recref->{_password} = '!';
1158 } elsif ( $recref->{_password} eq '!!' ) {
1159 $recref->{_password} = '!!';
1161 #return "Illegal password";
1162 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1163 FS::Msgcat::_gettext('illegal_password_characters').
1164 ": ". $recref->{_password};
1167 $self->SUPER::check;
1172 Internal function to check the username against the list of system usernames
1173 from the I<system_usernames> configuration value. Returns true if the username
1174 is listed on the system username list.
1180 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1181 $conf->config('system_usernames')
1185 =item _check_duplicate
1187 Internal function to check for duplicates usernames, username@domain pairs and
1190 If the I<global_unique-username> configuration value is set to B<username> or
1191 B<username@domain>, enforces global username or username@domain uniqueness.
1193 In all cases, check for duplicate uids and usernames or username@domain pairs
1194 per export and with identical I<svcpart> values.
1198 sub _check_duplicate {
1201 my $global_unique = $conf->config('global_unique-username') || 'none';
1202 return '' if $global_unique eq 'disabled';
1204 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1205 if ( driver_name =~ /^Pg/i ) {
1206 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1208 } elsif ( driver_name =~ /^mysql/i ) {
1209 dbh->do("SELECT * FROM duplicate_lock
1210 WHERE lockname = 'svc_acct'
1212 ) or die dbh->errstr;
1214 die "unknown database ". driver_name.
1215 "; don't know how to lock for duplicate search";
1217 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1219 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1220 unless ( $part_svc ) {
1221 return 'unknown svcpart '. $self->svcpart;
1224 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1225 qsearch( 'svc_acct', { 'username' => $self->username } );
1226 return gettext('username_in_use')
1227 if $global_unique eq 'username' && @dup_user;
1229 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1230 qsearch( 'svc_acct', { 'username' => $self->username,
1231 'domsvc' => $self->domsvc } );
1232 return gettext('username_in_use')
1233 if $global_unique eq 'username@domain' && @dup_userdomain;
1236 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1237 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1238 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1239 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1244 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1245 my $exports = FS::part_export::export_info('svc_acct');
1246 my %conflict_user_svcpart;
1247 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1249 foreach my $part_export ( $part_svc->part_export ) {
1251 #this will catch to the same exact export
1252 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1254 #this will catch to exports w/same exporthost+type ???
1255 #my @other_part_export = qsearch('part_export', {
1256 # 'machine' => $part_export->machine,
1257 # 'exporttype' => $part_export->exporttype,
1259 #foreach my $other_part_export ( @other_part_export ) {
1260 # push @svcparts, map { $_->svcpart }
1261 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1264 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1265 #silly kludge to avoid uninitialized value errors
1266 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1267 ? $exports->{$part_export->exporttype}{'nodomain'}
1269 if ( $nodomain =~ /^Y/i ) {
1270 $conflict_user_svcpart{$_} = $part_export->exportnum
1273 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1278 foreach my $dup_user ( @dup_user ) {
1279 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1280 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1281 return "duplicate username ". $self->username.
1282 ": conflicts with svcnum ". $dup_user->svcnum.
1283 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1287 foreach my $dup_userdomain ( @dup_userdomain ) {
1288 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1289 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1290 return "duplicate username\@domain ". $self->email.
1291 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1292 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1296 foreach my $dup_uid ( @dup_uid ) {
1297 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1298 if ( exists($conflict_user_svcpart{$dup_svcpart})
1299 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1300 return "duplicate uid ". $self->uid.
1301 ": conflicts with svcnum ". $dup_uid->svcnum.
1303 ( $conflict_user_svcpart{$dup_svcpart}
1304 || $conflict_userdomain_svcpart{$dup_svcpart} );
1316 Depriciated, use radius_reply instead.
1321 carp "FS::svc_acct::radius depriciated, use radius_reply";
1322 $_[0]->radius_reply;
1327 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1328 reply attributes of this record.
1330 Note that this is now the preferred method for reading RADIUS attributes -
1331 accessing the columns directly is discouraged, as the column names are
1332 expected to change in the future.
1339 return %{ $self->{'radius_reply'} }
1340 if exists $self->{'radius_reply'};
1345 my($column, $attrib) = ($1, $2);
1346 #$attrib =~ s/_/\-/g;
1347 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1348 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1350 if ( $self->slipip && $self->slipip ne '0e0' ) {
1351 $reply{$radius_ip} = $self->slipip;
1354 if ( $self->seconds !~ /^$/ ) {
1355 $reply{'Session-Timeout'} = $self->seconds;
1363 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1364 check attributes of this record.
1366 Note that this is now the preferred method for reading RADIUS attributes -
1367 accessing the columns directly is discouraged, as the column names are
1368 expected to change in the future.
1375 return %{ $self->{'radius_check'} }
1376 if exists $self->{'radius_check'};
1381 my($column, $attrib) = ($1, $2);
1382 #$attrib =~ s/_/\-/g;
1383 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1384 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1386 my $password = $self->_password;
1387 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1389 my $cust_svc = $self->cust_svc;
1390 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1392 my $cust_pkg = $cust_svc->cust_pkg;
1393 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1394 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1403 This method instructs the object to "snapshot" or freeze RADIUS check and
1404 reply attributes to the current values.
1408 #bah, my english is too broken this morning
1409 #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
1410 #the FS::cust_pkg's replace method to trigger the correct export updates when
1411 #package dates change)
1416 $self->{$_} = { $self->$_() }
1417 foreach qw( radius_reply radius_check );
1421 =item forget_snapshot
1423 This methos instructs the object to forget any previously snapshotted
1424 RADIUS check and reply attributes.
1428 sub forget_snapshot {
1432 foreach qw( radius_reply radius_check );
1436 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1438 Returns the domain associated with this account.
1440 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1447 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1448 my $svc_domain = $self->svc_domain(@_)
1449 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1450 $svc_domain->domain;
1455 Returns the FS::svc_domain record for this account's domain (see
1460 # FS::h_svc_acct has a history-aware svc_domain override
1465 ? $self->{'_domsvc'}
1466 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1471 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1475 #inherited from svc_Common
1477 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1479 Returns an email address associated with the account.
1481 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1488 $self->username. '@'. $self->domain(@_);
1493 Returns an array of FS::acct_snarf records associated with the account.
1494 If the acct_snarf table does not exist or there are no associated records,
1495 an empty list is returned
1501 return () unless dbdef->table('acct_snarf');
1502 eval "use FS::acct_snarf;";
1504 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1507 =item decrement_upbytes OCTETS
1509 Decrements the I<upbytes> field of this record by the given amount. If there
1510 is an error, returns the error, otherwise returns false.
1514 sub decrement_upbytes {
1515 shift->_op_usage('-', 'upbytes', @_);
1518 =item increment_upbytes OCTETS
1520 Increments the I<upbytes> field of this record by the given amount. If there
1521 is an error, returns the error, otherwise returns false.
1525 sub increment_upbytes {
1526 shift->_op_usage('+', 'upbytes', @_);
1529 =item decrement_downbytes OCTETS
1531 Decrements the I<downbytes> field of this record by the given amount. If there
1532 is an error, returns the error, otherwise returns false.
1536 sub decrement_downbytes {
1537 shift->_op_usage('-', 'downbytes', @_);
1540 =item increment_downbytes OCTETS
1542 Increments the I<downbytes> field of this record by the given amount. If there
1543 is an error, returns the error, otherwise returns false.
1547 sub increment_downbytes {
1548 shift->_op_usage('+', 'downbytes', @_);
1551 =item decrement_totalbytes OCTETS
1553 Decrements the I<totalbytes> field of this record by the given amount. If there
1554 is an error, returns the error, otherwise returns false.
1558 sub decrement_totalbytes {
1559 shift->_op_usage('-', 'totalbytes', @_);
1562 =item increment_totalbytes OCTETS
1564 Increments the I<totalbytes> field of this record by the given amount. If there
1565 is an error, returns the error, otherwise returns false.
1569 sub increment_totalbytes {
1570 shift->_op_usage('+', 'totalbytes', @_);
1573 =item decrement_seconds SECONDS
1575 Decrements the I<seconds> field of this record by the given amount. If there
1576 is an error, returns the error, otherwise returns false.
1580 sub decrement_seconds {
1581 shift->_op_usage('-', 'seconds', @_);
1584 =item increment_seconds SECONDS
1586 Increments the I<seconds> field of this record by the given amount. If there
1587 is an error, returns the error, otherwise returns false.
1591 sub increment_seconds {
1592 shift->_op_usage('+', 'seconds', @_);
1600 my %op2condition = (
1601 '-' => sub { my($self, $column, $amount) = @_;
1602 $self->$column - $amount <= 0;
1604 '+' => sub { my($self, $column, $amount) = @_;
1605 $self->$column + $amount > 0;
1608 my %op2warncondition = (
1609 '-' => sub { my($self, $column, $amount) = @_;
1610 my $threshold = $column . '_threshold';
1611 $self->$column - $amount <= $self->$threshold + 0;
1613 '+' => sub { my($self, $column, $amount) = @_;
1614 $self->$column + $amount > 0;
1619 my( $self, $op, $column, $amount ) = @_;
1621 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1622 ' ('. $self->email. "): $op $amount\n"
1625 return '' unless $amount;
1627 local $SIG{HUP} = 'IGNORE';
1628 local $SIG{INT} = 'IGNORE';
1629 local $SIG{QUIT} = 'IGNORE';
1630 local $SIG{TERM} = 'IGNORE';
1631 local $SIG{TSTP} = 'IGNORE';
1632 local $SIG{PIPE} = 'IGNORE';
1634 my $oldAutoCommit = $FS::UID::AutoCommit;
1635 local $FS::UID::AutoCommit = 0;
1638 my $sql = "UPDATE svc_acct SET $column = ".
1639 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1640 " $op ? WHERE svcnum = ?";
1644 my $sth = $dbh->prepare( $sql )
1645 or die "Error preparing $sql: ". $dbh->errstr;
1646 my $rv = $sth->execute($amount, $self->svcnum);
1647 die "Error executing $sql: ". $sth->errstr
1648 unless defined($rv);
1649 die "Can't update $column for svcnum". $self->svcnum
1652 my $action = $op2action{$op};
1654 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1655 ( $action eq 'suspend' && !$self->overlimit
1656 || $action eq 'unsuspend' && $self->overlimit )
1658 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1659 if ($part_export->option('overlimit_groups')) {
1661 my $other = new FS::svc_acct $self->hashref;
1662 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1663 ($self, $part_export->option('overlimit_groups'));
1664 $other->usergroup( $groups );
1665 if ($action eq 'suspend'){
1666 $new = $other; $old = $self;
1668 $new = $self; $old = $other;
1670 my $error = $part_export->export_replace($new, $old);
1671 $error ||= $self->overlimit($action);
1673 $dbh->rollback if $oldAutoCommit;
1674 return "Error replacing radius groups in export, ${op}: $error";
1680 if ( $conf->exists("svc_acct-usage_$action")
1681 && &{$op2condition{$op}}($self, $column, $amount) ) {
1682 #my $error = $self->$action();
1683 my $error = $self->cust_svc->cust_pkg->$action();
1684 # $error ||= $self->overlimit($action);
1686 $dbh->rollback if $oldAutoCommit;
1687 return "Error ${action}ing: $error";
1691 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1692 my $wqueue = new FS::queue {
1693 'svcnum' => $self->svcnum,
1694 'job' => 'FS::svc_acct::reached_threshold',
1699 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1703 my $error = $wqueue->insert(
1704 'svcnum' => $self->svcnum,
1706 'column' => $column,
1710 $dbh->rollback if $oldAutoCommit;
1711 return "Error queuing threshold activity: $error";
1715 warn "$me update successful; committing\n"
1717 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1723 my( $self, $valueref ) = @_;
1725 warn "$me set_usage called for svcnum ". $self->svcnum.
1726 ' ('. $self->email. "): ".
1727 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1730 local $SIG{HUP} = 'IGNORE';
1731 local $SIG{INT} = 'IGNORE';
1732 local $SIG{QUIT} = 'IGNORE';
1733 local $SIG{TERM} = 'IGNORE';
1734 local $SIG{TSTP} = 'IGNORE';
1735 local $SIG{PIPE} = 'IGNORE';
1737 local $FS::svc_Common::noexport_hack = 1;
1738 my $oldAutoCommit = $FS::UID::AutoCommit;
1739 local $FS::UID::AutoCommit = 0;
1744 foreach my $field (keys %$valueref){
1745 $reset = 1 if $valueref->{$field};
1746 $self->setfield($field, $valueref->{$field});
1747 $self->setfield( $field.'_threshold',
1748 int($self->getfield($field)
1749 * ( $conf->exists('svc_acct-usage_threshold')
1750 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1755 $handyhash{$field} = $self->getfield($field);
1756 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1758 #my $error = $self->replace; #NO! we avoid the call to ->check for
1759 #die $error if $error; #services not explicity changed via the UI
1761 my $sql = "UPDATE svc_acct SET " .
1762 join (',', map { "$_ = ?" } (keys %handyhash) ).
1763 " WHERE svcnum = ?";
1768 if (scalar(keys %handyhash)) {
1769 my $sth = $dbh->prepare( $sql )
1770 or die "Error preparing $sql: ". $dbh->errstr;
1771 my $rv = $sth->execute((values %handyhash), $self->svcnum);
1772 die "Error executing $sql: ". $sth->errstr
1773 unless defined($rv);
1774 die "Can't update usage for svcnum ". $self->svcnum
1781 if ($self->overlimit) {
1782 $error = $self->overlimit('unsuspend');
1783 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1784 if ($part_export->option('overlimit_groups')) {
1785 my $old = new FS::svc_acct $self->hashref;
1786 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1787 ($self, $part_export->option('overlimit_groups'));
1788 $old->usergroup( $groups );
1789 $error ||= $part_export->export_replace($self, $old);
1794 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1795 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1798 $dbh->rollback if $oldAutoCommit;
1799 return "Error unsuspending: $error";
1803 warn "$me update successful; committing\n"
1805 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1811 =item recharge HASHREF
1813 Increments usage columns by the amount specified in HASHREF as
1814 column=>amount pairs.
1819 my ($self, $vhash) = @_;
1822 warn "[$me] recharge called on $self: ". Dumper($self).
1823 "\nwith vhash: ". Dumper($vhash);
1826 my $oldAutoCommit = $FS::UID::AutoCommit;
1827 local $FS::UID::AutoCommit = 0;
1831 foreach my $column (keys %$vhash){
1832 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1836 $dbh->rollback if $oldAutoCommit;
1838 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1843 =item is_rechargeable
1845 Returns true if this svc_account can be "recharged" and false otherwise.
1849 sub is_rechargable {
1851 $self->seconds ne ''
1852 || $self->upbytes ne ''
1853 || $self->downbytes ne ''
1854 || $self->totalbytes ne '';
1857 =item seconds_since TIMESTAMP
1859 Returns the number of seconds this account has been online since TIMESTAMP,
1860 according to the session monitor (see L<FS::Session>).
1862 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1863 L<Time::Local> and L<Date::Parse> for conversion functions.
1867 #note: POD here, implementation in FS::cust_svc
1870 $self->cust_svc->seconds_since(@_);
1873 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1875 Returns the numbers of seconds this account has been online between
1876 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1877 external SQL radacct table, specified via sqlradius export. Sessions which
1878 started in the specified range but are still open are counted from session
1879 start to the end of the range (unless they are over 1 day old, in which case
1880 they are presumed missing their stop record and not counted). Also, sessions
1881 which end in the range but started earlier are counted from the start of the
1882 range to session end. Finally, sessions which start before the range but end
1883 after are counted for the entire range.
1885 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1886 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1891 #note: POD here, implementation in FS::cust_svc
1892 sub seconds_since_sqlradacct {
1894 $self->cust_svc->seconds_since_sqlradacct(@_);
1897 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1899 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1900 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1901 TIMESTAMP_END (exclusive).
1903 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1904 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1909 #note: POD here, implementation in FS::cust_svc
1910 sub attribute_since_sqlradacct {
1912 $self->cust_svc->attribute_since_sqlradacct(@_);
1915 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1917 Returns an array of hash references of this customers login history for the
1918 given time range. (document this better)
1922 sub get_session_history {
1924 $self->cust_svc->get_session_history(@_);
1927 =item last_login_text
1929 Returns text describing the time of last login.
1933 sub last_login_text {
1935 $self->last_login ? ctime($self->last_login) : 'unknown';
1938 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1943 my($self, $start, $end, %opt ) = @_;
1945 my $did = $self->username; #yup
1947 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1949 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1951 #SELECT $for_update * FROM cdr
1952 # WHERE calldate >= $start #need a conversion
1953 # AND calldate < $end #ditto
1954 # AND ( charged_party = "$did"
1955 # OR charged_party = "$prefix$did" #if length($prefix);
1956 # OR ( ( charged_party IS NULL OR charged_party = '' )
1958 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1961 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1964 if ( length($prefix) ) {
1966 " AND ( charged_party = '$did'
1967 OR charged_party = '$prefix$did'
1968 OR ( ( charged_party IS NULL OR charged_party = '' )
1970 ( src = '$did' OR src = '$prefix$did' )
1976 " AND ( charged_party = '$did'
1977 OR ( ( charged_party IS NULL OR charged_party = '' )
1987 'select' => "$for_update *",
1990 #( freesidestatus IS NULL OR freesidestatus = '' )
1991 'freesidestatus' => '',
1993 'extra_sql' => $charged_or_src,
2001 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2007 if ( $self->usergroup ) {
2008 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2009 unless ref($self->usergroup) eq 'ARRAY';
2010 #when provisioning records, export callback runs in svc_Common.pm before
2011 #radius_usergroup records can be inserted...
2012 @{$self->usergroup};
2014 map { $_->groupname }
2015 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2019 =item clone_suspended
2021 Constructor used by FS::part_export::_export_suspend fallback. Document
2026 sub clone_suspended {
2028 my %hash = $self->hash;
2029 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2030 new FS::svc_acct \%hash;
2033 =item clone_kludge_unsuspend
2035 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2040 sub clone_kludge_unsuspend {
2042 my %hash = $self->hash;
2043 $hash{_password} = '';
2044 new FS::svc_acct \%hash;
2047 =item check_password
2049 Checks the supplied password against the (possibly encrypted) password in the
2050 database. Returns true for a successful authentication, false for no match.
2052 Currently supported encryptions are: classic DES crypt() and MD5
2056 sub check_password {
2057 my($self, $check_password) = @_;
2059 #remove old-style SUSPENDED kludge, they should be allowed to login to
2060 #self-service and pay up
2061 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2063 #eventually should check a "password-encoding" field
2064 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2066 } elsif ( length($password) < 13 ) { #plaintext
2067 $check_password eq $password;
2068 } elsif ( length($password) == 13 ) { #traditional DES crypt
2069 crypt($check_password, $password) eq $password;
2070 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2071 unix_md5_crypt($check_password, $password) eq $password;
2072 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2073 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
2074 $self->svcnum. "\n";
2077 warn "Can't check password: Unrecognized encryption for svcnum ".
2078 $self->svcnum. "\n";
2084 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2086 Returns an encrypted password, either by passing through an encrypted password
2087 in the database or by encrypting a plaintext password from the database.
2089 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2090 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2091 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2092 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2093 encryption type is only used if the password is not already encrypted in the
2098 sub crypt_password {
2100 #eventually should check a "password-encoding" field
2101 if ( length($self->_password) == 13
2102 || $self->_password =~ /^\$(1|2a?)\$/
2103 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2108 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2109 if ( $encryption eq 'crypt' ) {
2112 $saltset[int(rand(64))].$saltset[int(rand(64))]
2114 } elsif ( $encryption eq 'md5' ) {
2115 unix_md5_crypt( $self->_password );
2116 } elsif ( $encryption eq 'blowfish' ) {
2117 croak "unknown encryption method $encryption";
2119 croak "unknown encryption method $encryption";
2124 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2126 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2127 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
2128 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
2130 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2131 to work the same as the B</crypt_password> method.
2137 #eventually should check a "password-encoding" field
2138 if ( length($self->_password) == 13 ) { #crypt
2139 return '{CRYPT}'. $self->_password;
2140 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2142 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2143 warn "Blowfish encryption not supported in this context, svcnum ".
2144 $self->svcnum. "\n";
2145 return '{CRYPT}*'; #unsupported, should not auth
2146 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2147 return '{SSHA}'. $1;
2148 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2149 return '{NS-MTA-MD5}'. $1;
2151 return '{PLAIN}'. $self->_password;
2152 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2153 #if ( $encryption eq 'crypt' ) {
2154 # return '{CRYPT}'. crypt(
2156 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2158 #} elsif ( $encryption eq 'md5' ) {
2159 # unix_md5_crypt( $self->_password );
2160 #} elsif ( $encryption eq 'blowfish' ) {
2161 # croak "unknown encryption method $encryption";
2163 # croak "unknown encryption method $encryption";
2168 =item domain_slash_username
2170 Returns $domain/$username/
2174 sub domain_slash_username {
2176 $self->domain. '/'. $self->username. '/';
2179 =item virtual_maildir
2181 Returns $domain/maildirs/$username/
2185 sub virtual_maildir {
2187 $self->domain. '/maildirs/'. $self->username. '/';
2198 This is the FS::svc_acct job-queue-able version. It still uses
2199 FS::Misc::send_email under-the-hood.
2206 eval "use FS::Misc qw(send_email)";
2209 $opt{mimetype} ||= 'text/plain';
2210 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2212 my $error = send_email(
2213 'from' => $opt{from},
2215 'subject' => $opt{subject},
2216 'content-type' => $opt{mimetype},
2217 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2219 die $error if $error;
2222 =item check_and_rebuild_fuzzyfiles
2226 sub check_and_rebuild_fuzzyfiles {
2227 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2228 -e "$dir/svc_acct.username"
2229 or &rebuild_fuzzyfiles;
2232 =item rebuild_fuzzyfiles
2236 sub rebuild_fuzzyfiles {
2238 use Fcntl qw(:flock);
2240 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2244 open(USERNAMELOCK,">>$dir/svc_acct.username")
2245 or die "can't open $dir/svc_acct.username: $!";
2246 flock(USERNAMELOCK,LOCK_EX)
2247 or die "can't lock $dir/svc_acct.username: $!";
2249 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2251 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2252 or die "can't open $dir/svc_acct.username.tmp: $!";
2253 print USERNAMECACHE join("\n", @all_username), "\n";
2254 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2256 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2266 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2267 open(USERNAMECACHE,"<$dir/svc_acct.username")
2268 or die "can't open $dir/svc_acct.username: $!";
2269 my @array = map { chomp; $_; } <USERNAMECACHE>;
2270 close USERNAMECACHE;
2274 =item append_fuzzyfiles USERNAME
2278 sub append_fuzzyfiles {
2279 my $username = shift;
2281 &check_and_rebuild_fuzzyfiles;
2283 use Fcntl qw(:flock);
2285 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2287 open(USERNAME,">>$dir/svc_acct.username")
2288 or die "can't open $dir/svc_acct.username: $!";
2289 flock(USERNAME,LOCK_EX)
2290 or die "can't lock $dir/svc_acct.username: $!";
2292 print USERNAME "$username\n";
2294 flock(USERNAME,LOCK_UN)
2295 or die "can't unlock $dir/svc_acct.username: $!";
2303 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2307 sub radius_usergroup_selector {
2308 my $sel_groups = shift;
2309 my %sel_groups = map { $_=>1 } @$sel_groups;
2311 my $selectname = shift || 'radius_usergroup';
2314 my $sth = $dbh->prepare(
2315 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2316 ) or die $dbh->errstr;
2317 $sth->execute() or die $sth->errstr;
2318 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2322 function ${selectname}_doadd(object) {
2323 var myvalue = object.${selectname}_add.value;
2324 var optionName = new Option(myvalue,myvalue,false,true);
2325 var length = object.$selectname.length;
2326 object.$selectname.options[length] = optionName;
2327 object.${selectname}_add.value = "";
2330 <SELECT MULTIPLE NAME="$selectname">
2333 foreach my $group ( @all_groups ) {
2334 $html .= qq(<OPTION VALUE="$group");
2335 if ( $sel_groups{$group} ) {
2336 $html .= ' SELECTED';
2337 $sel_groups{$group} = 0;
2339 $html .= ">$group</OPTION>\n";
2341 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2342 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2344 $html .= '</SELECT>';
2346 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2347 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2352 =item reached_threshold
2354 Performs some activities when svc_acct thresholds (such as number of seconds
2355 remaining) are reached.
2359 sub reached_threshold {
2362 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2363 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2365 if ( $opt{'op'} eq '+' ){
2366 $svc_acct->setfield( $opt{'column'}.'_threshold',
2367 int($svc_acct->getfield($opt{'column'})
2368 * ( $conf->exists('svc_acct-usage_threshold')
2369 ? $conf->config('svc_acct-usage_threshold')/100
2374 my $error = $svc_acct->replace;
2375 die $error if $error;
2376 }elsif ( $opt{'op'} eq '-' ){
2378 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2379 return '' if ($threshold eq '' );
2381 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2382 my $error = $svc_acct->replace;
2383 die $error if $error; # email next time, i guess
2385 if ( $warning_template ) {
2386 eval "use FS::Misc qw(send_email)";
2389 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2390 my $cust_main = $cust_pkg->cust_main;
2392 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2393 $cust_main->invoicing_list,
2394 ($opt{'to'} ? $opt{'to'} : ())
2397 my $mimetype = $warning_mimetype;
2398 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2400 my $body = $warning_template->fill_in( HASH => {
2401 'custnum' => $cust_main->custnum,
2402 'username' => $svc_acct->username,
2403 'password' => $svc_acct->_password,
2404 'first' => $cust_main->first,
2405 'last' => $cust_main->getfield('last'),
2406 'pkg' => $cust_pkg->part_pkg->pkg,
2407 'column' => $opt{'column'},
2408 'amount' => $opt{'column'} =~/bytes/
2409 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2410 : $svc_acct->getfield($opt{'column'}),
2411 'threshold' => $opt{'column'} =~/bytes/
2412 ? FS::UI::bytecount::display_bytecount($threshold)
2417 my $error = send_email(
2418 'from' => $warning_from,
2420 'subject' => $warning_subject,
2421 'content-type' => $mimetype,
2422 'body' => [ map "$_\n", split("\n", $body) ],
2424 die $error if $error;
2427 die "unknown op: " . $opt{'op'};
2435 The $recref stuff in sub check should be cleaned up.
2437 The suspend, unsuspend and cancel methods update the database, but not the
2438 current object. This is probably a bug as it's unexpected and
2441 radius_usergroup_selector? putting web ui components in here? they should
2442 probably live somewhere else...
2444 insertion of RADIUS group stuff in insert could be done with child_objects now
2445 (would probably clean up export of them too)
2449 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2450 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2451 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2452 L<freeside-queued>), L<FS::svc_acct_pop>,
2453 schema.html from the base documentation.
2457 =item domain_select_hash %OPTIONS
2459 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2460 may at present purchase.
2462 Currently available options are: I<pkgnum> I<svcpart>
2466 sub domain_select_hash {
2467 my ($self, %options) = @_;
2473 $part_svc = $self->part_svc;
2474 $cust_pkg = $self->cust_svc->cust_pkg
2478 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2479 if $options{'svcpart'};
2481 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2482 if $options{'pkgnum'};
2484 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2485 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2486 %domains = map { $_->svcnum => $_->domain }
2487 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2488 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2489 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2490 %domains = map { $_->svcnum => $_->domain }
2491 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2492 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2493 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2495 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2498 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2499 my $svc_domain = qsearchs('svc_domain',
2500 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2501 if ( $svc_domain ) {
2502 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2504 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2505 $part_svc->part_svc_column('domsvc')->columnvalue;