4 use base qw( FS::svc_Domain_Mixin FS::svc_Common );
5 use vars qw( $DEBUG $me $conf $skip_fuzzyfiles
6 $dir_prefix @shells $usernamemin
7 $usernamemax $passwordmin $passwordmax
8 $username_ampersand $username_letter $username_letterfirst
9 $username_noperiod $username_nounderscore $username_nodash
10 $username_uppercase $username_percent $username_colon
11 $password_noampersand $password_noexclamation
12 $warning_template $warning_from $warning_subject $warning_mimetype
15 $radius_password $radius_ip
18 use Scalar::Util qw( blessed );
23 use Crypt::PasswdMD5 1.2;
24 use Digest::SHA1 'sha1_base64';
25 use Digest::MD5 'md5_base64';
28 use Authen::Passphrase;
29 use FS::UID qw( datasrc driver_name );
31 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
32 use FS::Msgcat qw(gettext);
33 use FS::UI::bytecount;
38 use FS::cust_main_invoice;
43 use FS::radius_usergroup;
51 $me = '[FS::svc_acct]';
53 #ask FS::UID to run this stuff for us later
54 FS::UID->install_callback( sub {
56 $dir_prefix = $conf->config('home');
57 @shells = $conf->config('shells');
58 $usernamemin = $conf->config('usernamemin') || 2;
59 $usernamemax = $conf->config('usernamemax');
60 $passwordmin = $conf->config('passwordmin'); # || 6;
62 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
65 $passwordmax = $conf->config('passwordmax') || 8;
66 $username_letter = $conf->exists('username-letter');
67 $username_letterfirst = $conf->exists('username-letterfirst');
68 $username_noperiod = $conf->exists('username-noperiod');
69 $username_nounderscore = $conf->exists('username-nounderscore');
70 $username_nodash = $conf->exists('username-nodash');
71 $username_uppercase = $conf->exists('username-uppercase');
72 $username_ampersand = $conf->exists('username-ampersand');
73 $username_percent = $conf->exists('username-percent');
74 $username_colon = $conf->exists('username-colon');
75 $password_noampersand = $conf->exists('password-noexclamation');
76 $password_noexclamation = $conf->exists('password-noexclamation');
77 $dirhash = $conf->config('dirhash') || 0;
78 if ( $conf->exists('warning_email') ) {
79 $warning_template = new Text::Template (
81 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
82 ) or warn "can't create warning email template: $Text::Template::ERROR";
83 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
84 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
85 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
86 $warning_cc = $conf->config('warning_email-cc');
88 $warning_template = '';
90 $warning_subject = '';
91 $warning_mimetype = '';
94 $smtpmachine = $conf->config('smtpmachine');
95 $radius_password = $conf->config('radius-password') || 'Password';
96 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
97 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
101 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
102 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
106 my ( $hashref, $cache ) = @_;
107 if ( $hashref->{'svc_acct_svcnum'} ) {
108 $self->{'_domsvc'} = FS::svc_domain->new( {
109 'svcnum' => $hashref->{'domsvc'},
110 'domain' => $hashref->{'svc_acct_domain'},
111 'catchall' => $hashref->{'svc_acct_catchall'},
118 FS::svc_acct - Object methods for svc_acct records
124 $record = new FS::svc_acct \%hash;
125 $record = new FS::svc_acct { 'column' => 'value' };
127 $error = $record->insert;
129 $error = $new_record->replace($old_record);
131 $error = $record->delete;
133 $error = $record->check;
135 $error = $record->suspend;
137 $error = $record->unsuspend;
139 $error = $record->cancel;
141 %hash = $record->radius;
143 %hash = $record->radius_reply;
145 %hash = $record->radius_check;
147 $domain = $record->domain;
149 $svc_domain = $record->svc_domain;
151 $email = $record->email;
153 $seconds_since = $record->seconds_since($timestamp);
157 An FS::svc_acct object represents an account. FS::svc_acct inherits from
158 FS::svc_Common. The following fields are currently supported:
164 Primary key (assigned automatcially for new accounts)
172 =item _password_encoding
174 plain, crypt, ldap (or empty for autodetection)
182 Point of presence (see L<FS::svc_acct_pop>)
194 set automatically if blank (and uid is not)
214 svcnum from svc_domain
218 Optional svcnum from svc_pbx
220 =item radius_I<Radius_Attribute>
222 I<Radius-Attribute> (reply)
224 =item rc_I<Radius_Attribute>
226 I<Radius-Attribute> (check)
236 Creates a new account. To add the account to the database, see L<"insert">.
243 'longname_plural' => 'Access accounts and mailboxes',
244 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
245 'display_weight' => 10,
246 'cancel_weight' => 50,
248 'dir' => 'Home directory',
251 def_info => 'set to fixed and blank for no UIDs',
254 'slipip' => 'IP address',
255 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
257 label => 'Access number',
259 select_table => 'svc_acct_pop',
260 select_key => 'popnum',
261 select_label => 'city',
267 disable_default => 1,
271 'password_selfchange' => { label => 'Password modification',
274 'password_recover' => { label => 'Password recovery',
278 label => 'Quota', #Mail storage limit
280 disable_inventory => 1,
284 label => 'File storage limit',
286 disable_inventory => 1,
290 label => 'Number of files limit',
292 disable_inventory => 1,
296 label => 'File size limit',
298 disable_inventory => 1,
301 '_password' => 'Password',
304 def_info => 'when blank, defaults to UID',
309 def_info => 'set to blank for no shell tracking',
311 #select_list => [ $conf->config('shells') ],
312 select_list => [ $conf ? $conf->config('shells') : () ],
313 disable_inventory => 1,
316 'finger' => 'Real name', # (GECOS)',
320 select_table => 'svc_domain',
321 select_key => 'svcnum',
322 select_label => 'domain',
323 disable_inventory => 1,
325 'pbxsvc' => { label => 'PBX',
326 type => 'select-svc_pbx.html',
327 disable_inventory => 1,
328 disable_select => 1, #UI wonky, pry works otherwise
331 label => 'RADIUS groups',
332 type => 'radius_usergroup_selector',
333 disable_inventory => 1,
336 'seconds' => { label => 'Seconds',
337 label_sort => 'with Time Remaining',
339 disable_inventory => 1,
341 disable_part_svc_column => 1,
343 'upbytes' => { label => 'Upload',
345 disable_inventory => 1,
347 'format' => \&FS::UI::bytecount::display_bytecount,
348 'parse' => \&FS::UI::bytecount::parse_bytecount,
349 disable_part_svc_column => 1,
351 'downbytes' => { label => 'Download',
353 disable_inventory => 1,
355 'format' => \&FS::UI::bytecount::display_bytecount,
356 'parse' => \&FS::UI::bytecount::parse_bytecount,
357 disable_part_svc_column => 1,
359 'totalbytes'=> { label => 'Total up and download',
361 disable_inventory => 1,
363 'format' => \&FS::UI::bytecount::display_bytecount,
364 'parse' => \&FS::UI::bytecount::parse_bytecount,
365 disable_part_svc_column => 1,
367 'seconds_threshold' => { label => 'Seconds threshold',
369 disable_inventory => 1,
371 disable_part_svc_column => 1,
373 'upbytes_threshold' => { label => 'Upload threshold',
375 disable_inventory => 1,
377 'format' => \&FS::UI::bytecount::display_bytecount,
378 'parse' => \&FS::UI::bytecount::parse_bytecount,
379 disable_part_svc_column => 1,
381 'downbytes_threshold' => { label => 'Download threshold',
383 disable_inventory => 1,
385 'format' => \&FS::UI::bytecount::display_bytecount,
386 'parse' => \&FS::UI::bytecount::parse_bytecount,
387 disable_part_svc_column => 1,
389 'totalbytes_threshold'=> { label => 'Total up and download threshold',
391 disable_inventory => 1,
393 'format' => \&FS::UI::bytecount::display_bytecount,
394 'parse' => \&FS::UI::bytecount::parse_bytecount,
395 disable_part_svc_column => 1,
398 label => 'Last login',
402 label => 'Last logout',
407 label => 'Communigate aliases',
409 disable_inventory => 1,
414 label => 'Communigate account type',
416 select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )],
417 disable_inventory => 1,
420 'cgp_accessmodes' => {
421 label => 'Communigate enabled services',
422 type => 'communigate_pro-accessmodes',
423 disable_inventory => 1,
426 'cgp_rulesallowed' => {
427 label => 'Allowed mail rules',
429 select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ],
430 disable_inventory => 1,
433 'cgp_rpopallowed' => { label => 'RPOP modifications',
436 'cgp_mailtoall' => { label => 'Accepts mail to "all"',
439 'cgp_addmailtrailer' => { label => 'Add trailer to sent mail',
442 #XXX archive messages, mailing lists
445 'cgp_deletemode' => {
446 label => 'Communigate message delete method',
448 select_list => [ 'Move To Trash', 'Immediately', 'Mark' ],
449 disable_inventory => 1,
452 'cgp_emptytrash' => {
453 label => 'Communigate on logout remove trash',
455 disable_inventory => 1,
459 label => 'Communigate language',
461 select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ],
462 disable_inventory => 1,
466 label => 'Communigate time zone',
470 '(+0100) Algeria/Congo',
471 '(+0200) Egypt/South Africa',
472 '(+0300) Saudi Arabia',
475 '(+0600) Bangladesh',
476 '(+0700) Thailand/Vietnam',
477 '(+0800) China/Malaysia',
478 '(+0900) Japan/Korea',
479 '(+1000) Queensland',
480 '(+1100) Micronesia',
482 '(+1300) Tonga/Kiribati',
483 '(+1400) Christmas Islands',
484 '(-0100) Azores/Cape Verde',
485 '(-0200) Fernando de Noronha',
486 '(-0300) Argentina/Uruguay',
487 '(-0400) Venezuela/Guyana',
488 '(-0500) Haiti/Peru',
489 '(-0600) Central America',
492 '(-0900) Marquesas Islands',
493 '(-1000) Hawaii/Tahiti',
503 'Australia/Adelaide',
505 'Australia/NorthernTerritory',
512 'NewZealand/Auckland',
513 'NorthAmerica/Alaska',
514 'NorthAmerica/Atlantic',
515 'NorthAmerica/Central',
516 'NorthAmerica/Eastern',
517 'NorthAmerica/Mountain',
518 'NorthAmerica/Pacific',
519 'Russia/Ekaterinburg',
522 'Russia/Krasnoyarsk',
524 'Russia/Novosibirsk',
525 'Russia/Vladivostok',
527 'SouthAmerica/Brasil',
528 'SouthAmerica/Chile',
529 'SouthAmerica/Paraguay',
531 disable_inventory => 1,
535 label => 'Communigate layout',
537 select_list => [ '', '***', 'GoldFleece', 'Skin2' ],
538 disable_inventory => 1,
542 'cgp_sendmdnmode' => {
543 label => 'Communigate send read receipts',
545 select_list => [ '', 'Never', 'Manually', 'Automatically' ],
546 disable_inventory => 1,
551 #XXX vacation message, redirect all mail, mail rules
558 sub table { 'svc_acct'; }
560 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
564 #false laziness with edit/svc_acct.cgi
566 my( $self, $groups ) = @_;
567 if ( ref($groups) eq 'ARRAY' ) {
569 } elsif ( length($groups) ) {
570 [ split(/\s*,\s*/, $groups) ];
579 shift->_lastlog('in', @_);
583 shift->_lastlog('out', @_);
587 my( $self, $op, $time ) = @_;
589 if ( defined($time) ) {
590 warn "$me last_log$op called on svcnum ". $self->svcnum.
591 ' ('. $self->email. "): $time\n"
596 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
600 my $sth = $dbh->prepare( $sql )
601 or die "Error preparing $sql: ". $dbh->errstr;
602 my $rv = $sth->execute($time, $self->svcnum);
603 die "Error executing $sql: ". $sth->errstr
605 die "Can't update last_log$op for svcnum". $self->svcnum
608 $self->{'Hash'}->{"last_log$op"} = $time;
610 $self->getfield("last_log$op");
614 =item search_sql STRING
616 Class method which returns an SQL fragment to search for the given string.
621 my( $class, $string ) = @_;
622 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
623 my( $username, $domain ) = ( $1, $2 );
624 my $q_username = dbh->quote($username);
625 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
627 "svc_acct.username = $q_username AND ( ".
628 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
633 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
635 $class->search_sql_field('slipip', $string ).
637 $class->search_sql_field('username', $string ).
640 $class->search_sql_field('username', $string);
644 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
646 Returns the "username@domain" string for this account.
648 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
658 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
660 Returns a longer string label for this acccount ("Real Name <username@domain>"
661 if available, or "username@domain").
663 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
670 my $label = $self->label(@_);
671 my $finger = $self->finger;
672 return $label unless $finger =~ /\S/;
673 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
674 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
678 =item insert [ , OPTION => VALUE ... ]
680 Adds this account to the database. If there is an error, returns the error,
681 otherwise returns false.
683 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
684 defined. An FS::cust_svc record will be created and inserted.
686 The additional field I<usergroup> can optionally be defined; if so it should
687 contain an arrayref of group names. See L<FS::radius_usergroup>.
689 The additional field I<child_objects> can optionally be defined; if so it
690 should contain an arrayref of FS::tablename objects. They will have their
691 svcnum fields set and will be inserted after this record, but before any
692 exports are run. Each element of the array can also optionally be a
693 two-element array reference containing the child object and the name of an
694 alternate field to be filled in with the newly-inserted svcnum, for example
695 C<[ $svc_forward, 'srcsvc' ]>
697 Currently available options are: I<depend_jobnum>
699 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
700 jobnums), all provisioning jobs will have a dependancy on the supplied
701 jobnum(s) (they will not run until the specific job(s) complete(s)).
703 (TODOC: L<FS::queue> and L<freeside-queued>)
705 (TODOC: new exports!)
714 warn "[$me] insert called on $self: ". Dumper($self).
715 "\nwith options: ". Dumper(%options);
718 local $SIG{HUP} = 'IGNORE';
719 local $SIG{INT} = 'IGNORE';
720 local $SIG{QUIT} = 'IGNORE';
721 local $SIG{TERM} = 'IGNORE';
722 local $SIG{TSTP} = 'IGNORE';
723 local $SIG{PIPE} = 'IGNORE';
725 my $oldAutoCommit = $FS::UID::AutoCommit;
726 local $FS::UID::AutoCommit = 0;
730 my $error = $self->SUPER::insert(
731 'jobnums' => \@jobnums,
732 'child_objects' => $self->child_objects,
736 $dbh->rollback if $oldAutoCommit;
740 if ( $self->usergroup ) {
741 foreach my $groupname ( @{$self->usergroup} ) {
742 my $radius_usergroup = new FS::radius_usergroup ( {
743 svcnum => $self->svcnum,
744 groupname => $groupname,
746 my $error = $radius_usergroup->insert;
748 $dbh->rollback if $oldAutoCommit;
754 unless ( $skip_fuzzyfiles ) {
755 $error = $self->queue_fuzzyfiles_update;
757 $dbh->rollback if $oldAutoCommit;
758 return "updating fuzzy search cache: $error";
762 my $cust_pkg = $self->cust_svc->cust_pkg;
765 my $cust_main = $cust_pkg->cust_main;
766 my $agentnum = $cust_main->agentnum;
768 if ( $conf->exists('emailinvoiceautoalways')
769 || $conf->exists('emailinvoiceauto')
770 && ! $cust_main->invoicing_list_emailonly
772 my @invoicing_list = $cust_main->invoicing_list;
773 push @invoicing_list, $self->email;
774 $cust_main->invoicing_list(\@invoicing_list);
778 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
779 = ('','','','','','');
781 if ( $conf->exists('welcome_email', $agentnum) ) {
782 $welcome_template = new Text::Template (
784 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
785 ) or warn "can't create welcome email template: $Text::Template::ERROR";
786 $welcome_from = $conf->config('welcome_email-from', $agentnum);
787 # || 'your-isp-is-dum'
788 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
790 $welcome_subject_template = new Text::Template (
792 SOURCE => $welcome_subject,
793 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
794 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
797 if ( $welcome_template && $cust_pkg ) {
798 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
802 'custnum' => $self->custnum,
803 'username' => $self->username,
804 'password' => $self->_password,
805 'first' => $cust_main->first,
806 'last' => $cust_main->getfield('last'),
807 'pkg' => $cust_pkg->part_pkg->pkg,
809 my $wqueue = new FS::queue {
810 'svcnum' => $self->svcnum,
811 'job' => 'FS::svc_acct::send_email'
813 my $error = $wqueue->insert(
815 'from' => $welcome_from,
816 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
817 'mimetype' => $welcome_mimetype,
818 'body' => $welcome_template->fill_in( HASH => \%hash, ),
821 $dbh->rollback if $oldAutoCommit;
822 return "error queuing welcome email: $error";
825 if ( $options{'depend_jobnum'} ) {
826 warn "$me depend_jobnum found; adding to welcome email dependancies"
828 if ( ref($options{'depend_jobnum'}) ) {
829 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
830 "to welcome email dependancies"
832 push @jobnums, @{ $options{'depend_jobnum'} };
834 warn "$me adding job $options{'depend_jobnum'} ".
835 "to welcome email dependancies"
837 push @jobnums, $options{'depend_jobnum'};
841 foreach my $jobnum ( @jobnums ) {
842 my $error = $wqueue->depend_insert($jobnum);
844 $dbh->rollback if $oldAutoCommit;
845 return "error queuing welcome email job dependancy: $error";
855 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
859 # set usage fields and thresholds if unset but set in a package def
860 # AND the package already has a last bill date (otherwise they get double added)
861 sub preinsert_hook_first {
864 return '' unless $self->pkgnum;
866 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
867 return '' unless $cust_pkg && $cust_pkg->last_bill;
869 my $part_pkg = $cust_pkg->part_pkg;
870 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
872 my %values = $part_pkg->usage_valuehash;
873 my $multiplier = $conf->exists('svc_acct-usage_threshold')
874 ? 1 - $conf->config('svc_acct-usage_threshold')/100
875 : 0.20; #doesn't matter
877 foreach ( keys %values ) {
878 next if $self->getfield($_);
879 $self->setfield( $_, $values{$_} );
880 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
881 if $conf->exists('svc_acct-usage_threshold');
889 Deletes this account from the database. If there is an error, returns the
890 error, otherwise returns false.
892 The corresponding FS::cust_svc record will be deleted as well.
894 (TODOC: new exports!)
901 return "can't delete system account" if $self->_check_system;
903 return "Can't delete an account which is a (svc_forward) source!"
904 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
906 return "Can't delete an account which is a (svc_forward) destination!"
907 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
909 return "Can't delete an account with (svc_www) web service!"
910 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
912 # what about records in session ? (they should refer to history table)
914 local $SIG{HUP} = 'IGNORE';
915 local $SIG{INT} = 'IGNORE';
916 local $SIG{QUIT} = 'IGNORE';
917 local $SIG{TERM} = 'IGNORE';
918 local $SIG{TSTP} = 'IGNORE';
919 local $SIG{PIPE} = 'IGNORE';
921 my $oldAutoCommit = $FS::UID::AutoCommit;
922 local $FS::UID::AutoCommit = 0;
925 foreach my $cust_main_invoice (
926 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
928 unless ( defined($cust_main_invoice) ) {
929 warn "WARNING: something's wrong with qsearch";
932 my %hash = $cust_main_invoice->hash;
933 $hash{'dest'} = $self->email;
934 my $new = new FS::cust_main_invoice \%hash;
935 my $error = $new->replace($cust_main_invoice);
937 $dbh->rollback if $oldAutoCommit;
942 foreach my $svc_domain (
943 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
945 my %hash = new FS::svc_domain->hash;
946 $hash{'catchall'} = '';
947 my $new = new FS::svc_domain \%hash;
948 my $error = $new->replace($svc_domain);
950 $dbh->rollback if $oldAutoCommit;
955 my $error = $self->SUPER::delete;
957 $dbh->rollback if $oldAutoCommit;
961 foreach my $radius_usergroup (
962 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
964 my $error = $radius_usergroup->delete;
966 $dbh->rollback if $oldAutoCommit;
971 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
975 =item replace OLD_RECORD
977 Replaces OLD_RECORD with this one in the database. If there is an error,
978 returns the error, otherwise returns false.
980 The additional field I<usergroup> can optionally be defined; if so it should
981 contain an arrayref of group names. See L<FS::radius_usergroup>.
989 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
993 warn "$me replacing $old with $new\n" if $DEBUG;
997 return "can't modify system account" if $old->_check_system;
1000 #no warnings 'numeric'; #alas, a 5.006-ism
1003 foreach my $xid (qw( uid gid )) {
1005 return "Can't change $xid!"
1006 if ! $conf->exists("svc_acct-edit_$xid")
1007 && $old->$xid() != $new->$xid()
1008 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
1013 #change homdir when we change username
1014 $new->setfield('dir', '') if $old->username ne $new->username;
1016 local $SIG{HUP} = 'IGNORE';
1017 local $SIG{INT} = 'IGNORE';
1018 local $SIG{QUIT} = 'IGNORE';
1019 local $SIG{TERM} = 'IGNORE';
1020 local $SIG{TSTP} = 'IGNORE';
1021 local $SIG{PIPE} = 'IGNORE';
1023 my $oldAutoCommit = $FS::UID::AutoCommit;
1024 local $FS::UID::AutoCommit = 0;
1027 # redundant, but so $new->usergroup gets set
1028 $error = $new->check;
1029 return $error if $error;
1031 $old->usergroup( [ $old->radius_groups ] );
1033 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
1034 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
1036 if ( $new->usergroup ) {
1037 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
1038 my @newgroups = @{$new->usergroup};
1039 foreach my $oldgroup ( @{$old->usergroup} ) {
1040 if ( grep { $oldgroup eq $_ } @newgroups ) {
1041 @newgroups = grep { $oldgroup ne $_ } @newgroups;
1044 my $radius_usergroup = qsearchs('radius_usergroup', {
1045 svcnum => $old->svcnum,
1046 groupname => $oldgroup,
1048 my $error = $radius_usergroup->delete;
1050 $dbh->rollback if $oldAutoCommit;
1051 return "error deleting radius_usergroup $oldgroup: $error";
1055 foreach my $newgroup ( @newgroups ) {
1056 my $radius_usergroup = new FS::radius_usergroup ( {
1057 svcnum => $new->svcnum,
1058 groupname => $newgroup,
1060 my $error = $radius_usergroup->insert;
1062 $dbh->rollback if $oldAutoCommit;
1063 return "error adding radius_usergroup $newgroup: $error";
1069 $error = $new->SUPER::replace($old, @_);
1071 $dbh->rollback if $oldAutoCommit;
1072 return $error if $error;
1075 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1076 $error = $new->queue_fuzzyfiles_update;
1078 $dbh->rollback if $oldAutoCommit;
1079 return "updating fuzzy search cache: $error";
1083 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1087 =item queue_fuzzyfiles_update
1089 Used by insert & replace to update the fuzzy search cache
1093 sub queue_fuzzyfiles_update {
1096 local $SIG{HUP} = 'IGNORE';
1097 local $SIG{INT} = 'IGNORE';
1098 local $SIG{QUIT} = 'IGNORE';
1099 local $SIG{TERM} = 'IGNORE';
1100 local $SIG{TSTP} = 'IGNORE';
1101 local $SIG{PIPE} = 'IGNORE';
1103 my $oldAutoCommit = $FS::UID::AutoCommit;
1104 local $FS::UID::AutoCommit = 0;
1107 my $queue = new FS::queue {
1108 'svcnum' => $self->svcnum,
1109 'job' => 'FS::svc_acct::append_fuzzyfiles'
1111 my $error = $queue->insert($self->username);
1113 $dbh->rollback if $oldAutoCommit;
1114 return "queueing job (transaction rolled back): $error";
1117 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1125 Suspends this account by calling export-specific suspend hooks. If there is
1126 an error, returns the error, otherwise returns false.
1128 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1134 return "can't suspend system account" if $self->_check_system;
1135 $self->SUPER::suspend(@_);
1140 Unsuspends this account by by calling export-specific suspend hooks. If there
1141 is an error, returns the error, otherwise returns false.
1143 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1149 my %hash = $self->hash;
1150 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1151 $hash{_password} = $1;
1152 my $new = new FS::svc_acct ( \%hash );
1153 my $error = $new->replace($self);
1154 return $error if $error;
1157 $self->SUPER::unsuspend(@_);
1162 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1164 If the B<auto_unset_catchall> configuration option is set, this method will
1165 automatically remove any references to the canceled service in the catchall
1166 field of svc_domain. This allows packages that contain both a svc_domain and
1167 its catchall svc_acct to be canceled in one step.
1172 # Only one thing to do at this level
1174 foreach my $svc_domain (
1175 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1176 if($conf->exists('auto_unset_catchall')) {
1177 my %hash = $svc_domain->hash;
1178 $hash{catchall} = '';
1179 my $new = new FS::svc_domain ( \%hash );
1180 my $error = $new->replace($svc_domain);
1181 return $error if $error;
1183 return "cannot unprovision svc_acct #".$self->svcnum.
1184 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1188 $self->SUPER::cancel(@_);
1194 Checks all fields to make sure this is a valid service. If there is an error,
1195 returns the error, otherwise returns false. Called by the insert and replace
1198 Sets any fixed values; see L<FS::part_svc>.
1205 my($recref) = $self->hashref;
1207 my $x = $self->setfixed( $self->_fieldhandlers );
1208 return $x unless ref($x);
1211 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1213 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1216 my $error = $self->ut_numbern('svcnum')
1217 #|| $self->ut_number('domsvc')
1218 || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1219 || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx', 'svcnum' )
1220 || $self->ut_textn('sec_phrase')
1221 || $self->ut_snumbern('seconds')
1222 || $self->ut_snumbern('upbytes')
1223 || $self->ut_snumbern('downbytes')
1224 || $self->ut_snumbern('totalbytes')
1225 || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1226 || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1227 || $self->ut_enum('password_recover', [ '', 'Y' ])
1228 || $self->ut_textn('cgp_accessmodes')
1229 || $self->ut_alphan('cgp_type')
1230 || $self->ut_textn('cgp_aliases' ) #well
1232 || $self->ut_alphasn('cgp_rulesallowed')
1233 || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1234 || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1235 || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1237 || $self->ut_alphasn('cgp_deletemode')
1238 || $self->ut_alphan('cgp_emptytrash')
1239 || $self->ut_alphan('cgp_language')
1240 || $self->ut_textn('cgp_timezone')
1241 || $self->ut_textn('cgp_skinname')
1243 || $self->ut_alphan('cgp_sendmdnmode')
1244 #XXX vacation message, redirect all mail, mail rules
1247 return $error if $error;
1250 local $username_letter = $username_letter;
1251 if ($self->svcnum) {
1252 my $cust_svc = $self->cust_svc
1253 or return "no cust_svc record found for svcnum ". $self->svcnum;
1254 my $cust_pkg = $cust_svc->cust_pkg;
1256 if ($self->pkgnum) {
1257 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1261 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1264 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1265 if ( $username_uppercase ) {
1266 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1267 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1268 $recref->{username} = $1;
1270 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1271 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1272 $recref->{username} = $1;
1275 if ( $username_letterfirst ) {
1276 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1277 } elsif ( $username_letter ) {
1278 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1280 if ( $username_noperiod ) {
1281 $recref->{username} =~ /\./ and return gettext('illegal_username');
1283 if ( $username_nounderscore ) {
1284 $recref->{username} =~ /_/ and return gettext('illegal_username');
1286 if ( $username_nodash ) {
1287 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1289 unless ( $username_ampersand ) {
1290 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1292 unless ( $username_percent ) {
1293 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1295 unless ( $username_colon ) {
1296 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1299 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1300 $recref->{popnum} = $1;
1301 return "Unknown popnum" unless
1302 ! $recref->{popnum} ||
1303 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1305 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1307 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1308 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1310 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1311 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1312 #not all systems use gid=uid
1313 #you can set a fixed gid in part_svc
1315 return "Only root can have uid 0"
1316 if $recref->{uid} == 0
1317 && $recref->{username} !~ /^(root|toor|smtp)$/;
1319 unless ( $recref->{username} eq 'sync' ) {
1320 if ( grep $_ eq $recref->{shell}, @shells ) {
1321 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1323 return "Illegal shell \`". $self->shell. "\'; ".
1324 "shells configuration value contains: @shells";
1327 $recref->{shell} = '/bin/sync';
1331 $recref->{gid} ne '' ?
1332 return "Can't have gid without uid" : ( $recref->{gid}='' );
1333 #$recref->{dir} ne '' ?
1334 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1335 $recref->{shell} ne '' ?
1336 return "Can't have shell without uid" : ( $recref->{shell}='' );
1339 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1341 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1342 or return "Illegal directory: ". $recref->{dir};
1343 $recref->{dir} = $1;
1344 return "Illegal directory"
1345 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1346 return "Illegal directory"
1347 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1348 unless ( $recref->{dir} ) {
1349 $recref->{dir} = $dir_prefix . '/';
1350 if ( $dirhash > 0 ) {
1351 for my $h ( 1 .. $dirhash ) {
1352 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1354 } elsif ( $dirhash < 0 ) {
1355 for my $h ( reverse $dirhash .. -1 ) {
1356 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1359 $recref->{dir} .= $recref->{username};
1365 # $error = $self->ut_textn('finger');
1366 # return $error if $error;
1367 if ( $self->getfield('finger') eq '' ) {
1368 my $cust_pkg = $self->svcnum
1369 ? $self->cust_svc->cust_pkg
1370 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1372 my $cust_main = $cust_pkg->cust_main;
1373 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1376 $self->getfield('finger') =~
1377 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1378 or return "Illegal finger: ". $self->getfield('finger');
1379 $self->setfield('finger', $1);
1381 for (qw( quota file_quota file_maxsize )) {
1382 $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1385 $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1386 $recref->{file_maxnum} = $1;
1388 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1389 if ( $recref->{slipip} eq '' ) {
1390 $recref->{slipip} = '';
1391 } elsif ( $recref->{slipip} eq '0e0' ) {
1392 $recref->{slipip} = '0e0';
1394 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1395 or return "Illegal slipip: ". $self->slipip;
1396 $recref->{slipip} = $1;
1401 #arbitrary RADIUS stuff; allow ut_textn for now
1402 foreach ( grep /^radius_/, fields('svc_acct') ) {
1403 $self->ut_textn($_);
1406 # First, if _password is blank, generate one and set default encoding.
1407 if ( ! $recref->{_password} ) {
1408 $error = $self->set_password('');
1410 # But if there's a _password but no encoding, assume it's plaintext and
1411 # set it to default encoding.
1412 elsif ( ! $recref->{_password_encoding} ) {
1413 $error = $self->set_password($recref->{_password});
1415 return $error if $error;
1417 # Next, check _password to ensure compliance with the encoding.
1418 if ( $recref->{_password_encoding} eq 'ldap' ) {
1420 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1421 $recref->{_password} = uc($1).$2;
1423 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1426 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1428 if ( $recref->{_password} =~
1429 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1430 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1433 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1436 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1439 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1440 # Password randomization is now in set_password.
1441 # Strip whitespace characters, check length requirements, etc.
1442 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1443 $recref->{_password} = $1;
1445 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1446 FS::Msgcat::_gettext('illegal_password_characters').
1447 ": ". $recref->{_password};
1450 if ( $password_noampersand ) {
1451 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1453 if ( $password_noexclamation ) {
1454 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1458 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1460 $self->SUPER::check;
1465 sub _password_encryption {
1467 my $encoding = lc($self->_password_encoding);
1468 return if !$encoding;
1469 return 'plain' if $encoding eq 'plain';
1470 if($encoding eq 'crypt') {
1471 my $pass = $self->_password;
1472 $pass =~ s/^\*SUSPENDED\* //;
1474 return 'md5' if $pass =~ /^\$1\$/;
1475 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1476 return 'des' if length($pass) == 13;
1479 if($encoding eq 'ldap') {
1480 uc($self->_password) =~ /^\{([\w-]+)\}/;
1481 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1482 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1483 return 'md5' if $1 eq 'MD5';
1484 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1491 sub get_cleartext_password {
1493 if($self->_password_encryption eq 'plain') {
1494 if($self->_password_encoding eq 'ldap') {
1495 $self->_password =~ /\{\w+\}(.*)$/;
1499 return $self->_password;
1508 Set the cleartext password for the account. If _password_encoding is set, the
1509 new password will be encoded according to the existing method (including
1510 encryption mode, if it can be determined). Otherwise,
1511 config('default-password-encoding') is used.
1513 If no password is supplied (or a zero-length password when minimum password length
1514 is >0), one will be generated randomly.
1519 my( $self, $pass ) = ( shift, shift );
1521 warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1524 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1525 FS::Msgcat::_gettext('illegal_password_characters').
1528 my( $encoding, $encryption ) = ('', '');
1530 if ( $self->_password_encoding ) {
1531 $encoding = $self->_password_encoding;
1532 # identify existing encryption method, try to use it.
1533 $encryption = $self->_password_encryption;
1535 # use the system default
1541 # set encoding to system default
1542 ($encoding, $encryption) =
1543 split(/-/, lc($conf->config('default-password-encoding')));
1544 $encoding ||= 'legacy';
1545 $self->_password_encoding($encoding);
1548 if ( $encoding eq 'legacy' ) {
1550 # The legacy behavior from check():
1551 # If the password is blank, randomize it and set encoding to 'plain'.
1552 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1553 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1554 $self->_password_encoding('plain');
1556 # Prefix + valid-length password
1557 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1559 $self->_password_encoding('plain');
1560 # Prefix + crypt string
1561 } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1563 $self->_password_encoding('crypt');
1564 # Various disabled crypt passwords
1565 } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1566 $self->_password_encoding('crypt');
1572 $self->_password($pass);
1578 if $passwordmin && length($pass) < $passwordmin
1579 or $passwordmax && length($pass) > $passwordmax;
1581 if ( $encoding eq 'crypt' ) {
1582 if ($encryption eq 'md5') {
1583 $pass = unix_md5_crypt($pass);
1584 } elsif ($encryption eq 'des') {
1585 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1588 } elsif ( $encoding eq 'ldap' ) {
1589 if ($encryption eq 'md5') {
1590 $pass = md5_base64($pass);
1591 } elsif ($encryption eq 'sha1') {
1592 $pass = sha1_base64($pass);
1593 } elsif ($encryption eq 'crypt') {
1594 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1596 # else $encryption eq 'plain', do nothing
1597 $pass = '{'.uc($encryption).'}'.$pass;
1599 # else encoding eq 'plain'
1601 $self->_password($pass);
1607 Internal function to check the username against the list of system usernames
1608 from the I<system_usernames> configuration value. Returns true if the username
1609 is listed on the system username list.
1615 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1616 $conf->config('system_usernames')
1620 =item _check_duplicate
1622 Internal method to check for duplicates usernames, username@domain pairs and
1625 If the I<global_unique-username> configuration value is set to B<username> or
1626 B<username@domain>, enforces global username or username@domain uniqueness.
1628 In all cases, check for duplicate uids and usernames or username@domain pairs
1629 per export and with identical I<svcpart> values.
1633 sub _check_duplicate {
1636 my $global_unique = $conf->config('global_unique-username') || 'none';
1637 return '' if $global_unique eq 'disabled';
1641 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1642 unless ( $part_svc ) {
1643 return 'unknown svcpart '. $self->svcpart;
1646 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1647 qsearch( 'svc_acct', { 'username' => $self->username } );
1648 return gettext('username_in_use')
1649 if $global_unique eq 'username' && @dup_user;
1651 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1652 qsearch( 'svc_acct', { 'username' => $self->username,
1653 'domsvc' => $self->domsvc } );
1654 return gettext('username_in_use')
1655 if $global_unique eq 'username@domain' && @dup_userdomain;
1658 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1659 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1660 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1661 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1666 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1667 my $exports = FS::part_export::export_info('svc_acct');
1668 my %conflict_user_svcpart;
1669 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1671 foreach my $part_export ( $part_svc->part_export ) {
1673 #this will catch to the same exact export
1674 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1676 #this will catch to exports w/same exporthost+type ???
1677 #my @other_part_export = qsearch('part_export', {
1678 # 'machine' => $part_export->machine,
1679 # 'exporttype' => $part_export->exporttype,
1681 #foreach my $other_part_export ( @other_part_export ) {
1682 # push @svcparts, map { $_->svcpart }
1683 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1686 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1687 #silly kludge to avoid uninitialized value errors
1688 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1689 ? $exports->{$part_export->exporttype}{'nodomain'}
1691 if ( $nodomain =~ /^Y/i ) {
1692 $conflict_user_svcpart{$_} = $part_export->exportnum
1695 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1700 foreach my $dup_user ( @dup_user ) {
1701 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1702 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1703 return "duplicate username ". $self->username.
1704 ": conflicts with svcnum ". $dup_user->svcnum.
1705 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1709 foreach my $dup_userdomain ( @dup_userdomain ) {
1710 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1711 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1712 return "duplicate username\@domain ". $self->email.
1713 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1714 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1718 foreach my $dup_uid ( @dup_uid ) {
1719 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1720 if ( exists($conflict_user_svcpart{$dup_svcpart})
1721 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1722 return "duplicate uid ". $self->uid.
1723 ": conflicts with svcnum ". $dup_uid->svcnum.
1725 ( $conflict_user_svcpart{$dup_svcpart}
1726 || $conflict_userdomain_svcpart{$dup_svcpart} );
1738 Depriciated, use radius_reply instead.
1743 carp "FS::svc_acct::radius depriciated, use radius_reply";
1744 $_[0]->radius_reply;
1749 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1750 reply attributes of this record.
1752 Note that this is now the preferred method for reading RADIUS attributes -
1753 accessing the columns directly is discouraged, as the column names are
1754 expected to change in the future.
1761 return %{ $self->{'radius_reply'} }
1762 if exists $self->{'radius_reply'};
1767 my($column, $attrib) = ($1, $2);
1768 #$attrib =~ s/_/\-/g;
1769 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1770 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1772 if ( $self->slipip && $self->slipip ne '0e0' ) {
1773 $reply{$radius_ip} = $self->slipip;
1776 if ( $self->seconds !~ /^$/ ) {
1777 $reply{'Session-Timeout'} = $self->seconds;
1780 if ( $conf->exists('radius-chillispot-max') ) {
1781 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1783 #hmm. just because sqlradius.pm says so?
1790 foreach my $what (qw( input output total )) {
1791 my $is = $whatis{$what}.'bytes';
1792 if ( $self->$is() =~ /\d/ ) {
1793 my $big = new Math::BigInt $self->$is();
1794 $big = new Math::BigInt '0' if $big->is_neg();
1795 my $att = "Chillispot-Max-\u$what";
1796 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1797 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1808 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1809 check attributes of this record.
1811 Note that this is now the preferred method for reading RADIUS attributes -
1812 accessing the columns directly is discouraged, as the column names are
1813 expected to change in the future.
1820 return %{ $self->{'radius_check'} }
1821 if exists $self->{'radius_check'};
1826 my($column, $attrib) = ($1, $2);
1827 #$attrib =~ s/_/\-/g;
1828 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1829 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1832 my($pw_attrib, $password) = $self->radius_password;
1833 $check{$pw_attrib} = $password;
1835 my $cust_svc = $self->cust_svc;
1837 my $cust_pkg = $cust_svc->cust_pkg;
1838 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1839 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1842 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1843 "; can't set Expiration\n"
1851 =item radius_password
1853 Returns a key/value pair containing the RADIUS attribute name and value
1858 sub radius_password {
1862 if ( $self->_password_encoding eq 'ldap' ) {
1863 $pw_attrib = 'Password-With-Header';
1864 } elsif ( $self->_password_encoding eq 'crypt' ) {
1865 $pw_attrib = 'Crypt-Password';
1866 } elsif ( $self->_password_encoding eq 'plain' ) {
1867 $pw_attrib = $radius_password;
1869 $pw_attrib = length($self->_password) <= 12
1874 ($pw_attrib, $self->_password);
1880 This method instructs the object to "snapshot" or freeze RADIUS check and
1881 reply attributes to the current values.
1885 #bah, my english is too broken this morning
1886 #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
1887 #the FS::cust_pkg's replace method to trigger the correct export updates when
1888 #package dates change)
1893 $self->{$_} = { $self->$_() }
1894 foreach qw( radius_reply radius_check );
1898 =item forget_snapshot
1900 This methos instructs the object to forget any previously snapshotted
1901 RADIUS check and reply attributes.
1905 sub forget_snapshot {
1909 foreach qw( radius_reply radius_check );
1913 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1915 Returns the domain associated with this account.
1917 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1924 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1925 my $svc_domain = $self->svc_domain(@_)
1926 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1927 $svc_domain->domain;
1932 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1936 #inherited from svc_Common
1938 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1940 Returns an email address associated with the account.
1942 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1949 $self->username. '@'. $self->domain(@_);
1954 Returns an array of FS::acct_snarf records associated with the account.
1955 If the acct_snarf table does not exist or there are no associated records,
1956 an empty list is returned
1962 return () unless dbdef->table('acct_snarf');
1963 eval "use FS::acct_snarf;";
1965 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1968 =item decrement_upbytes OCTETS
1970 Decrements the I<upbytes> field of this record by the given amount. If there
1971 is an error, returns the error, otherwise returns false.
1975 sub decrement_upbytes {
1976 shift->_op_usage('-', 'upbytes', @_);
1979 =item increment_upbytes OCTETS
1981 Increments the I<upbytes> field of this record by the given amount. If there
1982 is an error, returns the error, otherwise returns false.
1986 sub increment_upbytes {
1987 shift->_op_usage('+', 'upbytes', @_);
1990 =item decrement_downbytes OCTETS
1992 Decrements the I<downbytes> field of this record by the given amount. If there
1993 is an error, returns the error, otherwise returns false.
1997 sub decrement_downbytes {
1998 shift->_op_usage('-', 'downbytes', @_);
2001 =item increment_downbytes OCTETS
2003 Increments the I<downbytes> field of this record by the given amount. If there
2004 is an error, returns the error, otherwise returns false.
2008 sub increment_downbytes {
2009 shift->_op_usage('+', 'downbytes', @_);
2012 =item decrement_totalbytes OCTETS
2014 Decrements the I<totalbytes> field of this record by the given amount. If there
2015 is an error, returns the error, otherwise returns false.
2019 sub decrement_totalbytes {
2020 shift->_op_usage('-', 'totalbytes', @_);
2023 =item increment_totalbytes OCTETS
2025 Increments the I<totalbytes> field of this record by the given amount. If there
2026 is an error, returns the error, otherwise returns false.
2030 sub increment_totalbytes {
2031 shift->_op_usage('+', 'totalbytes', @_);
2034 =item decrement_seconds SECONDS
2036 Decrements the I<seconds> field of this record by the given amount. If there
2037 is an error, returns the error, otherwise returns false.
2041 sub decrement_seconds {
2042 shift->_op_usage('-', 'seconds', @_);
2045 =item increment_seconds SECONDS
2047 Increments the I<seconds> field of this record by the given amount. If there
2048 is an error, returns the error, otherwise returns false.
2052 sub increment_seconds {
2053 shift->_op_usage('+', 'seconds', @_);
2061 my %op2condition = (
2062 '-' => sub { my($self, $column, $amount) = @_;
2063 $self->$column - $amount <= 0;
2065 '+' => sub { my($self, $column, $amount) = @_;
2066 ($self->$column || 0) + $amount > 0;
2069 my %op2warncondition = (
2070 '-' => sub { my($self, $column, $amount) = @_;
2071 my $threshold = $column . '_threshold';
2072 $self->$column - $amount <= $self->$threshold + 0;
2074 '+' => sub { my($self, $column, $amount) = @_;
2075 ($self->$column || 0) + $amount > 0;
2080 my( $self, $op, $column, $amount ) = @_;
2082 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2083 ' ('. $self->email. "): $op $amount\n"
2086 return '' unless $amount;
2088 local $SIG{HUP} = 'IGNORE';
2089 local $SIG{INT} = 'IGNORE';
2090 local $SIG{QUIT} = 'IGNORE';
2091 local $SIG{TERM} = 'IGNORE';
2092 local $SIG{TSTP} = 'IGNORE';
2093 local $SIG{PIPE} = 'IGNORE';
2095 my $oldAutoCommit = $FS::UID::AutoCommit;
2096 local $FS::UID::AutoCommit = 0;
2099 my $sql = "UPDATE svc_acct SET $column = ".
2100 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2101 " $op ? WHERE svcnum = ?";
2105 my $sth = $dbh->prepare( $sql )
2106 or die "Error preparing $sql: ". $dbh->errstr;
2107 my $rv = $sth->execute($amount, $self->svcnum);
2108 die "Error executing $sql: ". $sth->errstr
2109 unless defined($rv);
2110 die "Can't update $column for svcnum". $self->svcnum
2113 #$self->snapshot; #not necessary, we retain the old values
2114 #create an object with the updated usage values
2115 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2117 my $error = $new->replace($self);
2119 $dbh->rollback if $oldAutoCommit;
2120 return "Error replacing: $error";
2123 #overlimit_action eq 'cancel' handling
2124 my $cust_pkg = $self->cust_svc->cust_pkg;
2126 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2127 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2131 my $error = $cust_pkg->cancel; #XXX should have a reason
2133 $dbh->rollback if $oldAutoCommit;
2134 return "Error cancelling: $error";
2137 #nothing else is relevant if we're cancelling, so commit & return success
2138 warn "$me update successful; committing\n"
2140 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2145 my $action = $op2action{$op};
2147 if ( &{$op2condition{$op}}($self, $column, $amount) &&
2148 ( $action eq 'suspend' && !$self->overlimit
2149 || $action eq 'unsuspend' && $self->overlimit )
2152 my $error = $self->_op_overlimit($action);
2154 $dbh->rollback if $oldAutoCommit;
2160 if ( $conf->exists("svc_acct-usage_$action")
2161 && &{$op2condition{$op}}($self, $column, $amount) ) {
2162 #my $error = $self->$action();
2163 my $error = $self->cust_svc->cust_pkg->$action();
2164 # $error ||= $self->overlimit($action);
2166 $dbh->rollback if $oldAutoCommit;
2167 return "Error ${action}ing: $error";
2171 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2172 my $wqueue = new FS::queue {
2173 'svcnum' => $self->svcnum,
2174 'job' => 'FS::svc_acct::reached_threshold',
2179 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2183 my $error = $wqueue->insert(
2184 'svcnum' => $self->svcnum,
2186 'column' => $column,
2190 $dbh->rollback if $oldAutoCommit;
2191 return "Error queuing threshold activity: $error";
2195 warn "$me update successful; committing\n"
2197 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2203 my( $self, $action ) = @_;
2205 local $SIG{HUP} = 'IGNORE';
2206 local $SIG{INT} = 'IGNORE';
2207 local $SIG{QUIT} = 'IGNORE';
2208 local $SIG{TERM} = 'IGNORE';
2209 local $SIG{TSTP} = 'IGNORE';
2210 local $SIG{PIPE} = 'IGNORE';
2212 my $oldAutoCommit = $FS::UID::AutoCommit;
2213 local $FS::UID::AutoCommit = 0;
2216 my $cust_pkg = $self->cust_svc->cust_pkg;
2218 my $conf_overlimit =
2220 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2221 : $conf->config('overlimit_groups');
2223 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2225 my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2226 next unless $groups;
2228 my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2230 my $other = new FS::svc_acct $self->hashref;
2231 $other->usergroup( $gref );
2234 if ($action eq 'suspend') {
2237 } else { # $action eq 'unsuspend'
2242 my $error = $part_export->export_replace($new, $old)
2243 || $self->overlimit($action);
2246 $dbh->rollback if $oldAutoCommit;
2247 return "Error replacing radius groups: $error";
2252 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2258 my( $self, $valueref, %options ) = @_;
2260 warn "$me set_usage called for svcnum ". $self->svcnum.
2261 ' ('. $self->email. "): ".
2262 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2265 local $SIG{HUP} = 'IGNORE';
2266 local $SIG{INT} = 'IGNORE';
2267 local $SIG{QUIT} = 'IGNORE';
2268 local $SIG{TERM} = 'IGNORE';
2269 local $SIG{TSTP} = 'IGNORE';
2270 local $SIG{PIPE} = 'IGNORE';
2272 local $FS::svc_Common::noexport_hack = 1;
2273 my $oldAutoCommit = $FS::UID::AutoCommit;
2274 local $FS::UID::AutoCommit = 0;
2279 if ( $options{null} ) {
2280 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2281 qw( seconds upbytes downbytes totalbytes )
2284 foreach my $field (keys %$valueref){
2285 $reset = 1 if $valueref->{$field};
2286 $self->setfield($field, $valueref->{$field});
2287 $self->setfield( $field.'_threshold',
2288 int($self->getfield($field)
2289 * ( $conf->exists('svc_acct-usage_threshold')
2290 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2295 $handyhash{$field} = $self->getfield($field);
2296 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2298 #my $error = $self->replace; #NO! we avoid the call to ->check for
2299 #die $error if $error; #services not explicity changed via the UI
2301 my $sql = "UPDATE svc_acct SET " .
2302 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
2303 " WHERE svcnum = ". $self->svcnum;
2308 if (scalar(keys %handyhash)) {
2309 my $sth = $dbh->prepare( $sql )
2310 or die "Error preparing $sql: ". $dbh->errstr;
2311 my $rv = $sth->execute();
2312 die "Error executing $sql: ". $sth->errstr
2313 unless defined($rv);
2314 die "Can't update usage for svcnum ". $self->svcnum
2318 #$self->snapshot; #not necessary, we retain the old values
2319 #create an object with the updated usage values
2320 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2321 local($FS::Record::nowarn_identical) = 1;
2322 my $error = $new->replace($self); #call exports
2324 $dbh->rollback if $oldAutoCommit;
2325 return "Error replacing: $error";
2332 $error = $self->_op_overlimit('unsuspend')
2333 if $self->overlimit;;
2335 $error ||= $self->cust_svc->cust_pkg->unsuspend
2336 if $conf->exists("svc_acct-usage_unsuspend");
2339 $dbh->rollback if $oldAutoCommit;
2340 return "Error unsuspending: $error";
2345 warn "$me update successful; committing\n"
2347 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2353 =item recharge HASHREF
2355 Increments usage columns by the amount specified in HASHREF as
2356 column=>amount pairs.
2361 my ($self, $vhash) = @_;
2364 warn "[$me] recharge called on $self: ". Dumper($self).
2365 "\nwith vhash: ". Dumper($vhash);
2368 my $oldAutoCommit = $FS::UID::AutoCommit;
2369 local $FS::UID::AutoCommit = 0;
2373 foreach my $column (keys %$vhash){
2374 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2378 $dbh->rollback if $oldAutoCommit;
2380 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2385 =item is_rechargeable
2387 Returns true if this svc_account can be "recharged" and false otherwise.
2391 sub is_rechargable {
2393 $self->seconds ne ''
2394 || $self->upbytes ne ''
2395 || $self->downbytes ne ''
2396 || $self->totalbytes ne '';
2399 =item seconds_since TIMESTAMP
2401 Returns the number of seconds this account has been online since TIMESTAMP,
2402 according to the session monitor (see L<FS::Session>).
2404 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2405 L<Time::Local> and L<Date::Parse> for conversion functions.
2409 #note: POD here, implementation in FS::cust_svc
2412 $self->cust_svc->seconds_since(@_);
2415 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2417 Returns the numbers of seconds this account has been online between
2418 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2419 external SQL radacct table, specified via sqlradius export. Sessions which
2420 started in the specified range but are still open are counted from session
2421 start to the end of the range (unless they are over 1 day old, in which case
2422 they are presumed missing their stop record and not counted). Also, sessions
2423 which end in the range but started earlier are counted from the start of the
2424 range to session end. Finally, sessions which start before the range but end
2425 after are counted for the entire range.
2427 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2428 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2433 #note: POD here, implementation in FS::cust_svc
2434 sub seconds_since_sqlradacct {
2436 $self->cust_svc->seconds_since_sqlradacct(@_);
2439 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2441 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2442 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2443 TIMESTAMP_END (exclusive).
2445 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2446 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2451 #note: POD here, implementation in FS::cust_svc
2452 sub attribute_since_sqlradacct {
2454 $self->cust_svc->attribute_since_sqlradacct(@_);
2457 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2459 Returns an array of hash references of this customers login history for the
2460 given time range. (document this better)
2464 sub get_session_history {
2466 $self->cust_svc->get_session_history(@_);
2469 =item last_login_text
2471 Returns text describing the time of last login.
2475 sub last_login_text {
2477 $self->last_login ? ctime($self->last_login) : 'unknown';
2480 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2485 my($self, $start, $end, %opt ) = @_;
2487 my $did = $self->username; #yup
2489 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2491 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2493 #SELECT $for_update * FROM cdr
2494 # WHERE calldate >= $start #need a conversion
2495 # AND calldate < $end #ditto
2496 # AND ( charged_party = "$did"
2497 # OR charged_party = "$prefix$did" #if length($prefix);
2498 # OR ( ( charged_party IS NULL OR charged_party = '' )
2500 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2503 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2506 if ( length($prefix) ) {
2508 " AND ( charged_party = '$did'
2509 OR charged_party = '$prefix$did'
2510 OR ( ( charged_party IS NULL OR charged_party = '' )
2512 ( src = '$did' OR src = '$prefix$did' )
2518 " AND ( charged_party = '$did'
2519 OR ( ( charged_party IS NULL OR charged_party = '' )
2529 'select' => "$for_update *",
2532 #( freesidestatus IS NULL OR freesidestatus = '' )
2533 'freesidestatus' => '',
2535 'extra_sql' => $charged_or_src,
2543 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2549 if ( $self->usergroup ) {
2550 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2551 unless ref($self->usergroup) eq 'ARRAY';
2552 #when provisioning records, export callback runs in svc_Common.pm before
2553 #radius_usergroup records can be inserted...
2554 @{$self->usergroup};
2556 map { $_->groupname }
2557 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2561 =item clone_suspended
2563 Constructor used by FS::part_export::_export_suspend fallback. Document
2568 sub clone_suspended {
2570 my %hash = $self->hash;
2571 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2572 new FS::svc_acct \%hash;
2575 =item clone_kludge_unsuspend
2577 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2582 sub clone_kludge_unsuspend {
2584 my %hash = $self->hash;
2585 $hash{_password} = '';
2586 new FS::svc_acct \%hash;
2589 =item check_password
2591 Checks the supplied password against the (possibly encrypted) password in the
2592 database. Returns true for a successful authentication, false for no match.
2594 Currently supported encryptions are: classic DES crypt() and MD5
2598 sub check_password {
2599 my($self, $check_password) = @_;
2601 #remove old-style SUSPENDED kludge, they should be allowed to login to
2602 #self-service and pay up
2603 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2605 if ( $self->_password_encoding eq 'ldap' ) {
2607 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2608 return $auth->match($check_password);
2610 } elsif ( $self->_password_encoding eq 'crypt' ) {
2612 my $auth = from_crypt Authen::Passphrase $self->_password;
2613 return $auth->match($check_password);
2615 } elsif ( $self->_password_encoding eq 'plain' ) {
2617 return $check_password eq $password;
2621 #XXX this could be replaced with Authen::Passphrase stuff
2623 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2625 } elsif ( length($password) < 13 ) { #plaintext
2626 $check_password eq $password;
2627 } elsif ( length($password) == 13 ) { #traditional DES crypt
2628 crypt($check_password, $password) eq $password;
2629 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2630 unix_md5_crypt($check_password, $password) eq $password;
2631 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2632 warn "Can't check password: Blowfish encryption not yet supported, ".
2633 "svcnum ". $self->svcnum. "\n";
2636 warn "Can't check password: Unrecognized encryption for svcnum ".
2637 $self->svcnum. "\n";
2645 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2647 Returns an encrypted password, either by passing through an encrypted password
2648 in the database or by encrypting a plaintext password from the database.
2650 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2651 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2652 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2653 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2654 encryption type is only used if the password is not already encrypted in the
2659 sub crypt_password {
2662 if ( $self->_password_encoding eq 'ldap' ) {
2664 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2667 #XXX this could be replaced with Authen::Passphrase stuff
2669 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2670 if ( $encryption eq 'crypt' ) {
2673 $saltset[int(rand(64))].$saltset[int(rand(64))]
2675 } elsif ( $encryption eq 'md5' ) {
2676 unix_md5_crypt( $self->_password );
2677 } elsif ( $encryption eq 'blowfish' ) {
2678 croak "unknown encryption method $encryption";
2680 croak "unknown encryption method $encryption";
2683 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2687 } elsif ( $self->_password_encoding eq 'crypt' ) {
2689 return $self->_password;
2691 } elsif ( $self->_password_encoding eq 'plain' ) {
2693 #XXX this could be replaced with Authen::Passphrase stuff
2695 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2696 if ( $encryption eq 'crypt' ) {
2699 $saltset[int(rand(64))].$saltset[int(rand(64))]
2701 } elsif ( $encryption eq 'md5' ) {
2702 unix_md5_crypt( $self->_password );
2703 } elsif ( $encryption eq 'blowfish' ) {
2704 croak "unknown encryption method $encryption";
2706 croak "unknown encryption method $encryption";
2711 if ( length($self->_password) == 13
2712 || $self->_password =~ /^\$(1|2a?)\$/
2713 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2719 #XXX this could be replaced with Authen::Passphrase stuff
2721 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2722 if ( $encryption eq 'crypt' ) {
2725 $saltset[int(rand(64))].$saltset[int(rand(64))]
2727 } elsif ( $encryption eq 'md5' ) {
2728 unix_md5_crypt( $self->_password );
2729 } elsif ( $encryption eq 'blowfish' ) {
2730 croak "unknown encryption method $encryption";
2732 croak "unknown encryption method $encryption";
2741 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2743 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2744 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2745 "{MD5}5426824942db4253f87a1009fd5d2d4".
2747 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2748 to work the same as the B</crypt_password> method.
2754 #eventually should check a "password-encoding" field
2756 if ( $self->_password_encoding eq 'ldap' ) {
2758 return $self->_password;
2760 } elsif ( $self->_password_encoding eq 'crypt' ) {
2762 if ( length($self->_password) == 13 ) { #crypt
2763 return '{CRYPT}'. $self->_password;
2764 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2766 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2767 # die "Blowfish encryption not supported in this context, svcnum ".
2768 # $self->svcnum. "\n";
2770 warn "encryption method not (yet?) supported in LDAP context";
2771 return '{CRYPT}*'; #unsupported, should not auth
2774 } elsif ( $self->_password_encoding eq 'plain' ) {
2776 return '{PLAIN}'. $self->_password;
2778 #return '{CLEARTEXT}'. $self->_password; #?
2782 if ( length($self->_password) == 13 ) { #crypt
2783 return '{CRYPT}'. $self->_password;
2784 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2786 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2787 warn "Blowfish encryption not supported in this context, svcnum ".
2788 $self->svcnum. "\n";
2791 #are these two necessary anymore?
2792 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2793 return '{SSHA}'. $1;
2794 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2795 return '{NS-MTA-MD5}'. $1;
2798 return '{PLAIN}'. $self->_password;
2800 #return '{CLEARTEXT}'. $self->_password; #?
2802 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2803 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2804 #if ( $encryption eq 'crypt' ) {
2805 # return '{CRYPT}'. crypt(
2807 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2809 #} elsif ( $encryption eq 'md5' ) {
2810 # unix_md5_crypt( $self->_password );
2811 #} elsif ( $encryption eq 'blowfish' ) {
2812 # croak "unknown encryption method $encryption";
2814 # croak "unknown encryption method $encryption";
2822 =item domain_slash_username
2824 Returns $domain/$username/
2828 sub domain_slash_username {
2830 $self->domain. '/'. $self->username. '/';
2833 =item virtual_maildir
2835 Returns $domain/maildirs/$username/
2839 sub virtual_maildir {
2841 $self->domain. '/maildirs/'. $self->username. '/';
2846 =head1 CLASS METHODS
2850 =item search HASHREF
2852 Class method which returns a qsearch hash expression to search for parameters
2853 specified in HASHREF. Valid parameters are
2867 Arrayref of pkgparts
2873 Arrayref of additional WHERE clauses, will be ANDed together.
2884 my ($class, $params) = @_;
2889 if ( $params->{'domain'} ) {
2890 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2891 #preserve previous behavior & bubble up an error if $svc_domain not found?
2892 push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2896 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2897 push @where, "domsvc = $1";
2901 push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2904 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2905 push @where, "agentnum = $1";
2909 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2910 push @where, "custnum = $1";
2914 if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2915 #XXX untaint or sql quote
2917 'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2921 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2922 push @where, "popnum = $1";
2926 if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2927 push @where, "svcpart = $1";
2931 # here is the agent virtualization
2932 #if ($params->{CurrentUser}) {
2934 # qsearchs('access_user', { username => $params->{CurrentUser} });
2936 # if ($access_user) {
2937 # push @where, $access_user->agentnums_sql('table'=>'cust_main');
2939 # push @where, "1=0";
2942 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2943 'table' => 'cust_main',
2944 'null_right' => 'View/link unlinked services',
2948 push @where, @{ $params->{'where'} } if $params->{'where'};
2950 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2952 my $addl_from = ' LEFT JOIN cust_svc USING ( svcnum ) '.
2953 ' LEFT JOIN part_svc USING ( svcpart ) '.
2954 ' LEFT JOIN cust_pkg USING ( pkgnum ) '.
2955 ' LEFT JOIN cust_main USING ( custnum ) ';
2957 my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2958 #if ( keys %svc_acct ) {
2959 # $count_query .= ' WHERE '.
2960 # join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2966 'table' => 'svc_acct',
2967 'hashref' => {}, # \%svc_acct,
2968 'select' => join(', ',
2971 'cust_main.custnum',
2972 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2974 'addl_from' => $addl_from,
2975 'extra_sql' => $extra_sql,
2976 'order_by' => $params->{'order_by'},
2977 'count_query' => $count_query,
2990 This is the FS::svc_acct job-queue-able version. It still uses
2991 FS::Misc::send_email under-the-hood.
2998 eval "use FS::Misc qw(send_email)";
3001 $opt{mimetype} ||= 'text/plain';
3002 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3004 my $error = send_email(
3005 'from' => $opt{from},
3007 'subject' => $opt{subject},
3008 'content-type' => $opt{mimetype},
3009 'body' => [ map "$_\n", split("\n", $opt{body}) ],
3011 die $error if $error;
3014 =item check_and_rebuild_fuzzyfiles
3018 sub check_and_rebuild_fuzzyfiles {
3019 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3020 -e "$dir/svc_acct.username"
3021 or &rebuild_fuzzyfiles;
3024 =item rebuild_fuzzyfiles
3028 sub rebuild_fuzzyfiles {
3030 use Fcntl qw(:flock);
3032 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3036 open(USERNAMELOCK,">>$dir/svc_acct.username")
3037 or die "can't open $dir/svc_acct.username: $!";
3038 flock(USERNAMELOCK,LOCK_EX)
3039 or die "can't lock $dir/svc_acct.username: $!";
3041 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
3043 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
3044 or die "can't open $dir/svc_acct.username.tmp: $!";
3045 print USERNAMECACHE join("\n", @all_username), "\n";
3046 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
3048 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
3058 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3059 open(USERNAMECACHE,"<$dir/svc_acct.username")
3060 or die "can't open $dir/svc_acct.username: $!";
3061 my @array = map { chomp; $_; } <USERNAMECACHE>;
3062 close USERNAMECACHE;
3066 =item append_fuzzyfiles USERNAME
3070 sub append_fuzzyfiles {
3071 my $username = shift;
3073 &check_and_rebuild_fuzzyfiles;
3075 use Fcntl qw(:flock);
3077 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3079 open(USERNAME,">>$dir/svc_acct.username")
3080 or die "can't open $dir/svc_acct.username: $!";
3081 flock(USERNAME,LOCK_EX)
3082 or die "can't lock $dir/svc_acct.username: $!";
3084 print USERNAME "$username\n";
3086 flock(USERNAME,LOCK_UN)
3087 or die "can't unlock $dir/svc_acct.username: $!";
3095 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
3099 sub radius_usergroup_selector {
3100 my $sel_groups = shift;
3101 my %sel_groups = map { $_=>1 } @$sel_groups;
3103 my $selectname = shift || 'radius_usergroup';
3106 my $sth = $dbh->prepare(
3107 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
3108 ) or die $dbh->errstr;
3109 $sth->execute() or die $sth->errstr;
3110 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
3114 function ${selectname}_doadd(object) {
3115 var myvalue = object.${selectname}_add.value;
3116 var optionName = new Option(myvalue,myvalue,false,true);
3117 var length = object.$selectname.length;
3118 object.$selectname.options[length] = optionName;
3119 object.${selectname}_add.value = "";
3122 <SELECT MULTIPLE NAME="$selectname">
3125 foreach my $group ( @all_groups ) {
3126 $html .= qq(<OPTION VALUE="$group");
3127 if ( $sel_groups{$group} ) {
3128 $html .= ' SELECTED';
3129 $sel_groups{$group} = 0;
3131 $html .= ">$group</OPTION>\n";
3133 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
3134 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
3136 $html .= '</SELECT>';
3138 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
3139 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
3144 =item reached_threshold
3146 Performs some activities when svc_acct thresholds (such as number of seconds
3147 remaining) are reached.
3151 sub reached_threshold {
3154 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3155 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3157 if ( $opt{'op'} eq '+' ){
3158 $svc_acct->setfield( $opt{'column'}.'_threshold',
3159 int($svc_acct->getfield($opt{'column'})
3160 * ( $conf->exists('svc_acct-usage_threshold')
3161 ? $conf->config('svc_acct-usage_threshold')/100
3166 my $error = $svc_acct->replace;
3167 die $error if $error;
3168 }elsif ( $opt{'op'} eq '-' ){
3170 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3171 return '' if ($threshold eq '' );
3173 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3174 my $error = $svc_acct->replace;
3175 die $error if $error; # email next time, i guess
3177 if ( $warning_template ) {
3178 eval "use FS::Misc qw(send_email)";
3181 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
3182 my $cust_main = $cust_pkg->cust_main;
3184 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3185 $cust_main->invoicing_list,
3186 ($opt{'to'} ? $opt{'to'} : ())
3189 my $mimetype = $warning_mimetype;
3190 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3192 my $body = $warning_template->fill_in( HASH => {
3193 'custnum' => $cust_main->custnum,
3194 'username' => $svc_acct->username,
3195 'password' => $svc_acct->_password,
3196 'first' => $cust_main->first,
3197 'last' => $cust_main->getfield('last'),
3198 'pkg' => $cust_pkg->part_pkg->pkg,
3199 'column' => $opt{'column'},
3200 'amount' => $opt{'column'} =~/bytes/
3201 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3202 : $svc_acct->getfield($opt{'column'}),
3203 'threshold' => $opt{'column'} =~/bytes/
3204 ? FS::UI::bytecount::display_bytecount($threshold)
3209 my $error = send_email(
3210 'from' => $warning_from,
3212 'subject' => $warning_subject,
3213 'content-type' => $mimetype,
3214 'body' => [ map "$_\n", split("\n", $body) ],
3216 die $error if $error;
3219 die "unknown op: " . $opt{'op'};
3227 The $recref stuff in sub check should be cleaned up.
3229 The suspend, unsuspend and cancel methods update the database, but not the
3230 current object. This is probably a bug as it's unexpected and
3233 radius_usergroup_selector? putting web ui components in here? they should
3234 probably live somewhere else...
3236 insertion of RADIUS group stuff in insert could be done with child_objects now
3237 (would probably clean up export of them too)
3239 _op_usage and set_usage bypass the history... maybe they shouldn't
3243 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3244 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3245 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3246 L<freeside-queued>), L<FS::svc_acct_pop>,
3247 schema.html from the base documentation.