4 use base qw( FS::svc_Domain_Mixin FS::svc_CGP_Mixin FS::svc_CGPRule_Mixin
6 use vars qw( $DEBUG $me $conf $skip_fuzzyfiles
7 $dir_prefix @shells $usernamemin
8 $usernamemax $passwordmin $passwordmax
9 $username_ampersand $username_letter $username_letterfirst
10 $username_noperiod $username_nounderscore $username_nodash
11 $username_uppercase $username_percent $username_colon
12 $password_noampersand $password_noexclamation
13 $warning_template $warning_from $warning_subject $warning_mimetype
16 $radius_password $radius_ip
19 use Scalar::Util qw( blessed );
24 use Crypt::PasswdMD5 1.2;
25 use Digest::SHA1 'sha1_base64';
26 use Digest::MD5 'md5_base64';
29 use Authen::Passphrase;
30 use FS::UID qw( datasrc driver_name );
32 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
33 use FS::Msgcat qw(gettext);
34 use FS::UI::bytecount;
39 use FS::cust_main_invoice;
44 use FS::radius_usergroup;
52 $me = '[FS::svc_acct]';
54 #ask FS::UID to run this stuff for us later
55 FS::UID->install_callback( sub {
57 $dir_prefix = $conf->config('home');
58 @shells = $conf->config('shells');
59 $usernamemin = $conf->config('usernamemin') || 2;
60 $usernamemax = $conf->config('usernamemax');
61 $passwordmin = $conf->config('passwordmin'); # || 6;
63 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
66 $passwordmax = $conf->config('passwordmax') || 8;
67 $username_letter = $conf->exists('username-letter');
68 $username_letterfirst = $conf->exists('username-letterfirst');
69 $username_noperiod = $conf->exists('username-noperiod');
70 $username_nounderscore = $conf->exists('username-nounderscore');
71 $username_nodash = $conf->exists('username-nodash');
72 $username_uppercase = $conf->exists('username-uppercase');
73 $username_ampersand = $conf->exists('username-ampersand');
74 $username_percent = $conf->exists('username-percent');
75 $username_colon = $conf->exists('username-colon');
76 $password_noampersand = $conf->exists('password-noexclamation');
77 $password_noexclamation = $conf->exists('password-noexclamation');
78 $dirhash = $conf->config('dirhash') || 0;
79 if ( $conf->exists('warning_email') ) {
80 $warning_template = new Text::Template (
82 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
83 ) or warn "can't create warning email template: $Text::Template::ERROR";
84 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
85 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
86 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
87 $warning_cc = $conf->config('warning_email-cc');
89 $warning_template = '';
91 $warning_subject = '';
92 $warning_mimetype = '';
95 $smtpmachine = $conf->config('smtpmachine');
96 $radius_password = $conf->config('radius-password') || 'Password';
97 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
98 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
102 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
103 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
107 my ( $hashref, $cache ) = @_;
108 if ( $hashref->{'svc_acct_svcnum'} ) {
109 $self->{'_domsvc'} = FS::svc_domain->new( {
110 'svcnum' => $hashref->{'domsvc'},
111 'domain' => $hashref->{'svc_acct_domain'},
112 'catchall' => $hashref->{'svc_acct_catchall'},
119 FS::svc_acct - Object methods for svc_acct records
125 $record = new FS::svc_acct \%hash;
126 $record = new FS::svc_acct { 'column' => 'value' };
128 $error = $record->insert;
130 $error = $new_record->replace($old_record);
132 $error = $record->delete;
134 $error = $record->check;
136 $error = $record->suspend;
138 $error = $record->unsuspend;
140 $error = $record->cancel;
142 %hash = $record->radius;
144 %hash = $record->radius_reply;
146 %hash = $record->radius_check;
148 $domain = $record->domain;
150 $svc_domain = $record->svc_domain;
152 $email = $record->email;
154 $seconds_since = $record->seconds_since($timestamp);
158 An FS::svc_acct object represents an account. FS::svc_acct inherits from
159 FS::svc_Common. The following fields are currently supported:
165 Primary key (assigned automatcially for new accounts)
173 =item _password_encoding
175 plain, crypt, ldap (or empty for autodetection)
183 Point of presence (see L<FS::svc_acct_pop>)
195 set automatically if blank (and uid is not)
215 svcnum from svc_domain
219 Optional svcnum from svc_pbx
221 =item radius_I<Radius_Attribute>
223 I<Radius-Attribute> (reply)
225 =item rc_I<Radius_Attribute>
227 I<Radius-Attribute> (check)
237 Creates a new account. To add the account to the database, see L<"insert">.
244 'longname_plural' => 'Access accounts and mailboxes',
245 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
246 'display_weight' => 10,
247 'cancel_weight' => 50,
249 'dir' => 'Home directory',
252 def_info => 'set to fixed and blank for no UIDs',
255 'slipip' => 'IP address',
256 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
258 label => 'Access number',
260 select_table => 'svc_acct_pop',
261 select_key => 'popnum',
262 select_label => 'city',
268 disable_default => 1,
272 'password_selfchange' => { label => 'Password modification',
275 'password_recover' => { label => 'Password recovery',
279 label => 'Quota', #Mail storage limit
281 disable_inventory => 1,
285 label => 'File storage limit',
287 disable_inventory => 1,
291 label => 'Number of files limit',
293 disable_inventory => 1,
297 label => 'File size limit',
299 disable_inventory => 1,
302 '_password' => 'Password',
305 def_info => 'when blank, defaults to UID',
310 def_info => 'set to blank for no shell tracking',
312 #select_list => [ $conf->config('shells') ],
313 select_list => [ $conf ? $conf->config('shells') : () ],
314 disable_inventory => 1,
317 'finger' => 'Real name', # (GECOS)',
321 select_table => 'svc_domain',
322 select_key => 'svcnum',
323 select_label => 'domain',
324 disable_inventory => 1,
326 'pbxsvc' => { label => 'PBX',
327 type => 'select-svc_pbx.html',
328 disable_inventory => 1,
329 disable_select => 1, #UI wonky, pry works otherwise
332 label => 'RADIUS groups',
333 type => 'radius_usergroup_selector',
334 disable_inventory => 1,
337 'seconds' => { label => 'Seconds',
338 label_sort => 'with Time Remaining',
340 disable_inventory => 1,
342 disable_part_svc_column => 1,
344 'upbytes' => { label => 'Upload',
346 disable_inventory => 1,
348 'format' => \&FS::UI::bytecount::display_bytecount,
349 'parse' => \&FS::UI::bytecount::parse_bytecount,
350 disable_part_svc_column => 1,
352 'downbytes' => { label => 'Download',
354 disable_inventory => 1,
356 'format' => \&FS::UI::bytecount::display_bytecount,
357 'parse' => \&FS::UI::bytecount::parse_bytecount,
358 disable_part_svc_column => 1,
360 'totalbytes'=> { label => 'Total up and download',
362 disable_inventory => 1,
364 'format' => \&FS::UI::bytecount::display_bytecount,
365 'parse' => \&FS::UI::bytecount::parse_bytecount,
366 disable_part_svc_column => 1,
368 'seconds_threshold' => { label => 'Seconds threshold',
370 disable_inventory => 1,
372 disable_part_svc_column => 1,
374 'upbytes_threshold' => { label => 'Upload threshold',
376 disable_inventory => 1,
378 'format' => \&FS::UI::bytecount::display_bytecount,
379 'parse' => \&FS::UI::bytecount::parse_bytecount,
380 disable_part_svc_column => 1,
382 'downbytes_threshold' => { label => 'Download threshold',
384 disable_inventory => 1,
386 'format' => \&FS::UI::bytecount::display_bytecount,
387 'parse' => \&FS::UI::bytecount::parse_bytecount,
388 disable_part_svc_column => 1,
390 'totalbytes_threshold'=> { label => 'Total up and download threshold',
392 disable_inventory => 1,
394 'format' => \&FS::UI::bytecount::display_bytecount,
395 'parse' => \&FS::UI::bytecount::parse_bytecount,
396 disable_part_svc_column => 1,
399 label => 'Last login',
403 label => 'Last logout',
408 label => 'Communigate aliases',
410 disable_inventory => 1,
415 label => 'Communigate account type',
417 select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )],
418 disable_inventory => 1,
421 'cgp_accessmodes' => {
422 label => 'Communigate enabled services',
423 type => 'communigate_pro-accessmodes',
424 disable_inventory => 1,
427 'cgp_rulesallowed' => {
428 label => 'Allowed mail rules',
430 select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ],
431 disable_inventory => 1,
434 'cgp_rpopallowed' => { label => 'RPOP modifications',
437 'cgp_mailtoall' => { label => 'Accepts mail to "all"',
440 'cgp_addmailtrailer' => { label => 'Add trailer to sent mail',
443 'cgp_archiveafter' => {
444 label => 'Archive messages after',
447 -2 => 'default(730 days)',
454 1209600 => '2 weeks',
455 2592000 => '30 days',
456 7776000 => '90 days',
457 15552000 => '180 days',
458 31536000 => '365 days',
459 63072000 => '730 days',
461 disable_inventory => 1,
467 'cgp_deletemode' => {
468 label => 'Communigate message delete method',
470 select_list => [ 'Move To Trash', 'Immediately', 'Mark' ],
471 disable_inventory => 1,
474 'cgp_emptytrash' => {
475 label => 'Communigate on logout remove trash',
477 select_list => __PACKAGE__->cgp_emptytrash_values,
478 disable_inventory => 1,
482 label => 'Communigate language',
484 select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ],
485 disable_inventory => 1,
489 label => 'Communigate time zone',
491 select_list => __PACKAGE__->cgp_timezone_values,
492 disable_inventory => 1,
496 label => 'Communigate layout',
498 select_list => [ '', '***', 'GoldFleece', 'Skin2' ],
499 disable_inventory => 1,
502 'cgp_prontoskinname' => {
503 label => 'Communigate Pronto style',
505 select_list => [ '', 'Pronto', 'Pronto-darkflame', 'Pronto-steel', 'Pronto-twilight', ],
506 disable_inventory => 1,
509 'cgp_sendmdnmode' => {
510 label => 'Communigate send read receipts',
512 select_list => [ '', 'Never', 'Manually', 'Automatically' ],
513 disable_inventory => 1,
524 sub table { 'svc_acct'; }
526 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
530 #false laziness with edit/svc_acct.cgi
532 my( $self, $groups ) = @_;
533 if ( ref($groups) eq 'ARRAY' ) {
535 } elsif ( length($groups) ) {
536 [ split(/\s*,\s*/, $groups) ];
545 shift->_lastlog('in', @_);
549 shift->_lastlog('out', @_);
553 my( $self, $op, $time ) = @_;
555 if ( defined($time) ) {
556 warn "$me last_log$op called on svcnum ". $self->svcnum.
557 ' ('. $self->email. "): $time\n"
562 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
566 my $sth = $dbh->prepare( $sql )
567 or die "Error preparing $sql: ". $dbh->errstr;
568 my $rv = $sth->execute($time, $self->svcnum);
569 die "Error executing $sql: ". $sth->errstr
571 die "Can't update last_log$op for svcnum". $self->svcnum
574 $self->{'Hash'}->{"last_log$op"} = $time;
576 $self->getfield("last_log$op");
580 =item search_sql STRING
582 Class method which returns an SQL fragment to search for the given string.
587 my( $class, $string ) = @_;
588 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
589 my( $username, $domain ) = ( $1, $2 );
590 my $q_username = dbh->quote($username);
591 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
593 "svc_acct.username = $q_username AND ( ".
594 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
599 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
601 $class->search_sql_field('slipip', $string ).
603 $class->search_sql_field('username', $string ).
606 $class->search_sql_field('username', $string);
610 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
612 Returns the "username@domain" string for this account.
614 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
624 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
626 Returns a longer string label for this acccount ("Real Name <username@domain>"
627 if available, or "username@domain").
629 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
636 my $label = $self->label(@_);
637 my $finger = $self->finger;
638 return $label unless $finger =~ /\S/;
639 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
640 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
644 =item insert [ , OPTION => VALUE ... ]
646 Adds this account to the database. If there is an error, returns the error,
647 otherwise returns false.
649 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
650 defined. An FS::cust_svc record will be created and inserted.
652 The additional field I<usergroup> can optionally be defined; if so it should
653 contain an arrayref of group names. See L<FS::radius_usergroup>.
655 The additional field I<child_objects> can optionally be defined; if so it
656 should contain an arrayref of FS::tablename objects. They will have their
657 svcnum fields set and will be inserted after this record, but before any
658 exports are run. Each element of the array can also optionally be a
659 two-element array reference containing the child object and the name of an
660 alternate field to be filled in with the newly-inserted svcnum, for example
661 C<[ $svc_forward, 'srcsvc' ]>
663 Currently available options are: I<depend_jobnum>
665 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
666 jobnums), all provisioning jobs will have a dependancy on the supplied
667 jobnum(s) (they will not run until the specific job(s) complete(s)).
669 (TODOC: L<FS::queue> and L<freeside-queued>)
671 (TODOC: new exports!)
680 warn "[$me] insert called on $self: ". Dumper($self).
681 "\nwith options: ". Dumper(%options);
684 local $SIG{HUP} = 'IGNORE';
685 local $SIG{INT} = 'IGNORE';
686 local $SIG{QUIT} = 'IGNORE';
687 local $SIG{TERM} = 'IGNORE';
688 local $SIG{TSTP} = 'IGNORE';
689 local $SIG{PIPE} = 'IGNORE';
691 my $oldAutoCommit = $FS::UID::AutoCommit;
692 local $FS::UID::AutoCommit = 0;
696 my $error = $self->SUPER::insert(
697 'jobnums' => \@jobnums,
698 'child_objects' => $self->child_objects,
702 $dbh->rollback if $oldAutoCommit;
706 if ( $self->usergroup ) {
707 foreach my $groupname ( @{$self->usergroup} ) {
708 my $radius_usergroup = new FS::radius_usergroup ( {
709 svcnum => $self->svcnum,
710 groupname => $groupname,
712 my $error = $radius_usergroup->insert;
714 $dbh->rollback if $oldAutoCommit;
720 unless ( $skip_fuzzyfiles ) {
721 $error = $self->queue_fuzzyfiles_update;
723 $dbh->rollback if $oldAutoCommit;
724 return "updating fuzzy search cache: $error";
728 my $cust_pkg = $self->cust_svc->cust_pkg;
731 my $cust_main = $cust_pkg->cust_main;
732 my $agentnum = $cust_main->agentnum;
734 if ( $conf->exists('emailinvoiceautoalways')
735 || $conf->exists('emailinvoiceauto')
736 && ! $cust_main->invoicing_list_emailonly
738 my @invoicing_list = $cust_main->invoicing_list;
739 push @invoicing_list, $self->email;
740 $cust_main->invoicing_list(\@invoicing_list);
745 my $msgnum = $conf->config('welcome_msgnum', $agentnum);
747 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
748 $error = $msg_template->send('cust_main' => $cust_main);
751 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
752 = ('','','','','','');
754 if ( $conf->exists('welcome_email', $agentnum) ) {
755 $welcome_template = new Text::Template (
757 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
758 ) or warn "can't create welcome email template: $Text::Template::ERROR";
759 $welcome_from = $conf->config('welcome_email-from', $agentnum);
760 # || 'your-isp-is-dum'
761 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
763 $welcome_subject_template = new Text::Template (
765 SOURCE => $welcome_subject,
766 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
767 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
770 if ( $welcome_template ) {
771 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
775 'custnum' => $self->custnum,
776 'username' => $self->username,
777 'password' => $self->_password,
778 'first' => $cust_main->first,
779 'last' => $cust_main->getfield('last'),
780 'pkg' => $cust_pkg->part_pkg->pkg,
782 my $wqueue = new FS::queue {
783 'svcnum' => $self->svcnum,
784 'job' => 'FS::svc_acct::send_email'
786 my $error = $wqueue->insert(
788 'from' => $welcome_from,
789 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
790 'mimetype' => $welcome_mimetype,
791 'body' => $welcome_template->fill_in( HASH => \%hash, ),
794 $dbh->rollback if $oldAutoCommit;
795 return "error queuing welcome email: $error";
798 if ( $options{'depend_jobnum'} ) {
799 warn "$me depend_jobnum found; adding to welcome email dependancies"
801 if ( ref($options{'depend_jobnum'}) ) {
802 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
803 "to welcome email dependancies"
805 push @jobnums, @{ $options{'depend_jobnum'} };
807 warn "$me adding job $options{'depend_jobnum'} ".
808 "to welcome email dependancies"
810 push @jobnums, $options{'depend_jobnum'};
814 foreach my $jobnum ( @jobnums ) {
815 my $error = $wqueue->depend_insert($jobnum);
817 $dbh->rollback if $oldAutoCommit;
818 return "error queuing welcome email job dependancy: $error";
824 } # if $welcome_template
828 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
832 # set usage fields and thresholds if unset but set in a package def
833 # AND the package already has a last bill date (otherwise they get double added)
834 sub preinsert_hook_first {
837 return '' unless $self->pkgnum;
839 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
840 return '' unless $cust_pkg && $cust_pkg->last_bill;
842 my $part_pkg = $cust_pkg->part_pkg;
843 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
845 my %values = $part_pkg->usage_valuehash;
846 my $multiplier = $conf->exists('svc_acct-usage_threshold')
847 ? 1 - $conf->config('svc_acct-usage_threshold')/100
848 : 0.20; #doesn't matter
850 foreach ( keys %values ) {
851 next if $self->getfield($_);
852 $self->setfield( $_, $values{$_} );
853 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
854 if $conf->exists('svc_acct-usage_threshold');
862 Deletes this account from the database. If there is an error, returns the
863 error, otherwise returns false.
865 The corresponding FS::cust_svc record will be deleted as well.
867 (TODOC: new exports!)
874 return "can't delete system account" if $self->_check_system;
876 return "Can't delete an account which is a (svc_forward) source!"
877 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
879 return "Can't delete an account which is a (svc_forward) destination!"
880 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
882 return "Can't delete an account with (svc_www) web service!"
883 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
885 # what about records in session ? (they should refer to history table)
887 local $SIG{HUP} = 'IGNORE';
888 local $SIG{INT} = 'IGNORE';
889 local $SIG{QUIT} = 'IGNORE';
890 local $SIG{TERM} = 'IGNORE';
891 local $SIG{TSTP} = 'IGNORE';
892 local $SIG{PIPE} = 'IGNORE';
894 my $oldAutoCommit = $FS::UID::AutoCommit;
895 local $FS::UID::AutoCommit = 0;
898 foreach my $cust_main_invoice (
899 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
901 unless ( defined($cust_main_invoice) ) {
902 warn "WARNING: something's wrong with qsearch";
905 my %hash = $cust_main_invoice->hash;
906 $hash{'dest'} = $self->email;
907 my $new = new FS::cust_main_invoice \%hash;
908 my $error = $new->replace($cust_main_invoice);
910 $dbh->rollback if $oldAutoCommit;
915 foreach my $svc_domain (
916 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
918 my %hash = new FS::svc_domain->hash;
919 $hash{'catchall'} = '';
920 my $new = new FS::svc_domain \%hash;
921 my $error = $new->replace($svc_domain);
923 $dbh->rollback if $oldAutoCommit;
928 my $error = $self->SUPER::delete;
930 $dbh->rollback if $oldAutoCommit;
934 foreach my $radius_usergroup (
935 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
937 my $error = $radius_usergroup->delete;
939 $dbh->rollback if $oldAutoCommit;
944 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
948 =item replace OLD_RECORD
950 Replaces OLD_RECORD with this one in the database. If there is an error,
951 returns the error, otherwise returns false.
953 The additional field I<usergroup> can optionally be defined; if so it should
954 contain an arrayref of group names. See L<FS::radius_usergroup>.
962 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
966 warn "$me replacing $old with $new\n" if $DEBUG;
970 return "can't modify system account" if $old->_check_system;
973 #no warnings 'numeric'; #alas, a 5.006-ism
976 foreach my $xid (qw( uid gid )) {
978 return "Can't change $xid!"
979 if ! $conf->exists("svc_acct-edit_$xid")
980 && $old->$xid() != $new->$xid()
981 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
986 #change homdir when we change username
987 $new->setfield('dir', '') if $old->username ne $new->username;
989 local $SIG{HUP} = 'IGNORE';
990 local $SIG{INT} = 'IGNORE';
991 local $SIG{QUIT} = 'IGNORE';
992 local $SIG{TERM} = 'IGNORE';
993 local $SIG{TSTP} = 'IGNORE';
994 local $SIG{PIPE} = 'IGNORE';
996 my $oldAutoCommit = $FS::UID::AutoCommit;
997 local $FS::UID::AutoCommit = 0;
1000 # redundant, but so $new->usergroup gets set
1001 $error = $new->check;
1002 return $error if $error;
1004 $old->usergroup( [ $old->radius_groups ] );
1006 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
1007 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
1009 if ( $new->usergroup ) {
1010 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
1011 my @newgroups = @{$new->usergroup};
1012 foreach my $oldgroup ( @{$old->usergroup} ) {
1013 if ( grep { $oldgroup eq $_ } @newgroups ) {
1014 @newgroups = grep { $oldgroup ne $_ } @newgroups;
1017 my $radius_usergroup = qsearchs('radius_usergroup', {
1018 svcnum => $old->svcnum,
1019 groupname => $oldgroup,
1021 my $error = $radius_usergroup->delete;
1023 $dbh->rollback if $oldAutoCommit;
1024 return "error deleting radius_usergroup $oldgroup: $error";
1028 foreach my $newgroup ( @newgroups ) {
1029 my $radius_usergroup = new FS::radius_usergroup ( {
1030 svcnum => $new->svcnum,
1031 groupname => $newgroup,
1033 my $error = $radius_usergroup->insert;
1035 $dbh->rollback if $oldAutoCommit;
1036 return "error adding radius_usergroup $newgroup: $error";
1042 $error = $new->SUPER::replace($old, @_);
1044 $dbh->rollback if $oldAutoCommit;
1045 return $error if $error;
1048 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1049 $error = $new->queue_fuzzyfiles_update;
1051 $dbh->rollback if $oldAutoCommit;
1052 return "updating fuzzy search cache: $error";
1056 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1060 =item queue_fuzzyfiles_update
1062 Used by insert & replace to update the fuzzy search cache
1066 sub queue_fuzzyfiles_update {
1069 local $SIG{HUP} = 'IGNORE';
1070 local $SIG{INT} = 'IGNORE';
1071 local $SIG{QUIT} = 'IGNORE';
1072 local $SIG{TERM} = 'IGNORE';
1073 local $SIG{TSTP} = 'IGNORE';
1074 local $SIG{PIPE} = 'IGNORE';
1076 my $oldAutoCommit = $FS::UID::AutoCommit;
1077 local $FS::UID::AutoCommit = 0;
1080 my $queue = new FS::queue {
1081 'svcnum' => $self->svcnum,
1082 'job' => 'FS::svc_acct::append_fuzzyfiles'
1084 my $error = $queue->insert($self->username);
1086 $dbh->rollback if $oldAutoCommit;
1087 return "queueing job (transaction rolled back): $error";
1090 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1098 Suspends this account by calling export-specific suspend hooks. If there is
1099 an error, returns the error, otherwise returns false.
1101 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1107 return "can't suspend system account" if $self->_check_system;
1108 $self->SUPER::suspend(@_);
1113 Unsuspends this account by by calling export-specific suspend hooks. If there
1114 is an error, returns the error, otherwise returns false.
1116 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1122 my %hash = $self->hash;
1123 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1124 $hash{_password} = $1;
1125 my $new = new FS::svc_acct ( \%hash );
1126 my $error = $new->replace($self);
1127 return $error if $error;
1130 $self->SUPER::unsuspend(@_);
1135 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1137 If the B<auto_unset_catchall> configuration option is set, this method will
1138 automatically remove any references to the canceled service in the catchall
1139 field of svc_domain. This allows packages that contain both a svc_domain and
1140 its catchall svc_acct to be canceled in one step.
1145 # Only one thing to do at this level
1147 foreach my $svc_domain (
1148 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1149 if($conf->exists('auto_unset_catchall')) {
1150 my %hash = $svc_domain->hash;
1151 $hash{catchall} = '';
1152 my $new = new FS::svc_domain ( \%hash );
1153 my $error = $new->replace($svc_domain);
1154 return $error if $error;
1156 return "cannot unprovision svc_acct #".$self->svcnum.
1157 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1161 $self->SUPER::cancel(@_);
1167 Checks all fields to make sure this is a valid service. If there is an error,
1168 returns the error, otherwise returns false. Called by the insert and replace
1171 Sets any fixed values; see L<FS::part_svc>.
1178 my($recref) = $self->hashref;
1180 my $x = $self->setfixed( $self->_fieldhandlers );
1181 return $x unless ref($x);
1184 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1186 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1189 my $error = $self->ut_numbern('svcnum')
1190 #|| $self->ut_number('domsvc')
1191 || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1192 || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx', 'svcnum' )
1193 || $self->ut_textn('sec_phrase')
1194 || $self->ut_snumbern('seconds')
1195 || $self->ut_snumbern('upbytes')
1196 || $self->ut_snumbern('downbytes')
1197 || $self->ut_snumbern('totalbytes')
1198 || $self->ut_snumbern('seconds_threshold')
1199 || $self->ut_snumbern('upbytes_threshold')
1200 || $self->ut_snumbern('downbytes_threshold')
1201 || $self->ut_snumbern('totalbytes_threshold')
1202 || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1203 || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1204 || $self->ut_enum('password_recover', [ '', 'Y' ])
1205 || $self->ut_textn('cgp_accessmodes')
1206 || $self->ut_alphan('cgp_type')
1207 || $self->ut_textn('cgp_aliases' ) #well
1209 || $self->ut_alphasn('cgp_rulesallowed')
1210 || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1211 || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1212 || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1213 || $self->ut_snumbern('cgp_archiveafter')
1215 || $self->ut_alphasn('cgp_deletemode')
1216 || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1217 || $self->ut_alphan('cgp_language')
1218 || $self->ut_textn('cgp_timezone')
1219 || $self->ut_textn('cgp_skinname')
1220 || $self->ut_textn('cgp_prontoskinname')
1221 || $self->ut_alphan('cgp_sendmdnmode')
1224 return $error if $error;
1227 local $username_letter = $username_letter;
1228 if ($self->svcnum) {
1229 my $cust_svc = $self->cust_svc
1230 or return "no cust_svc record found for svcnum ". $self->svcnum;
1231 my $cust_pkg = $cust_svc->cust_pkg;
1233 if ($self->pkgnum) {
1234 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1238 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1241 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1242 if ( $username_uppercase ) {
1243 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1244 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1245 $recref->{username} = $1;
1247 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1248 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1249 $recref->{username} = $1;
1252 if ( $username_letterfirst ) {
1253 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1254 } elsif ( $username_letter ) {
1255 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1257 if ( $username_noperiod ) {
1258 $recref->{username} =~ /\./ and return gettext('illegal_username');
1260 if ( $username_nounderscore ) {
1261 $recref->{username} =~ /_/ and return gettext('illegal_username');
1263 if ( $username_nodash ) {
1264 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1266 unless ( $username_ampersand ) {
1267 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1269 unless ( $username_percent ) {
1270 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1272 unless ( $username_colon ) {
1273 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1276 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1277 $recref->{popnum} = $1;
1278 return "Unknown popnum" unless
1279 ! $recref->{popnum} ||
1280 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1282 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1284 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1285 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1287 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1288 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1289 #not all systems use gid=uid
1290 #you can set a fixed gid in part_svc
1292 return "Only root can have uid 0"
1293 if $recref->{uid} == 0
1294 && $recref->{username} !~ /^(root|toor|smtp)$/;
1296 unless ( $recref->{username} eq 'sync' ) {
1297 if ( grep $_ eq $recref->{shell}, @shells ) {
1298 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1300 return "Illegal shell \`". $self->shell. "\'; ".
1301 "shells configuration value contains: @shells";
1304 $recref->{shell} = '/bin/sync';
1308 $recref->{gid} ne '' ?
1309 return "Can't have gid without uid" : ( $recref->{gid}='' );
1310 #$recref->{dir} ne '' ?
1311 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1312 $recref->{shell} ne '' ?
1313 return "Can't have shell without uid" : ( $recref->{shell}='' );
1316 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1318 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1319 or return "Illegal directory: ". $recref->{dir};
1320 $recref->{dir} = $1;
1321 return "Illegal directory"
1322 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1323 return "Illegal directory"
1324 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1325 unless ( $recref->{dir} ) {
1326 $recref->{dir} = $dir_prefix . '/';
1327 if ( $dirhash > 0 ) {
1328 for my $h ( 1 .. $dirhash ) {
1329 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1331 } elsif ( $dirhash < 0 ) {
1332 for my $h ( reverse $dirhash .. -1 ) {
1333 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1336 $recref->{dir} .= $recref->{username};
1342 # $error = $self->ut_textn('finger');
1343 # return $error if $error;
1344 if ( $self->getfield('finger') eq '' ) {
1345 my $cust_pkg = $self->svcnum
1346 ? $self->cust_svc->cust_pkg
1347 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1349 my $cust_main = $cust_pkg->cust_main;
1350 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1353 $self->getfield('finger') =~
1354 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1355 or return "Illegal finger: ". $self->getfield('finger');
1356 $self->setfield('finger', $1);
1358 for (qw( quota file_quota file_maxsize )) {
1359 $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1362 $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1363 $recref->{file_maxnum} = $1;
1365 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1366 if ( $recref->{slipip} eq '' ) {
1367 $recref->{slipip} = '';
1368 } elsif ( $recref->{slipip} eq '0e0' ) {
1369 $recref->{slipip} = '0e0';
1371 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1372 or return "Illegal slipip: ". $self->slipip;
1373 $recref->{slipip} = $1;
1378 #arbitrary RADIUS stuff; allow ut_textn for now
1379 foreach ( grep /^radius_/, fields('svc_acct') ) {
1380 $self->ut_textn($_);
1383 # First, if _password is blank, generate one and set default encoding.
1384 if ( ! $recref->{_password} ) {
1385 $error = $self->set_password('');
1387 # But if there's a _password but no encoding, assume it's plaintext and
1388 # set it to default encoding.
1389 elsif ( ! $recref->{_password_encoding} ) {
1390 $error = $self->set_password($recref->{_password});
1392 return $error if $error;
1394 # Next, check _password to ensure compliance with the encoding.
1395 if ( $recref->{_password_encoding} eq 'ldap' ) {
1397 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1398 $recref->{_password} = uc($1).$2;
1400 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1403 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1405 if ( $recref->{_password} =~
1406 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1407 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1410 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1413 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1416 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1417 # Password randomization is now in set_password.
1418 # Strip whitespace characters, check length requirements, etc.
1419 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1420 $recref->{_password} = $1;
1422 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1423 FS::Msgcat::_gettext('illegal_password_characters').
1424 ": ". $recref->{_password};
1427 if ( $password_noampersand ) {
1428 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1430 if ( $password_noexclamation ) {
1431 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1435 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1437 $self->SUPER::check;
1442 sub _password_encryption {
1444 my $encoding = lc($self->_password_encoding);
1445 return if !$encoding;
1446 return 'plain' if $encoding eq 'plain';
1447 if($encoding eq 'crypt') {
1448 my $pass = $self->_password;
1449 $pass =~ s/^\*SUSPENDED\* //;
1451 return 'md5' if $pass =~ /^\$1\$/;
1452 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1453 return 'des' if length($pass) == 13;
1456 if($encoding eq 'ldap') {
1457 uc($self->_password) =~ /^\{([\w-]+)\}/;
1458 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1459 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1460 return 'md5' if $1 eq 'MD5';
1461 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1468 sub get_cleartext_password {
1470 if($self->_password_encryption eq 'plain') {
1471 if($self->_password_encoding eq 'ldap') {
1472 $self->_password =~ /\{\w+\}(.*)$/;
1476 return $self->_password;
1485 Set the cleartext password for the account. If _password_encoding is set, the
1486 new password will be encoded according to the existing method (including
1487 encryption mode, if it can be determined). Otherwise,
1488 config('default-password-encoding') is used.
1490 If no password is supplied (or a zero-length password when minimum password length
1491 is >0), one will be generated randomly.
1496 my( $self, $pass ) = ( shift, shift );
1498 warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1501 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1502 FS::Msgcat::_gettext('illegal_password_characters').
1505 my( $encoding, $encryption ) = ('', '');
1507 if ( $self->_password_encoding ) {
1508 $encoding = $self->_password_encoding;
1509 # identify existing encryption method, try to use it.
1510 $encryption = $self->_password_encryption;
1512 # use the system default
1518 # set encoding to system default
1519 ($encoding, $encryption) =
1520 split(/-/, lc($conf->config('default-password-encoding')));
1521 $encoding ||= 'legacy';
1522 $self->_password_encoding($encoding);
1525 if ( $encoding eq 'legacy' ) {
1527 # The legacy behavior from check():
1528 # If the password is blank, randomize it and set encoding to 'plain'.
1529 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1530 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1531 $self->_password_encoding('plain');
1533 # Prefix + valid-length password
1534 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1536 $self->_password_encoding('plain');
1537 # Prefix + crypt string
1538 } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1540 $self->_password_encoding('crypt');
1541 # Various disabled crypt passwords
1542 } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1543 $self->_password_encoding('crypt');
1549 $self->_password($pass);
1555 if $passwordmin && length($pass) < $passwordmin
1556 or $passwordmax && length($pass) > $passwordmax;
1558 if ( $encoding eq 'crypt' ) {
1559 if ($encryption eq 'md5') {
1560 $pass = unix_md5_crypt($pass);
1561 } elsif ($encryption eq 'des') {
1562 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1565 } elsif ( $encoding eq 'ldap' ) {
1566 if ($encryption eq 'md5') {
1567 $pass = md5_base64($pass);
1568 } elsif ($encryption eq 'sha1') {
1569 $pass = sha1_base64($pass);
1570 } elsif ($encryption eq 'crypt') {
1571 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1573 # else $encryption eq 'plain', do nothing
1574 $pass = '{'.uc($encryption).'}'.$pass;
1576 # else encoding eq 'plain'
1578 $self->_password($pass);
1584 Internal function to check the username against the list of system usernames
1585 from the I<system_usernames> configuration value. Returns true if the username
1586 is listed on the system username list.
1592 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1593 $conf->config('system_usernames')
1597 =item _check_duplicate
1599 Internal method to check for duplicates usernames, username@domain pairs and
1602 If the I<global_unique-username> configuration value is set to B<username> or
1603 B<username@domain>, enforces global username or username@domain uniqueness.
1605 In all cases, check for duplicate uids and usernames or username@domain pairs
1606 per export and with identical I<svcpart> values.
1610 sub _check_duplicate {
1613 my $global_unique = $conf->config('global_unique-username') || 'none';
1614 return '' if $global_unique eq 'disabled';
1618 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1619 unless ( $part_svc ) {
1620 return 'unknown svcpart '. $self->svcpart;
1623 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1624 qsearch( 'svc_acct', { 'username' => $self->username } );
1625 return gettext('username_in_use')
1626 if $global_unique eq 'username' && @dup_user;
1628 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1629 qsearch( 'svc_acct', { 'username' => $self->username,
1630 'domsvc' => $self->domsvc } );
1631 return gettext('username_in_use')
1632 if $global_unique eq 'username@domain' && @dup_userdomain;
1635 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1636 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1637 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1638 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1643 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1644 my $exports = FS::part_export::export_info('svc_acct');
1645 my %conflict_user_svcpart;
1646 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1648 foreach my $part_export ( $part_svc->part_export ) {
1650 #this will catch to the same exact export
1651 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1653 #this will catch to exports w/same exporthost+type ???
1654 #my @other_part_export = qsearch('part_export', {
1655 # 'machine' => $part_export->machine,
1656 # 'exporttype' => $part_export->exporttype,
1658 #foreach my $other_part_export ( @other_part_export ) {
1659 # push @svcparts, map { $_->svcpart }
1660 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1663 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1664 #silly kludge to avoid uninitialized value errors
1665 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1666 ? $exports->{$part_export->exporttype}{'nodomain'}
1668 if ( $nodomain =~ /^Y/i ) {
1669 $conflict_user_svcpart{$_} = $part_export->exportnum
1672 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1677 foreach my $dup_user ( @dup_user ) {
1678 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1679 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1680 return "duplicate username ". $self->username.
1681 ": conflicts with svcnum ". $dup_user->svcnum.
1682 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1686 foreach my $dup_userdomain ( @dup_userdomain ) {
1687 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1688 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1689 return "duplicate username\@domain ". $self->email.
1690 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1691 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1695 foreach my $dup_uid ( @dup_uid ) {
1696 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1697 if ( exists($conflict_user_svcpart{$dup_svcpart})
1698 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1699 return "duplicate uid ". $self->uid.
1700 ": conflicts with svcnum ". $dup_uid->svcnum.
1702 ( $conflict_user_svcpart{$dup_svcpart}
1703 || $conflict_userdomain_svcpart{$dup_svcpart} );
1715 Depriciated, use radius_reply instead.
1720 carp "FS::svc_acct::radius depriciated, use radius_reply";
1721 $_[0]->radius_reply;
1726 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1727 reply attributes of this record.
1729 Note that this is now the preferred method for reading RADIUS attributes -
1730 accessing the columns directly is discouraged, as the column names are
1731 expected to change in the future.
1738 return %{ $self->{'radius_reply'} }
1739 if exists $self->{'radius_reply'};
1744 my($column, $attrib) = ($1, $2);
1745 #$attrib =~ s/_/\-/g;
1746 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1747 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1749 if ( $self->slipip && $self->slipip ne '0e0' ) {
1750 $reply{$radius_ip} = $self->slipip;
1753 if ( $self->seconds !~ /^$/ ) {
1754 $reply{'Session-Timeout'} = $self->seconds;
1757 if ( $conf->exists('radius-chillispot-max') ) {
1758 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1760 #hmm. just because sqlradius.pm says so?
1767 foreach my $what (qw( input output total )) {
1768 my $is = $whatis{$what}.'bytes';
1769 if ( $self->$is() =~ /\d/ ) {
1770 my $big = new Math::BigInt $self->$is();
1771 $big = new Math::BigInt '0' if $big->is_neg();
1772 my $att = "Chillispot-Max-\u$what";
1773 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1774 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1785 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1786 check attributes of this record.
1788 Note that this is now the preferred method for reading RADIUS attributes -
1789 accessing the columns directly is discouraged, as the column names are
1790 expected to change in the future.
1797 return %{ $self->{'radius_check'} }
1798 if exists $self->{'radius_check'};
1803 my($column, $attrib) = ($1, $2);
1804 #$attrib =~ s/_/\-/g;
1805 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1806 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1809 my($pw_attrib, $password) = $self->radius_password;
1810 $check{$pw_attrib} = $password;
1812 my $cust_svc = $self->cust_svc;
1814 my $cust_pkg = $cust_svc->cust_pkg;
1815 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1816 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1819 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1820 "; can't set Expiration\n"
1828 =item radius_password
1830 Returns a key/value pair containing the RADIUS attribute name and value
1835 sub radius_password {
1839 if ( $self->_password_encoding eq 'ldap' ) {
1840 $pw_attrib = 'Password-With-Header';
1841 } elsif ( $self->_password_encoding eq 'crypt' ) {
1842 $pw_attrib = 'Crypt-Password';
1843 } elsif ( $self->_password_encoding eq 'plain' ) {
1844 $pw_attrib = $radius_password;
1846 $pw_attrib = length($self->_password) <= 12
1851 ($pw_attrib, $self->_password);
1857 This method instructs the object to "snapshot" or freeze RADIUS check and
1858 reply attributes to the current values.
1862 #bah, my english is too broken this morning
1863 #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
1864 #the FS::cust_pkg's replace method to trigger the correct export updates when
1865 #package dates change)
1870 $self->{$_} = { $self->$_() }
1871 foreach qw( radius_reply radius_check );
1875 =item forget_snapshot
1877 This methos instructs the object to forget any previously snapshotted
1878 RADIUS check and reply attributes.
1882 sub forget_snapshot {
1886 foreach qw( radius_reply radius_check );
1890 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1892 Returns the domain associated with this account.
1894 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1901 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1902 my $svc_domain = $self->svc_domain(@_)
1903 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1904 $svc_domain->domain;
1909 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1913 #inherited from svc_Common
1915 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1917 Returns an email address associated with the account.
1919 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1926 $self->username. '@'. $self->domain(@_);
1931 Returns an array of FS::acct_snarf records associated with the account.
1932 If the acct_snarf table does not exist or there are no associated records,
1933 an empty list is returned
1939 return () unless dbdef->table('acct_snarf');
1940 eval "use FS::acct_snarf;";
1942 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1945 =item decrement_upbytes OCTETS
1947 Decrements the I<upbytes> field of this record by the given amount. If there
1948 is an error, returns the error, otherwise returns false.
1952 sub decrement_upbytes {
1953 shift->_op_usage('-', 'upbytes', @_);
1956 =item increment_upbytes OCTETS
1958 Increments the I<upbytes> field of this record by the given amount. If there
1959 is an error, returns the error, otherwise returns false.
1963 sub increment_upbytes {
1964 shift->_op_usage('+', 'upbytes', @_);
1967 =item decrement_downbytes OCTETS
1969 Decrements the I<downbytes> field of this record by the given amount. If there
1970 is an error, returns the error, otherwise returns false.
1974 sub decrement_downbytes {
1975 shift->_op_usage('-', 'downbytes', @_);
1978 =item increment_downbytes OCTETS
1980 Increments the I<downbytes> field of this record by the given amount. If there
1981 is an error, returns the error, otherwise returns false.
1985 sub increment_downbytes {
1986 shift->_op_usage('+', 'downbytes', @_);
1989 =item decrement_totalbytes OCTETS
1991 Decrements the I<totalbytes> field of this record by the given amount. If there
1992 is an error, returns the error, otherwise returns false.
1996 sub decrement_totalbytes {
1997 shift->_op_usage('-', 'totalbytes', @_);
2000 =item increment_totalbytes OCTETS
2002 Increments the I<totalbytes> field of this record by the given amount. If there
2003 is an error, returns the error, otherwise returns false.
2007 sub increment_totalbytes {
2008 shift->_op_usage('+', 'totalbytes', @_);
2011 =item decrement_seconds SECONDS
2013 Decrements the I<seconds> field of this record by the given amount. If there
2014 is an error, returns the error, otherwise returns false.
2018 sub decrement_seconds {
2019 shift->_op_usage('-', 'seconds', @_);
2022 =item increment_seconds SECONDS
2024 Increments the I<seconds> field of this record by the given amount. If there
2025 is an error, returns the error, otherwise returns false.
2029 sub increment_seconds {
2030 shift->_op_usage('+', 'seconds', @_);
2038 my %op2condition = (
2039 '-' => sub { my($self, $column, $amount) = @_;
2040 $self->$column - $amount <= 0;
2042 '+' => sub { my($self, $column, $amount) = @_;
2043 ($self->$column || 0) + $amount > 0;
2046 my %op2warncondition = (
2047 '-' => sub { my($self, $column, $amount) = @_;
2048 my $threshold = $column . '_threshold';
2049 $self->$column - $amount <= $self->$threshold + 0;
2051 '+' => sub { my($self, $column, $amount) = @_;
2052 ($self->$column || 0) + $amount > 0;
2057 my( $self, $op, $column, $amount ) = @_;
2059 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2060 ' ('. $self->email. "): $op $amount\n"
2063 return '' unless $amount;
2065 local $SIG{HUP} = 'IGNORE';
2066 local $SIG{INT} = 'IGNORE';
2067 local $SIG{QUIT} = 'IGNORE';
2068 local $SIG{TERM} = 'IGNORE';
2069 local $SIG{TSTP} = 'IGNORE';
2070 local $SIG{PIPE} = 'IGNORE';
2072 my $oldAutoCommit = $FS::UID::AutoCommit;
2073 local $FS::UID::AutoCommit = 0;
2076 my $sql = "UPDATE svc_acct SET $column = ".
2077 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2078 " $op ? WHERE svcnum = ?";
2082 my $sth = $dbh->prepare( $sql )
2083 or die "Error preparing $sql: ". $dbh->errstr;
2084 my $rv = $sth->execute($amount, $self->svcnum);
2085 die "Error executing $sql: ". $sth->errstr
2086 unless defined($rv);
2087 die "Can't update $column for svcnum". $self->svcnum
2090 #$self->snapshot; #not necessary, we retain the old values
2091 #create an object with the updated usage values
2092 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2094 my $error = $new->replace($self);
2096 $dbh->rollback if $oldAutoCommit;
2097 return "Error replacing: $error";
2100 #overlimit_action eq 'cancel' handling
2101 my $cust_pkg = $self->cust_svc->cust_pkg;
2103 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2104 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2108 my $error = $cust_pkg->cancel; #XXX should have a reason
2110 $dbh->rollback if $oldAutoCommit;
2111 return "Error cancelling: $error";
2114 #nothing else is relevant if we're cancelling, so commit & return success
2115 warn "$me update successful; committing\n"
2117 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2122 my $action = $op2action{$op};
2124 if ( &{$op2condition{$op}}($self, $column, $amount) &&
2125 ( $action eq 'suspend' && !$self->overlimit
2126 || $action eq 'unsuspend' && $self->overlimit )
2129 my $error = $self->_op_overlimit($action);
2131 $dbh->rollback if $oldAutoCommit;
2137 if ( $conf->exists("svc_acct-usage_$action")
2138 && &{$op2condition{$op}}($self, $column, $amount) ) {
2139 #my $error = $self->$action();
2140 my $error = $self->cust_svc->cust_pkg->$action();
2141 # $error ||= $self->overlimit($action);
2143 $dbh->rollback if $oldAutoCommit;
2144 return "Error ${action}ing: $error";
2148 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2149 my $wqueue = new FS::queue {
2150 'svcnum' => $self->svcnum,
2151 'job' => 'FS::svc_acct::reached_threshold',
2156 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2160 my $error = $wqueue->insert(
2161 'svcnum' => $self->svcnum,
2163 'column' => $column,
2167 $dbh->rollback if $oldAutoCommit;
2168 return "Error queuing threshold activity: $error";
2172 warn "$me update successful; committing\n"
2174 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2180 my( $self, $action ) = @_;
2182 local $SIG{HUP} = 'IGNORE';
2183 local $SIG{INT} = 'IGNORE';
2184 local $SIG{QUIT} = 'IGNORE';
2185 local $SIG{TERM} = 'IGNORE';
2186 local $SIG{TSTP} = 'IGNORE';
2187 local $SIG{PIPE} = 'IGNORE';
2189 my $oldAutoCommit = $FS::UID::AutoCommit;
2190 local $FS::UID::AutoCommit = 0;
2193 my $cust_pkg = $self->cust_svc->cust_pkg;
2195 my $conf_overlimit =
2197 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2198 : $conf->config('overlimit_groups');
2200 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2202 my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2203 next unless $groups;
2205 my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2207 my $other = new FS::svc_acct $self->hashref;
2208 $other->usergroup( $gref );
2211 if ($action eq 'suspend') {
2214 } else { # $action eq 'unsuspend'
2219 my $error = $part_export->export_replace($new, $old)
2220 || $self->overlimit($action);
2223 $dbh->rollback if $oldAutoCommit;
2224 return "Error replacing radius groups: $error";
2229 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2235 my( $self, $valueref, %options ) = @_;
2237 warn "$me set_usage called for svcnum ". $self->svcnum.
2238 ' ('. $self->email. "): ".
2239 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2242 local $SIG{HUP} = 'IGNORE';
2243 local $SIG{INT} = 'IGNORE';
2244 local $SIG{QUIT} = 'IGNORE';
2245 local $SIG{TERM} = 'IGNORE';
2246 local $SIG{TSTP} = 'IGNORE';
2247 local $SIG{PIPE} = 'IGNORE';
2249 local $FS::svc_Common::noexport_hack = 1;
2250 my $oldAutoCommit = $FS::UID::AutoCommit;
2251 local $FS::UID::AutoCommit = 0;
2256 if ( $options{null} ) {
2257 %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2258 qw( seconds upbytes downbytes totalbytes )
2261 foreach my $field (keys %$valueref){
2262 $reset = 1 if $valueref->{$field};
2263 $self->setfield($field, $valueref->{$field});
2264 $self->setfield( $field.'_threshold',
2265 int($self->getfield($field)
2266 * ( $conf->exists('svc_acct-usage_threshold')
2267 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2272 $handyhash{$field} = $self->getfield($field);
2273 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2275 #my $error = $self->replace; #NO! we avoid the call to ->check for
2276 #die $error if $error; #services not explicity changed via the UI
2278 my $sql = "UPDATE svc_acct SET " .
2279 join (',', map { "$_ = ?" } (keys %handyhash) ).
2280 " WHERE svcnum = ". $self->svcnum;
2285 if (scalar(keys %handyhash)) {
2286 my $sth = $dbh->prepare( $sql )
2287 or die "Error preparing $sql: ". $dbh->errstr;
2288 my $rv = $sth->execute(values %handyhash);
2289 die "Error executing $sql: ". $sth->errstr
2290 unless defined($rv);
2291 die "Can't update usage for svcnum ". $self->svcnum
2295 #$self->snapshot; #not necessary, we retain the old values
2296 #create an object with the updated usage values
2297 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2298 local($FS::Record::nowarn_identical) = 1;
2299 my $error = $new->replace($self); #call exports
2301 $dbh->rollback if $oldAutoCommit;
2302 return "Error replacing: $error";
2309 $error = $self->_op_overlimit('unsuspend')
2310 if $self->overlimit;;
2312 $error ||= $self->cust_svc->cust_pkg->unsuspend
2313 if $conf->exists("svc_acct-usage_unsuspend");
2316 $dbh->rollback if $oldAutoCommit;
2317 return "Error unsuspending: $error";
2322 warn "$me update successful; committing\n"
2324 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2330 =item recharge HASHREF
2332 Increments usage columns by the amount specified in HASHREF as
2333 column=>amount pairs.
2338 my ($self, $vhash) = @_;
2341 warn "[$me] recharge called on $self: ". Dumper($self).
2342 "\nwith vhash: ". Dumper($vhash);
2345 my $oldAutoCommit = $FS::UID::AutoCommit;
2346 local $FS::UID::AutoCommit = 0;
2350 foreach my $column (keys %$vhash){
2351 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2355 $dbh->rollback if $oldAutoCommit;
2357 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2362 =item is_rechargeable
2364 Returns true if this svc_account can be "recharged" and false otherwise.
2368 sub is_rechargable {
2370 $self->seconds ne ''
2371 || $self->upbytes ne ''
2372 || $self->downbytes ne ''
2373 || $self->totalbytes ne '';
2376 =item seconds_since TIMESTAMP
2378 Returns the number of seconds this account has been online since TIMESTAMP,
2379 according to the session monitor (see L<FS::Session>).
2381 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2382 L<Time::Local> and L<Date::Parse> for conversion functions.
2386 #note: POD here, implementation in FS::cust_svc
2389 $self->cust_svc->seconds_since(@_);
2392 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2394 Returns the numbers of seconds this account has been online between
2395 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2396 external SQL radacct table, specified via sqlradius export. Sessions which
2397 started in the specified range but are still open are counted from session
2398 start to the end of the range (unless they are over 1 day old, in which case
2399 they are presumed missing their stop record and not counted). Also, sessions
2400 which end in the range but started earlier are counted from the start of the
2401 range to session end. Finally, sessions which start before the range but end
2402 after are counted for the entire range.
2404 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2405 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2410 #note: POD here, implementation in FS::cust_svc
2411 sub seconds_since_sqlradacct {
2413 $self->cust_svc->seconds_since_sqlradacct(@_);
2416 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2418 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2419 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2420 TIMESTAMP_END (exclusive).
2422 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2423 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2428 #note: POD here, implementation in FS::cust_svc
2429 sub attribute_since_sqlradacct {
2431 $self->cust_svc->attribute_since_sqlradacct(@_);
2434 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2436 Returns an array of hash references of this customers login history for the
2437 given time range. (document this better)
2441 sub get_session_history {
2443 $self->cust_svc->get_session_history(@_);
2446 =item last_login_text
2448 Returns text describing the time of last login.
2452 sub last_login_text {
2454 $self->last_login ? ctime($self->last_login) : 'unknown';
2457 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2462 my($self, $start, $end, %opt ) = @_;
2464 my $did = $self->username; #yup
2466 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2468 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2470 #SELECT $for_update * FROM cdr
2471 # WHERE calldate >= $start #need a conversion
2472 # AND calldate < $end #ditto
2473 # AND ( charged_party = "$did"
2474 # OR charged_party = "$prefix$did" #if length($prefix);
2475 # OR ( ( charged_party IS NULL OR charged_party = '' )
2477 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2480 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2483 if ( length($prefix) ) {
2485 " AND ( charged_party = '$did'
2486 OR charged_party = '$prefix$did'
2487 OR ( ( charged_party IS NULL OR charged_party = '' )
2489 ( src = '$did' OR src = '$prefix$did' )
2495 " AND ( charged_party = '$did'
2496 OR ( ( charged_party IS NULL OR charged_party = '' )
2506 'select' => "$for_update *",
2509 #( freesidestatus IS NULL OR freesidestatus = '' )
2510 'freesidestatus' => '',
2512 'extra_sql' => $charged_or_src,
2520 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2526 if ( $self->usergroup ) {
2527 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2528 unless ref($self->usergroup) eq 'ARRAY';
2529 #when provisioning records, export callback runs in svc_Common.pm before
2530 #radius_usergroup records can be inserted...
2531 @{$self->usergroup};
2533 map { $_->groupname }
2534 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2538 =item clone_suspended
2540 Constructor used by FS::part_export::_export_suspend fallback. Document
2545 sub clone_suspended {
2547 my %hash = $self->hash;
2548 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2549 new FS::svc_acct \%hash;
2552 =item clone_kludge_unsuspend
2554 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2559 sub clone_kludge_unsuspend {
2561 my %hash = $self->hash;
2562 $hash{_password} = '';
2563 new FS::svc_acct \%hash;
2566 =item check_password
2568 Checks the supplied password against the (possibly encrypted) password in the
2569 database. Returns true for a successful authentication, false for no match.
2571 Currently supported encryptions are: classic DES crypt() and MD5
2575 sub check_password {
2576 my($self, $check_password) = @_;
2578 #remove old-style SUSPENDED kludge, they should be allowed to login to
2579 #self-service and pay up
2580 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2582 if ( $self->_password_encoding eq 'ldap' ) {
2584 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2585 return $auth->match($check_password);
2587 } elsif ( $self->_password_encoding eq 'crypt' ) {
2589 my $auth = from_crypt Authen::Passphrase $self->_password;
2590 return $auth->match($check_password);
2592 } elsif ( $self->_password_encoding eq 'plain' ) {
2594 return $check_password eq $password;
2598 #XXX this could be replaced with Authen::Passphrase stuff
2600 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2602 } elsif ( length($password) < 13 ) { #plaintext
2603 $check_password eq $password;
2604 } elsif ( length($password) == 13 ) { #traditional DES crypt
2605 crypt($check_password, $password) eq $password;
2606 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2607 unix_md5_crypt($check_password, $password) eq $password;
2608 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2609 warn "Can't check password: Blowfish encryption not yet supported, ".
2610 "svcnum ". $self->svcnum. "\n";
2613 warn "Can't check password: Unrecognized encryption for svcnum ".
2614 $self->svcnum. "\n";
2622 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2624 Returns an encrypted password, either by passing through an encrypted password
2625 in the database or by encrypting a plaintext password from the database.
2627 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2628 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2629 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2630 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2631 encryption type is only used if the password is not already encrypted in the
2636 sub crypt_password {
2639 if ( $self->_password_encoding eq 'ldap' ) {
2641 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2644 #XXX this could be replaced with Authen::Passphrase stuff
2646 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2647 if ( $encryption eq 'crypt' ) {
2650 $saltset[int(rand(64))].$saltset[int(rand(64))]
2652 } elsif ( $encryption eq 'md5' ) {
2653 unix_md5_crypt( $self->_password );
2654 } elsif ( $encryption eq 'blowfish' ) {
2655 croak "unknown encryption method $encryption";
2657 croak "unknown encryption method $encryption";
2660 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2664 } elsif ( $self->_password_encoding eq 'crypt' ) {
2666 return $self->_password;
2668 } elsif ( $self->_password_encoding eq 'plain' ) {
2670 #XXX this could be replaced with Authen::Passphrase stuff
2672 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2673 if ( $encryption eq 'crypt' ) {
2676 $saltset[int(rand(64))].$saltset[int(rand(64))]
2678 } elsif ( $encryption eq 'md5' ) {
2679 unix_md5_crypt( $self->_password );
2680 } elsif ( $encryption eq 'blowfish' ) {
2681 croak "unknown encryption method $encryption";
2683 croak "unknown encryption method $encryption";
2688 if ( length($self->_password) == 13
2689 || $self->_password =~ /^\$(1|2a?)\$/
2690 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2696 #XXX this could be replaced with Authen::Passphrase stuff
2698 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2699 if ( $encryption eq 'crypt' ) {
2702 $saltset[int(rand(64))].$saltset[int(rand(64))]
2704 } elsif ( $encryption eq 'md5' ) {
2705 unix_md5_crypt( $self->_password );
2706 } elsif ( $encryption eq 'blowfish' ) {
2707 croak "unknown encryption method $encryption";
2709 croak "unknown encryption method $encryption";
2718 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2720 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2721 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2722 "{MD5}5426824942db4253f87a1009fd5d2d4".
2724 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2725 to work the same as the B</crypt_password> method.
2731 #eventually should check a "password-encoding" field
2733 if ( $self->_password_encoding eq 'ldap' ) {
2735 return $self->_password;
2737 } elsif ( $self->_password_encoding eq 'crypt' ) {
2739 if ( length($self->_password) == 13 ) { #crypt
2740 return '{CRYPT}'. $self->_password;
2741 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2743 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2744 # die "Blowfish encryption not supported in this context, svcnum ".
2745 # $self->svcnum. "\n";
2747 warn "encryption method not (yet?) supported in LDAP context";
2748 return '{CRYPT}*'; #unsupported, should not auth
2751 } elsif ( $self->_password_encoding eq 'plain' ) {
2753 return '{PLAIN}'. $self->_password;
2755 #return '{CLEARTEXT}'. $self->_password; #?
2759 if ( length($self->_password) == 13 ) { #crypt
2760 return '{CRYPT}'. $self->_password;
2761 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2763 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2764 warn "Blowfish encryption not supported in this context, svcnum ".
2765 $self->svcnum. "\n";
2768 #are these two necessary anymore?
2769 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2770 return '{SSHA}'. $1;
2771 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2772 return '{NS-MTA-MD5}'. $1;
2775 return '{PLAIN}'. $self->_password;
2777 #return '{CLEARTEXT}'. $self->_password; #?
2779 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2780 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2781 #if ( $encryption eq 'crypt' ) {
2782 # return '{CRYPT}'. crypt(
2784 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2786 #} elsif ( $encryption eq 'md5' ) {
2787 # unix_md5_crypt( $self->_password );
2788 #} elsif ( $encryption eq 'blowfish' ) {
2789 # croak "unknown encryption method $encryption";
2791 # croak "unknown encryption method $encryption";
2799 =item domain_slash_username
2801 Returns $domain/$username/
2805 sub domain_slash_username {
2807 $self->domain. '/'. $self->username. '/';
2810 =item virtual_maildir
2812 Returns $domain/maildirs/$username/
2816 sub virtual_maildir {
2818 $self->domain. '/maildirs/'. $self->username. '/';
2823 =head1 CLASS METHODS
2827 =item search HASHREF
2829 Class method which returns a qsearch hash expression to search for parameters
2830 specified in HASHREF. Valid parameters are
2844 Arrayref of pkgparts
2850 Arrayref of additional WHERE clauses, will be ANDed together.
2861 my ($class, $params) = @_;
2866 if ( $params->{'domain'} ) {
2867 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2868 #preserve previous behavior & bubble up an error if $svc_domain not found?
2869 push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2873 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2874 push @where, "domsvc = $1";
2878 push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2881 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2882 push @where, "agentnum = $1";
2886 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2887 push @where, "custnum = $1";
2891 if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2892 #XXX untaint or sql quote
2894 'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2898 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2899 push @where, "popnum = $1";
2903 if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2904 push @where, "svcpart = $1";
2908 # here is the agent virtualization
2909 #if ($params->{CurrentUser}) {
2911 # qsearchs('access_user', { username => $params->{CurrentUser} });
2913 # if ($access_user) {
2914 # push @where, $access_user->agentnums_sql('table'=>'cust_main');
2916 # push @where, "1=0";
2919 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2920 'table' => 'cust_main',
2921 'null_right' => 'View/link unlinked services',
2925 push @where, @{ $params->{'where'} } if $params->{'where'};
2927 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2929 my $addl_from = ' LEFT JOIN cust_svc USING ( svcnum ) '.
2930 ' LEFT JOIN part_svc USING ( svcpart ) '.
2931 ' LEFT JOIN cust_pkg USING ( pkgnum ) '.
2932 ' LEFT JOIN cust_main USING ( custnum ) ';
2934 my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2935 #if ( keys %svc_acct ) {
2936 # $count_query .= ' WHERE '.
2937 # join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2943 'table' => 'svc_acct',
2944 'hashref' => {}, # \%svc_acct,
2945 'select' => join(', ',
2948 'cust_main.custnum',
2949 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2951 'addl_from' => $addl_from,
2952 'extra_sql' => $extra_sql,
2953 'order_by' => $params->{'order_by'},
2954 'count_query' => $count_query,
2967 This is the FS::svc_acct job-queue-able version. It still uses
2968 FS::Misc::send_email under-the-hood.
2975 eval "use FS::Misc qw(send_email)";
2978 $opt{mimetype} ||= 'text/plain';
2979 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2981 my $error = send_email(
2982 'from' => $opt{from},
2984 'subject' => $opt{subject},
2985 'content-type' => $opt{mimetype},
2986 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2988 die $error if $error;
2991 =item check_and_rebuild_fuzzyfiles
2995 sub check_and_rebuild_fuzzyfiles {
2996 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2997 -e "$dir/svc_acct.username"
2998 or &rebuild_fuzzyfiles;
3001 =item rebuild_fuzzyfiles
3005 sub rebuild_fuzzyfiles {
3007 use Fcntl qw(:flock);
3009 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3013 open(USERNAMELOCK,">>$dir/svc_acct.username")
3014 or die "can't open $dir/svc_acct.username: $!";
3015 flock(USERNAMELOCK,LOCK_EX)
3016 or die "can't lock $dir/svc_acct.username: $!";
3018 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
3020 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
3021 or die "can't open $dir/svc_acct.username.tmp: $!";
3022 print USERNAMECACHE join("\n", @all_username), "\n";
3023 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
3025 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
3035 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3036 open(USERNAMECACHE,"<$dir/svc_acct.username")
3037 or die "can't open $dir/svc_acct.username: $!";
3038 my @array = map { chomp; $_; } <USERNAMECACHE>;
3039 close USERNAMECACHE;
3043 =item append_fuzzyfiles USERNAME
3047 sub append_fuzzyfiles {
3048 my $username = shift;
3050 &check_and_rebuild_fuzzyfiles;
3052 use Fcntl qw(:flock);
3054 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3056 open(USERNAME,">>$dir/svc_acct.username")
3057 or die "can't open $dir/svc_acct.username: $!";
3058 flock(USERNAME,LOCK_EX)
3059 or die "can't lock $dir/svc_acct.username: $!";
3061 print USERNAME "$username\n";
3063 flock(USERNAME,LOCK_UN)
3064 or die "can't unlock $dir/svc_acct.username: $!";
3072 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
3076 sub radius_usergroup_selector {
3077 my $sel_groups = shift;
3078 my %sel_groups = map { $_=>1 } @$sel_groups;
3080 my $selectname = shift || 'radius_usergroup';
3083 my $sth = $dbh->prepare(
3084 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
3085 ) or die $dbh->errstr;
3086 $sth->execute() or die $sth->errstr;
3087 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
3091 function ${selectname}_doadd(object) {
3092 var myvalue = object.${selectname}_add.value;
3093 var optionName = new Option(myvalue,myvalue,false,true);
3094 var length = object.$selectname.length;
3095 object.$selectname.options[length] = optionName;
3096 object.${selectname}_add.value = "";
3099 <SELECT MULTIPLE NAME="$selectname">
3102 foreach my $group ( @all_groups ) {
3103 $html .= qq(<OPTION VALUE="$group");
3104 if ( $sel_groups{$group} ) {
3105 $html .= ' SELECTED';
3106 $sel_groups{$group} = 0;
3108 $html .= ">$group</OPTION>\n";
3110 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
3111 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
3113 $html .= '</SELECT>';
3115 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
3116 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
3121 =item reached_threshold
3123 Performs some activities when svc_acct thresholds (such as number of seconds
3124 remaining) are reached.
3128 sub reached_threshold {
3131 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3132 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3134 if ( $opt{'op'} eq '+' ){
3135 $svc_acct->setfield( $opt{'column'}.'_threshold',
3136 int($svc_acct->getfield($opt{'column'})
3137 * ( $conf->exists('svc_acct-usage_threshold')
3138 ? $conf->config('svc_acct-usage_threshold')/100
3143 my $error = $svc_acct->replace;
3144 die $error if $error;
3145 }elsif ( $opt{'op'} eq '-' ){
3147 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3148 return '' if ($threshold eq '' );
3150 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3151 my $error = $svc_acct->replace;
3152 die $error if $error; # email next time, i guess
3154 if ( $warning_template ) {
3155 eval "use FS::Misc qw(send_email)";
3158 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
3159 my $cust_main = $cust_pkg->cust_main;
3161 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3162 $cust_main->invoicing_list,
3163 ($opt{'to'} ? $opt{'to'} : ())
3166 my $mimetype = $warning_mimetype;
3167 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3169 my $body = $warning_template->fill_in( HASH => {
3170 'custnum' => $cust_main->custnum,
3171 'username' => $svc_acct->username,
3172 'password' => $svc_acct->_password,
3173 'first' => $cust_main->first,
3174 'last' => $cust_main->getfield('last'),
3175 'pkg' => $cust_pkg->part_pkg->pkg,
3176 'column' => $opt{'column'},
3177 'amount' => $opt{'column'} =~/bytes/
3178 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3179 : $svc_acct->getfield($opt{'column'}),
3180 'threshold' => $opt{'column'} =~/bytes/
3181 ? FS::UI::bytecount::display_bytecount($threshold)
3186 my $error = send_email(
3187 'from' => $warning_from,
3189 'subject' => $warning_subject,
3190 'content-type' => $mimetype,
3191 'body' => [ map "$_\n", split("\n", $body) ],
3193 die $error if $error;
3196 die "unknown op: " . $opt{'op'};
3204 The $recref stuff in sub check should be cleaned up.
3206 The suspend, unsuspend and cancel methods update the database, but not the
3207 current object. This is probably a bug as it's unexpected and
3210 radius_usergroup_selector? putting web ui components in here? they should
3211 probably live somewhere else...
3213 insertion of RADIUS group stuff in insert could be done with child_objects now
3214 (would probably clean up export of them too)
3216 _op_usage and set_usage bypass the history... maybe they shouldn't
3220 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3221 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3222 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3223 L<freeside-queued>), L<FS::svc_acct_pop>,
3224 schema.html from the base documentation.