4 use base qw( FS::svc_Domain_Mixin
10 use vars qw( $DEBUG $me $conf $skip_fuzzyfiles
11 $dir_prefix @shells $usernamemin
12 $usernamemax $passwordmin $passwordmax
13 $username_ampersand $username_letter $username_letterfirst
14 $username_noperiod $username_nounderscore $username_nodash
15 $username_uppercase $username_percent $username_colon
16 $username_slash $username_equals $username_pound
17 $password_noampersand $password_noexclamation
18 $warning_template $warning_from $warning_subject $warning_mimetype
21 $radius_password $radius_ip
24 use Scalar::Util qw( blessed );
29 use Crypt::PasswdMD5 1.2;
30 use Digest::SHA 'sha1_base64';
31 use Digest::MD5 'md5_base64';
34 use Authen::Passphrase;
35 use FS::UID qw( datasrc driver_name );
37 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
38 use FS::Msgcat qw(gettext);
39 use FS::UI::bytecount;
44 use FS::cust_main_invoice;
49 use FS::radius_usergroup;
60 $me = '[FS::svc_acct]';
62 #ask FS::UID to run this stuff for us later
63 FS::UID->install_callback( sub {
65 $dir_prefix = $conf->config('home');
66 @shells = $conf->config('shells');
67 $usernamemin = $conf->config('usernamemin') || 2;
68 $usernamemax = $conf->config('usernamemax');
69 $passwordmin = $conf->config('passwordmin'); # || 6;
71 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
74 $passwordmax = $conf->config('passwordmax') || 8;
75 $username_letter = $conf->exists('username-letter');
76 $username_letterfirst = $conf->exists('username-letterfirst');
77 $username_noperiod = $conf->exists('username-noperiod');
78 $username_nounderscore = $conf->exists('username-nounderscore');
79 $username_nodash = $conf->exists('username-nodash');
80 $username_uppercase = $conf->exists('username-uppercase');
81 $username_ampersand = $conf->exists('username-ampersand');
82 $username_percent = $conf->exists('username-percent');
83 $username_colon = $conf->exists('username-colon');
84 $username_slash = $conf->exists('username-slash');
85 $username_equals = $conf->exists('username-equals');
86 $username_pound = $conf->exists('username-pound');
87 $password_noampersand = $conf->exists('password-noexclamation');
88 $password_noexclamation = $conf->exists('password-noexclamation');
89 $dirhash = $conf->config('dirhash') || 0;
90 if ( $conf->exists('warning_email') ) {
91 $warning_template = new Text::Template (
93 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
94 ) or warn "can't create warning email template: $Text::Template::ERROR";
95 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
96 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
97 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
98 $warning_cc = $conf->config('warning_email-cc');
100 $warning_template = '';
102 $warning_subject = '';
103 $warning_mimetype = '';
106 $smtpmachine = $conf->config('smtpmachine');
107 $radius_password = $conf->config('radius-password') || 'Password';
108 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
109 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
113 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
114 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '.', ',' );
118 my ( $hashref, $cache ) = @_;
119 if ( $hashref->{'svc_acct_svcnum'} ) {
120 $self->{'_domsvc'} = FS::svc_domain->new( {
121 'svcnum' => $hashref->{'domsvc'},
122 'domain' => $hashref->{'svc_acct_domain'},
123 'catchall' => $hashref->{'svc_acct_catchall'},
130 FS::svc_acct - Object methods for svc_acct records
136 $record = new FS::svc_acct \%hash;
137 $record = new FS::svc_acct { 'column' => 'value' };
139 $error = $record->insert;
141 $error = $new_record->replace($old_record);
143 $error = $record->delete;
145 $error = $record->check;
147 $error = $record->suspend;
149 $error = $record->unsuspend;
151 $error = $record->cancel;
153 %hash = $record->radius;
155 %hash = $record->radius_reply;
157 %hash = $record->radius_check;
159 $domain = $record->domain;
161 $svc_domain = $record->svc_domain;
163 $email = $record->email;
165 $seconds_since = $record->seconds_since($timestamp);
169 An FS::svc_acct object represents an account. FS::svc_acct inherits from
170 FS::svc_Common. The following fields are currently supported:
176 Primary key (assigned automatcially for new accounts)
184 =item _password_encoding
186 plain, crypt, ldap (or empty for autodetection)
194 Point of presence (see L<FS::svc_acct_pop>)
206 set automatically if blank (and uid is not)
226 svcnum from svc_domain
230 Optional svcnum from svc_pbx
232 =item radius_I<Radius_Attribute>
234 I<Radius-Attribute> (reply)
236 =item rc_I<Radius_Attribute>
238 I<Radius-Attribute> (check)
248 Creates a new account. To add the account to the database, see L<"insert">.
255 'longname_plural' => 'Access accounts and mailboxes',
256 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
257 'display_weight' => 10,
258 'cancel_weight' => 50,
259 'ip_field' => 'slipip',
261 'dir' => 'Home directory',
264 def_info => 'set to fixed and blank for no UIDs',
267 'slipip' => 'IP address',
268 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
270 label => 'Access number',
272 select_table => 'svc_acct_pop',
273 select_key => 'popnum',
274 select_label => 'city',
280 disable_default => 1,
284 'password_selfchange' => { label => 'Password modification',
287 'password_recover' => { label => 'Password recovery',
291 label => 'Quota', #Mail storage limit
293 disable_inventory => 1,
297 label => 'File storage limit',
299 disable_inventory => 1,
303 label => 'Number of files limit',
305 disable_inventory => 1,
309 label => 'File size limit',
311 disable_inventory => 1,
314 '_password' => 'Password',
317 def_info => 'when blank, defaults to UID',
322 def_info => 'set to blank for no shell tracking',
324 #select_list => [ $conf->config('shells') ],
325 select_list => [ $conf ? $conf->config('shells') : () ],
326 disable_inventory => 1,
329 'finger' => 'Real name', # (GECOS)',
333 select_table => 'svc_domain',
334 select_key => 'svcnum',
335 select_label => 'domain',
336 disable_inventory => 1,
338 'pbxsvc' => { label => 'PBX',
339 type => 'select-svc_pbx.html',
340 disable_inventory => 1,
341 disable_select => 1, #UI wonky, pry works otherwise
343 'sectornum' => 'Tower sector',
345 label => 'RADIUS groups',
346 type => 'select-radius_group.html',
347 disable_inventory => 1,
351 'seconds' => { label => 'Seconds',
352 label_sort => 'with Time Remaining',
354 disable_inventory => 1,
356 disable_part_svc_column => 1,
358 'upbytes' => { label => 'Upload',
360 disable_inventory => 1,
362 'format' => \&FS::UI::bytecount::display_bytecount,
363 'parse' => \&FS::UI::bytecount::parse_bytecount,
364 disable_part_svc_column => 1,
366 'downbytes' => { label => 'Download',
368 disable_inventory => 1,
370 'format' => \&FS::UI::bytecount::display_bytecount,
371 'parse' => \&FS::UI::bytecount::parse_bytecount,
372 disable_part_svc_column => 1,
374 'totalbytes'=> { label => 'Total up and download',
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 'seconds_threshold' => { label => 'Seconds threshold',
384 disable_inventory => 1,
386 disable_part_svc_column => 1,
388 'upbytes_threshold' => { label => 'Upload threshold',
390 disable_inventory => 1,
392 'format' => \&FS::UI::bytecount::display_bytecount,
393 'parse' => \&FS::UI::bytecount::parse_bytecount,
394 disable_part_svc_column => 1,
396 'downbytes_threshold' => { label => 'Download threshold',
398 disable_inventory => 1,
400 'format' => \&FS::UI::bytecount::display_bytecount,
401 'parse' => \&FS::UI::bytecount::parse_bytecount,
402 disable_part_svc_column => 1,
404 'totalbytes_threshold'=> { label => 'Total up and download threshold',
406 disable_inventory => 1,
408 'format' => \&FS::UI::bytecount::display_bytecount,
409 'parse' => \&FS::UI::bytecount::parse_bytecount,
410 disable_part_svc_column => 1,
413 label => 'Last login',
417 label => 'Last logout',
422 label => 'Communigate aliases',
424 disable_inventory => 1,
429 label => 'Communigate account type',
431 select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )],
432 disable_inventory => 1,
435 'cgp_accessmodes' => {
436 label => 'Communigate enabled services',
437 type => 'communigate_pro-accessmodes',
438 disable_inventory => 1,
441 'cgp_rulesallowed' => {
442 label => 'Allowed mail rules',
444 select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ],
445 disable_inventory => 1,
448 'cgp_rpopallowed' => { label => 'RPOP modifications',
451 'cgp_mailtoall' => { label => 'Accepts mail to "all"',
454 'cgp_addmailtrailer' => { label => 'Add trailer to sent mail',
457 'cgp_archiveafter' => {
458 label => 'Archive messages after',
461 -2 => 'default(730 days)',
468 1209600 => '2 weeks',
469 2592000 => '30 days',
470 7776000 => '90 days',
471 15552000 => '180 days',
472 31536000 => '365 days',
473 63072000 => '730 days',
475 disable_inventory => 1,
481 'cgp_deletemode' => {
482 label => 'Communigate message delete method',
484 select_list => [ 'Move To Trash', 'Immediately', 'Mark' ],
485 disable_inventory => 1,
488 'cgp_emptytrash' => {
489 label => 'Communigate on logout remove trash',
491 select_list => __PACKAGE__->cgp_emptytrash_values,
492 disable_inventory => 1,
496 label => 'Communigate language',
498 select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ],
499 disable_inventory => 1,
503 label => 'Communigate time zone',
505 select_list => __PACKAGE__->cgp_timezone_values,
506 disable_inventory => 1,
510 label => 'Communigate layout',
512 select_list => [ '', '***', 'GoldFleece', 'Skin2' ],
513 disable_inventory => 1,
516 'cgp_prontoskinname' => {
517 label => 'Communigate Pronto style',
519 select_list => [ '', 'Pronto', 'Pronto-darkflame', 'Pronto-steel', 'Pronto-twilight', ],
520 disable_inventory => 1,
523 'cgp_sendmdnmode' => {
524 label => 'Communigate send read receipts',
526 select_list => [ '', 'Never', 'Manually', 'Automatically' ],
527 disable_inventory => 1,
538 sub table { 'svc_acct'; }
540 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
543 shift->_lastlog('in', @_);
547 shift->_lastlog('out', @_);
551 my( $self, $op, $time ) = @_;
553 if ( defined($time) ) {
554 warn "$me last_log$op called on svcnum ". $self->svcnum.
555 ' ('. $self->email. "): $time\n"
560 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
564 my $sth = $dbh->prepare( $sql )
565 or die "Error preparing $sql: ". $dbh->errstr;
566 my $rv = $sth->execute($time, $self->svcnum);
567 die "Error executing $sql: ". $sth->errstr
569 die "Can't update last_log$op for svcnum". $self->svcnum
572 $self->{'Hash'}->{"last_log$op"} = $time;
574 $self->getfield("last_log$op");
578 =item search_sql STRING
580 Class method which returns an SQL fragment to search for the given string.
585 my( $class, $string ) = @_;
586 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
587 my( $username, $domain ) = ( $1, $2 );
588 my $q_username = dbh->quote($username);
589 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
591 "svc_acct.username = $q_username AND ( ".
592 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
597 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
599 $class->search_sql_field('slipip', $string ).
601 $class->search_sql_field('username', $string ).
604 $class->search_sql_field('username', $string);
608 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
610 Returns the "username@domain" string for this account.
612 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
622 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
624 Returns a longer string label for this acccount ("Real Name <username@domain>"
625 if available, or "username@domain").
627 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
634 my $label = $self->label(@_);
635 my $finger = $self->finger;
636 return $label unless $finger =~ /\S/;
637 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
638 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
642 =item insert [ , OPTION => VALUE ... ]
644 Adds this account to the database. If there is an error, returns the error,
645 otherwise returns false.
647 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
648 defined. An FS::cust_svc record will be created and inserted.
650 The additional field I<usergroup> can optionally be defined; if so it should
651 contain an arrayref of group names. See L<FS::radius_usergroup>.
653 The additional field I<child_objects> can optionally be defined; if so it
654 should contain an arrayref of FS::tablename objects. They will have their
655 svcnum fields set and will be inserted after this record, but before any
656 exports are run. Each element of the array can also optionally be a
657 two-element array reference containing the child object and the name of an
658 alternate field to be filled in with the newly-inserted svcnum, for example
659 C<[ $svc_forward, 'srcsvc' ]>
661 Currently available options are: I<depend_jobnum>
663 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
664 jobnums), all provisioning jobs will have a dependancy on the supplied
665 jobnum(s) (they will not run until the specific job(s) complete(s)).
667 (TODOC: L<FS::queue> and L<freeside-queued>)
669 (TODOC: new exports!)
678 warn "[$me] insert called on $self: ". Dumper($self).
679 "\nwith options: ". Dumper(%options);
682 local $SIG{HUP} = 'IGNORE';
683 local $SIG{INT} = 'IGNORE';
684 local $SIG{QUIT} = 'IGNORE';
685 local $SIG{TERM} = 'IGNORE';
686 local $SIG{TSTP} = 'IGNORE';
687 local $SIG{PIPE} = 'IGNORE';
689 my $oldAutoCommit = $FS::UID::AutoCommit;
690 local $FS::UID::AutoCommit = 0;
694 my $error = $self->SUPER::insert( # usergroup is here
695 'jobnums' => \@jobnums,
696 'child_objects' => $self->child_objects,
700 $dbh->rollback if $oldAutoCommit;
704 unless ( $skip_fuzzyfiles ) {
705 $error = $self->queue_fuzzyfiles_update;
707 $dbh->rollback if $oldAutoCommit;
708 return "updating fuzzy search cache: $error";
712 my $cust_pkg = $self->cust_svc->cust_pkg;
715 my $cust_main = $cust_pkg->cust_main;
716 my $agentnum = $cust_main->agentnum;
718 if ( $conf->exists('emailinvoiceautoalways')
719 || $conf->exists('emailinvoiceauto')
720 && ! $cust_main->invoicing_list_emailonly
722 my @invoicing_list = $cust_main->invoicing_list;
723 push @invoicing_list, $self->email;
724 $cust_main->invoicing_list(\@invoicing_list);
728 my @welcome_exclude_svcparts = $conf->config('svc_acct_welcome_exclude');
729 unless ( grep { $_ eq $self->svcpart } @welcome_exclude_svcparts ) {
731 my $msgnum = $conf->config('welcome_msgnum', $agentnum);
733 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
734 $error = $msg_template->send('cust_main' => $cust_main,
738 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
739 = ('','','','','','');
741 if ( $conf->exists('welcome_email', $agentnum) ) {
742 $welcome_template = new Text::Template (
744 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
745 ) or warn "can't create welcome email template: $Text::Template::ERROR";
746 $welcome_from = $conf->config('welcome_email-from', $agentnum);
747 # || 'your-isp-is-dum'
748 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
750 $welcome_subject_template = new Text::Template (
752 SOURCE => $welcome_subject,
753 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
754 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
757 if ( $welcome_template ) {
758 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
762 'custnum' => $self->custnum,
763 'username' => $self->username,
764 'password' => $self->_password,
765 'first' => $cust_main->first,
766 'last' => $cust_main->getfield('last'),
767 'pkg' => $cust_pkg->part_pkg->pkg,
769 my $wqueue = new FS::queue {
770 'svcnum' => $self->svcnum,
771 'job' => 'FS::svc_acct::send_email'
773 my $error = $wqueue->insert(
775 'from' => $welcome_from,
776 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
777 'mimetype' => $welcome_mimetype,
778 'body' => $welcome_template->fill_in( HASH => \%hash, ),
781 $dbh->rollback if $oldAutoCommit;
782 return "error queuing welcome email: $error";
785 if ( $options{'depend_jobnum'} ) {
786 warn "$me depend_jobnum found; adding to welcome email dependancies"
788 if ( ref($options{'depend_jobnum'}) ) {
789 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
790 "to welcome email dependancies"
792 push @jobnums, @{ $options{'depend_jobnum'} };
794 warn "$me adding job $options{'depend_jobnum'} ".
795 "to welcome email dependancies"
797 push @jobnums, $options{'depend_jobnum'};
801 foreach my $jobnum ( @jobnums ) {
802 my $error = $wqueue->depend_insert($jobnum);
804 $dbh->rollback if $oldAutoCommit;
805 return "error queuing welcome email job dependancy: $error";
811 } # if $welcome_template
816 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
820 # set usage fields and thresholds if unset but set in a package def
821 # AND the package already has a last bill date (otherwise they get double added)
822 sub preinsert_hook_first {
825 return '' unless $self->pkgnum;
827 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
828 return '' unless $cust_pkg && $cust_pkg->last_bill;
830 my $part_pkg = $cust_pkg->part_pkg;
831 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
833 my %values = $part_pkg->usage_valuehash;
834 my $multiplier = $conf->exists('svc_acct-usage_threshold')
835 ? 1 - $conf->config('svc_acct-usage_threshold')/100
836 : 0.20; #doesn't matter
838 foreach ( keys %values ) {
839 next if $self->getfield($_);
840 $self->setfield( $_, $values{$_} );
841 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
842 if $conf->exists('svc_acct-usage_threshold');
850 Deletes this account from the database. If there is an error, returns the
851 error, otherwise returns false.
853 The corresponding FS::cust_svc record will be deleted as well.
855 (TODOC: new exports!)
862 return "can't delete system account" if $self->_check_system;
864 return "Can't delete an account which is a (svc_forward) source!"
865 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
867 return "Can't delete an account which is a (svc_forward) destination!"
868 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
870 return "Can't delete an account with (svc_www) web service!"
871 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
873 # what about records in session ? (they should refer to history table)
875 local $SIG{HUP} = 'IGNORE';
876 local $SIG{INT} = 'IGNORE';
877 local $SIG{QUIT} = 'IGNORE';
878 local $SIG{TERM} = 'IGNORE';
879 local $SIG{TSTP} = 'IGNORE';
880 local $SIG{PIPE} = 'IGNORE';
882 my $oldAutoCommit = $FS::UID::AutoCommit;
883 local $FS::UID::AutoCommit = 0;
886 foreach my $cust_main_invoice (
887 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
889 unless ( defined($cust_main_invoice) ) {
890 warn "WARNING: something's wrong with qsearch";
893 my %hash = $cust_main_invoice->hash;
894 $hash{'dest'} = $self->email;
895 my $new = new FS::cust_main_invoice \%hash;
896 my $error = $new->replace($cust_main_invoice);
898 $dbh->rollback if $oldAutoCommit;
903 foreach my $svc_domain (
904 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
906 my %hash = new FS::svc_domain->hash;
907 $hash{'catchall'} = '';
908 my $new = new FS::svc_domain \%hash;
909 my $error = $new->replace($svc_domain);
911 $dbh->rollback if $oldAutoCommit;
916 my $error = $self->SUPER::delete; # usergroup here
918 $dbh->rollback if $oldAutoCommit;
922 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
926 =item replace OLD_RECORD
928 Replaces OLD_RECORD with this one in the database. If there is an error,
929 returns the error, otherwise returns false.
931 The additional field I<usergroup> can optionally be defined; if so it should
932 contain an arrayref of group names. See L<FS::radius_usergroup>.
940 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
944 warn "$me replacing $old with $new\n" if $DEBUG;
948 return "can't modify system account" if $old->_check_system;
951 #no warnings 'numeric'; #alas, a 5.006-ism
954 foreach my $xid (qw( uid gid )) {
956 return "Can't change $xid!"
957 if ! $conf->exists("svc_acct-edit_$xid")
958 && $old->$xid() != $new->$xid()
959 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
964 return "can't change username"
965 if $old->username ne $new->username
966 && $conf->exists('svc_acct-no_edit_username');
968 #change homdir when we change username
969 $new->setfield('dir', '') if $old->username ne $new->username;
971 local $SIG{HUP} = 'IGNORE';
972 local $SIG{INT} = 'IGNORE';
973 local $SIG{QUIT} = 'IGNORE';
974 local $SIG{TERM} = 'IGNORE';
975 local $SIG{TSTP} = 'IGNORE';
976 local $SIG{PIPE} = 'IGNORE';
978 my $oldAutoCommit = $FS::UID::AutoCommit;
979 local $FS::UID::AutoCommit = 0;
982 $error = $new->SUPER::replace($old, @_); # usergroup here
984 $dbh->rollback if $oldAutoCommit;
985 return $error if $error;
988 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
989 $error = $new->queue_fuzzyfiles_update;
991 $dbh->rollback if $oldAutoCommit;
992 return "updating fuzzy search cache: $error";
996 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1000 =item queue_fuzzyfiles_update
1002 Used by insert & replace to update the fuzzy search cache
1006 sub queue_fuzzyfiles_update {
1009 local $SIG{HUP} = 'IGNORE';
1010 local $SIG{INT} = 'IGNORE';
1011 local $SIG{QUIT} = 'IGNORE';
1012 local $SIG{TERM} = 'IGNORE';
1013 local $SIG{TSTP} = 'IGNORE';
1014 local $SIG{PIPE} = 'IGNORE';
1016 my $oldAutoCommit = $FS::UID::AutoCommit;
1017 local $FS::UID::AutoCommit = 0;
1020 my $queue = new FS::queue {
1021 'svcnum' => $self->svcnum,
1022 'job' => 'FS::svc_acct::append_fuzzyfiles'
1024 my $error = $queue->insert($self->username);
1026 $dbh->rollback if $oldAutoCommit;
1027 return "queueing job (transaction rolled back): $error";
1030 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1038 Suspends this account by calling export-specific suspend hooks. If there is
1039 an error, returns the error, otherwise returns false.
1041 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1047 return "can't suspend system account" if $self->_check_system;
1048 $self->SUPER::suspend(@_);
1053 Unsuspends this account by by calling export-specific suspend hooks. If there
1054 is an error, returns the error, otherwise returns false.
1056 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1062 my %hash = $self->hash;
1063 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1064 $hash{_password} = $1;
1065 my $new = new FS::svc_acct ( \%hash );
1066 my $error = $new->replace($self);
1067 return $error if $error;
1070 $self->SUPER::unsuspend(@_);
1075 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1077 If the B<auto_unset_catchall> configuration option is set, this method will
1078 automatically remove any references to the canceled service in the catchall
1079 field of svc_domain. This allows packages that contain both a svc_domain and
1080 its catchall svc_acct to be canceled in one step.
1085 # Only one thing to do at this level
1087 foreach my $svc_domain (
1088 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1089 if($conf->exists('auto_unset_catchall')) {
1090 my %hash = $svc_domain->hash;
1091 $hash{catchall} = '';
1092 my $new = new FS::svc_domain ( \%hash );
1093 my $error = $new->replace($svc_domain);
1094 return $error if $error;
1096 return "cannot unprovision svc_acct #".$self->svcnum.
1097 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1101 $self->SUPER::cancel(@_);
1107 Checks all fields to make sure this is a valid service. If there is an error,
1108 returns the error, otherwise returns false. Called by the insert and replace
1111 Sets any fixed values; see L<FS::part_svc>.
1118 my($recref) = $self->hashref;
1120 my $x = $self->setfixed;
1121 return $x unless ref($x);
1124 my $error = $self->ut_numbern('svcnum')
1125 #|| $self->ut_number('domsvc')
1126 || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1127 || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx', 'svcnum' )
1128 || $self->ut_foreign_keyn('sectornum','tower_sector','sectornum')
1129 || $self->ut_textn('sec_phrase')
1130 || $self->ut_snumbern('seconds')
1131 || $self->ut_snumbern('upbytes')
1132 || $self->ut_snumbern('downbytes')
1133 || $self->ut_snumbern('totalbytes')
1134 || $self->ut_snumbern('seconds_threshold')
1135 || $self->ut_snumbern('upbytes_threshold')
1136 || $self->ut_snumbern('downbytes_threshold')
1137 || $self->ut_snumbern('totalbytes_threshold')
1138 || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1139 || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1140 || $self->ut_enum('password_recover', [ '', 'Y' ])
1142 || $self->ut_anything('cf_privatekey')
1144 || $self->ut_textn('cgp_accessmodes')
1145 || $self->ut_alphan('cgp_type')
1146 || $self->ut_textn('cgp_aliases' ) #well
1148 || $self->ut_alphasn('cgp_rulesallowed')
1149 || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1150 || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1151 || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1152 || $self->ut_snumbern('cgp_archiveafter')
1154 || $self->ut_alphasn('cgp_deletemode')
1155 || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1156 || $self->ut_alphan('cgp_language')
1157 || $self->ut_textn('cgp_timezone')
1158 || $self->ut_textn('cgp_skinname')
1159 || $self->ut_textn('cgp_prontoskinname')
1160 || $self->ut_alphan('cgp_sendmdnmode')
1162 return $error if $error;
1165 local $username_letter = $username_letter;
1166 local $username_uppercase = $username_uppercase;
1167 if ($self->svcnum) {
1168 my $cust_svc = $self->cust_svc
1169 or return "no cust_svc record found for svcnum ". $self->svcnum;
1170 my $cust_pkg = $cust_svc->cust_pkg;
1172 if ($self->pkgnum) {
1173 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1177 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1178 $username_uppercase =
1179 $conf->exists('username-uppercase', $cust_pkg->cust_main->agentnum);
1182 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1184 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#]{$usernamemin,$ulen})$/i
1185 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1186 $recref->{username} = $1;
1188 unless ( $username_uppercase ) {
1189 $recref->{username} =~ /[A-Z]/ and return gettext('illegal_username');
1191 if ( $username_letterfirst ) {
1192 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1193 } elsif ( $username_letter ) {
1194 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1196 if ( $username_noperiod ) {
1197 $recref->{username} =~ /\./ and return gettext('illegal_username');
1199 if ( $username_nounderscore ) {
1200 $recref->{username} =~ /_/ and return gettext('illegal_username');
1202 if ( $username_nodash ) {
1203 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1205 unless ( $username_ampersand ) {
1206 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1208 unless ( $username_percent ) {
1209 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1211 unless ( $username_colon ) {
1212 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1214 unless ( $username_slash ) {
1215 $recref->{username} =~ /\// and return gettext('illegal_username');
1217 unless ( $username_equals ) {
1218 $recref->{username} =~ /\=/ and return gettext('illegal_username');
1220 unless ( $username_pound ) {
1221 $recref->{username} =~ /\#/ and return gettext('illegal_username');
1225 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1226 $recref->{popnum} = $1;
1227 return "Unknown popnum" unless
1228 ! $recref->{popnum} ||
1229 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1231 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1233 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1234 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1236 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1237 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1238 #not all systems use gid=uid
1239 #you can set a fixed gid in part_svc
1241 return "Only root can have uid 0"
1242 if $recref->{uid} == 0
1243 && $recref->{username} !~ /^(root|toor|smtp)$/;
1245 unless ( $recref->{username} eq 'sync' ) {
1246 if ( grep $_ eq $recref->{shell}, @shells ) {
1247 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1249 return "Illegal shell \`". $self->shell. "\'; ".
1250 "shells configuration value contains: @shells";
1253 $recref->{shell} = '/bin/sync';
1257 $recref->{gid} ne '' ?
1258 return "Can't have gid without uid" : ( $recref->{gid}='' );
1259 #$recref->{dir} ne '' ?
1260 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1261 $recref->{shell} ne '' ?
1262 return "Can't have shell without uid" : ( $recref->{shell}='' );
1265 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1267 $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1268 or return "Illegal directory: ". $recref->{dir};
1269 $recref->{dir} = $1;
1270 return "Illegal directory"
1271 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1272 return "Illegal directory"
1273 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1274 unless ( $recref->{dir} ) {
1275 $recref->{dir} = $dir_prefix . '/';
1276 if ( $dirhash > 0 ) {
1277 for my $h ( 1 .. $dirhash ) {
1278 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1280 } elsif ( $dirhash < 0 ) {
1281 for my $h ( reverse $dirhash .. -1 ) {
1282 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1285 $recref->{dir} .= $recref->{username};
1291 if ( $self->getfield('finger') eq '' ) {
1292 my $cust_pkg = $self->svcnum
1293 ? $self->cust_svc->cust_pkg
1294 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1296 my $cust_main = $cust_pkg->cust_main;
1297 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1300 # $error = $self->ut_textn('finger');
1301 # return $error if $error;
1302 $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]*)$/
1303 or return "Illegal finger: ". $self->getfield('finger');
1304 $self->setfield('finger', $1);
1306 for (qw( quota file_quota file_maxsize )) {
1307 $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1310 $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1311 $recref->{file_maxnum} = $1;
1313 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1314 if ( $recref->{slipip} eq '' ) {
1315 $recref->{slipip} = '';
1316 } elsif ( $recref->{slipip} eq '0e0' ) {
1317 $recref->{slipip} = '0e0';
1319 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1320 or return "Illegal slipip: ". $self->slipip;
1321 $recref->{slipip} = $1;
1326 #arbitrary RADIUS stuff; allow ut_textn for now
1327 foreach ( grep /^radius_/, fields('svc_acct') ) {
1328 $self->ut_textn($_);
1331 # First, if _password is blank, generate one and set default encoding.
1332 if ( ! $recref->{_password} ) {
1333 $error = $self->set_password('');
1335 # But if there's a _password but no encoding, assume it's plaintext and
1336 # set it to default encoding.
1337 elsif ( ! $recref->{_password_encoding} ) {
1338 $error = $self->set_password($recref->{_password});
1340 return $error if $error;
1342 # Next, check _password to ensure compliance with the encoding.
1343 if ( $recref->{_password_encoding} eq 'ldap' ) {
1345 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1346 $recref->{_password} = uc($1).$2;
1348 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1351 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1353 if ( $recref->{_password} =~
1354 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1355 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1358 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1361 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1364 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1365 # Password randomization is now in set_password.
1366 # Strip whitespace characters, check length requirements, etc.
1367 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1368 $recref->{_password} = $1;
1370 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1371 FS::Msgcat::_gettext('illegal_password_characters').
1372 ": ". $recref->{_password};
1375 if ( $password_noampersand ) {
1376 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1378 if ( $password_noexclamation ) {
1379 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1383 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1385 $self->SUPER::check;
1390 sub _password_encryption {
1392 my $encoding = lc($self->_password_encoding);
1393 return if !$encoding;
1394 return 'plain' if $encoding eq 'plain';
1395 if($encoding eq 'crypt') {
1396 my $pass = $self->_password;
1397 $pass =~ s/^\*SUSPENDED\* //;
1399 return 'md5' if $pass =~ /^\$1\$/;
1400 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1401 return 'des' if length($pass) == 13;
1404 if($encoding eq 'ldap') {
1405 uc($self->_password) =~ /^\{([\w-]+)\}/;
1406 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1407 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1408 return 'md5' if $1 eq 'MD5';
1409 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1416 sub get_cleartext_password {
1418 if($self->_password_encryption eq 'plain') {
1419 if($self->_password_encoding eq 'ldap') {
1420 $self->_password =~ /\{\w+\}(.*)$/;
1424 return $self->_password;
1433 Set the cleartext password for the account. If _password_encoding is set, the
1434 new password will be encoded according to the existing method (including
1435 encryption mode, if it can be determined). Otherwise,
1436 config('default-password-encoding') is used.
1438 If no password is supplied (or a zero-length password when minimum password length
1439 is >0), one will be generated randomly.
1444 my( $self, $pass ) = ( shift, shift );
1446 warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1449 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1450 FS::Msgcat::_gettext('illegal_password_characters').
1453 my( $encoding, $encryption ) = ('', '');
1455 if ( $self->_password_encoding ) {
1456 $encoding = $self->_password_encoding;
1457 # identify existing encryption method, try to use it.
1458 $encryption = $self->_password_encryption;
1460 # use the system default
1466 # set encoding to system default
1467 ($encoding, $encryption) =
1468 split(/-/, lc($conf->config('default-password-encoding') || ''));
1469 $encoding ||= 'legacy';
1470 $self->_password_encoding($encoding);
1473 if ( $encoding eq 'legacy' ) {
1475 # The legacy behavior from check():
1476 # If the password is blank, randomize it and set encoding to 'plain'.
1477 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1478 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1479 $self->_password_encoding('plain');
1481 # Prefix + valid-length password
1482 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1484 $self->_password_encoding('plain');
1485 # Prefix + crypt string
1486 } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1488 $self->_password_encoding('crypt');
1489 # Various disabled crypt passwords
1490 } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1491 $self->_password_encoding('crypt');
1497 $self->_password($pass);
1503 if $passwordmin && length($pass) < $passwordmin
1504 or $passwordmax && length($pass) > $passwordmax;
1506 if ( $encoding eq 'crypt' ) {
1507 if ($encryption eq 'md5') {
1508 $pass = unix_md5_crypt($pass);
1509 } elsif ($encryption eq 'des') {
1510 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1513 } elsif ( $encoding eq 'ldap' ) {
1514 if ($encryption eq 'md5') {
1515 $pass = md5_base64($pass);
1516 } elsif ($encryption eq 'sha1') {
1517 $pass = sha1_base64($pass);
1518 } elsif ($encryption eq 'crypt') {
1519 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1521 # else $encryption eq 'plain', do nothing
1522 $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1523 if $encryption eq 'md5' || $encryption eq 'sha1';
1524 $pass = '{'.uc($encryption).'}'.$pass;
1526 # else encoding eq 'plain'
1528 $self->_password($pass);
1534 Internal function to check the username against the list of system usernames
1535 from the I<system_usernames> configuration value. Returns true if the username
1536 is listed on the system username list.
1542 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1543 $conf->config('system_usernames')
1547 =item _check_duplicate
1549 Internal method to check for duplicates usernames, username@domain pairs and
1552 If the I<global_unique-username> configuration value is set to B<username> or
1553 B<username@domain>, enforces global username or username@domain uniqueness.
1555 In all cases, check for duplicate uids and usernames or username@domain pairs
1556 per export and with identical I<svcpart> values.
1560 sub _check_duplicate {
1563 my $global_unique = $conf->config('global_unique-username') || 'none';
1564 return '' if $global_unique eq 'disabled';
1568 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1569 unless ( $part_svc ) {
1570 return 'unknown svcpart '. $self->svcpart;
1573 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1574 qsearch( 'svc_acct', { 'username' => $self->username } );
1575 return gettext('username_in_use')
1576 if $global_unique eq 'username' && @dup_user;
1578 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1579 qsearch( 'svc_acct', { 'username' => $self->username,
1580 'domsvc' => $self->domsvc } );
1581 return gettext('username_in_use')
1582 if $global_unique eq 'username@domain' && @dup_userdomain;
1585 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1586 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1587 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1588 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1593 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1594 my $exports = FS::part_export::export_info('svc_acct');
1595 my %conflict_user_svcpart;
1596 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1598 foreach my $part_export ( $part_svc->part_export ) {
1600 #this will catch to the same exact export
1601 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1603 #this will catch to exports w/same exporthost+type ???
1604 #my @other_part_export = qsearch('part_export', {
1605 # 'machine' => $part_export->machine,
1606 # 'exporttype' => $part_export->exporttype,
1608 #foreach my $other_part_export ( @other_part_export ) {
1609 # push @svcparts, map { $_->svcpart }
1610 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1613 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1614 #silly kludge to avoid uninitialized value errors
1615 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1616 ? $exports->{$part_export->exporttype}{'nodomain'}
1618 if ( $nodomain =~ /^Y/i ) {
1619 $conflict_user_svcpart{$_} = $part_export->exportnum
1622 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1627 foreach my $dup_user ( @dup_user ) {
1628 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1629 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1630 return "duplicate username ". $self->username.
1631 ": conflicts with svcnum ". $dup_user->svcnum.
1632 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1636 foreach my $dup_userdomain ( @dup_userdomain ) {
1637 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1638 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1639 return "duplicate username\@domain ". $self->email.
1640 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1641 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1645 foreach my $dup_uid ( @dup_uid ) {
1646 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1647 if ( exists($conflict_user_svcpart{$dup_svcpart})
1648 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1649 return "duplicate uid ". $self->uid.
1650 ": conflicts with svcnum ". $dup_uid->svcnum.
1652 ( $conflict_user_svcpart{$dup_svcpart}
1653 || $conflict_userdomain_svcpart{$dup_svcpart} );
1665 Depriciated, use radius_reply instead.
1670 carp "FS::svc_acct::radius depriciated, use radius_reply";
1671 $_[0]->radius_reply;
1676 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1677 reply attributes of this record.
1679 Note that this is now the preferred method for reading RADIUS attributes -
1680 accessing the columns directly is discouraged, as the column names are
1681 expected to change in the future.
1688 return %{ $self->{'radius_reply'} }
1689 if exists $self->{'radius_reply'};
1694 my($column, $attrib) = ($1, $2);
1695 #$attrib =~ s/_/\-/g;
1696 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1697 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1699 if ( $self->slipip && $self->slipip ne '0e0' ) {
1700 $reply{$radius_ip} = $self->slipip;
1703 if ( $self->seconds !~ /^$/ ) {
1704 $reply{'Session-Timeout'} = $self->seconds;
1707 if ( $conf->exists('radius-chillispot-max') ) {
1708 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1710 #hmm. just because sqlradius.pm says so?
1717 foreach my $what (qw( input output total )) {
1718 my $is = $whatis{$what}.'bytes';
1719 if ( $self->$is() =~ /\d/ ) {
1720 my $big = new Math::BigInt $self->$is();
1721 $big = new Math::BigInt '0' if $big->is_neg();
1722 my $att = "Chillispot-Max-\u$what";
1723 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1724 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1735 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1736 check attributes of this record.
1738 Note that this is now the preferred method for reading RADIUS attributes -
1739 accessing the columns directly is discouraged, as the column names are
1740 expected to change in the future.
1747 return %{ $self->{'radius_check'} }
1748 if exists $self->{'radius_check'};
1753 my($column, $attrib) = ($1, $2);
1754 #$attrib =~ s/_/\-/g;
1755 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1756 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1759 my($pw_attrib, $password) = $self->radius_password;
1760 $check{$pw_attrib} = $password;
1762 my $cust_svc = $self->cust_svc;
1764 my $cust_pkg = $cust_svc->cust_pkg;
1765 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1766 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1769 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1770 "; can't set Expiration\n"
1778 =item radius_password
1780 Returns a key/value pair containing the RADIUS attribute name and value
1785 sub radius_password {
1789 if ( $self->_password_encoding eq 'ldap' ) {
1790 $pw_attrib = 'Password-With-Header';
1791 } elsif ( $self->_password_encoding eq 'crypt' ) {
1792 $pw_attrib = 'Crypt-Password';
1793 } elsif ( $self->_password_encoding eq 'plain' ) {
1794 $pw_attrib = $radius_password;
1796 $pw_attrib = length($self->_password) <= 12
1801 ($pw_attrib, $self->_password);
1807 This method instructs the object to "snapshot" or freeze RADIUS check and
1808 reply attributes to the current values.
1812 #bah, my english is too broken this morning
1813 #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
1814 #the FS::cust_pkg's replace method to trigger the correct export updates when
1815 #package dates change)
1820 $self->{$_} = { $self->$_() }
1821 foreach qw( radius_reply radius_check );
1825 =item forget_snapshot
1827 This methos instructs the object to forget any previously snapshotted
1828 RADIUS check and reply attributes.
1832 sub forget_snapshot {
1836 foreach qw( radius_reply radius_check );
1840 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1842 Returns the domain associated with this account.
1844 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1851 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1852 my $svc_domain = $self->svc_domain(@_)
1853 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1854 $svc_domain->domain;
1859 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1863 #inherited from svc_Common
1865 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1867 Returns an email address associated with the account.
1869 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1876 $self->username. '@'. $self->domain(@_);
1881 Returns an array of FS::acct_snarf records associated with the account.
1888 'table' => 'acct_snarf',
1889 'hashref' => { 'svcnum' => $self->svcnum },
1890 #'order_by' => 'ORDER BY priority ASC',
1894 =item cgp_rpop_hashref
1896 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1900 sub cgp_rpop_hashref {
1902 { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1905 =item decrement_upbytes OCTETS
1907 Decrements the I<upbytes> field of this record by the given amount. If there
1908 is an error, returns the error, otherwise returns false.
1912 sub decrement_upbytes {
1913 shift->_op_usage('-', 'upbytes', @_);
1916 =item increment_upbytes OCTETS
1918 Increments the I<upbytes> field of this record by the given amount. If there
1919 is an error, returns the error, otherwise returns false.
1923 sub increment_upbytes {
1924 shift->_op_usage('+', 'upbytes', @_);
1927 =item decrement_downbytes OCTETS
1929 Decrements the I<downbytes> field of this record by the given amount. If there
1930 is an error, returns the error, otherwise returns false.
1934 sub decrement_downbytes {
1935 shift->_op_usage('-', 'downbytes', @_);
1938 =item increment_downbytes OCTETS
1940 Increments the I<downbytes> field of this record by the given amount. If there
1941 is an error, returns the error, otherwise returns false.
1945 sub increment_downbytes {
1946 shift->_op_usage('+', 'downbytes', @_);
1949 =item decrement_totalbytes OCTETS
1951 Decrements the I<totalbytes> field of this record by the given amount. If there
1952 is an error, returns the error, otherwise returns false.
1956 sub decrement_totalbytes {
1957 shift->_op_usage('-', 'totalbytes', @_);
1960 =item increment_totalbytes OCTETS
1962 Increments the I<totalbytes> field of this record by the given amount. If there
1963 is an error, returns the error, otherwise returns false.
1967 sub increment_totalbytes {
1968 shift->_op_usage('+', 'totalbytes', @_);
1971 =item decrement_seconds SECONDS
1973 Decrements the I<seconds> field of this record by the given amount. If there
1974 is an error, returns the error, otherwise returns false.
1978 sub decrement_seconds {
1979 shift->_op_usage('-', 'seconds', @_);
1982 =item increment_seconds SECONDS
1984 Increments the I<seconds> field of this record by the given amount. If there
1985 is an error, returns the error, otherwise returns false.
1989 sub increment_seconds {
1990 shift->_op_usage('+', 'seconds', @_);
1998 my %op2condition = (
1999 '-' => sub { my($self, $column, $amount) = @_;
2000 $self->$column - $amount <= 0;
2002 '+' => sub { my($self, $column, $amount) = @_;
2003 ($self->$column || 0) + $amount > 0;
2006 my %op2warncondition = (
2007 '-' => sub { my($self, $column, $amount) = @_;
2008 my $threshold = $column . '_threshold';
2009 $self->$column - $amount <= $self->$threshold + 0;
2011 '+' => sub { my($self, $column, $amount) = @_;
2012 ($self->$column || 0) + $amount > 0;
2017 my( $self, $op, $column, $amount ) = @_;
2019 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2020 ' ('. $self->email. "): $op $amount\n"
2023 return '' unless $amount;
2025 local $SIG{HUP} = 'IGNORE';
2026 local $SIG{INT} = 'IGNORE';
2027 local $SIG{QUIT} = 'IGNORE';
2028 local $SIG{TERM} = 'IGNORE';
2029 local $SIG{TSTP} = 'IGNORE';
2030 local $SIG{PIPE} = 'IGNORE';
2032 my $oldAutoCommit = $FS::UID::AutoCommit;
2033 local $FS::UID::AutoCommit = 0;
2036 my $sql = "UPDATE svc_acct SET $column = ".
2037 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2038 " $op ? WHERE svcnum = ?";
2042 my $sth = $dbh->prepare( $sql )
2043 or die "Error preparing $sql: ". $dbh->errstr;
2044 my $rv = $sth->execute($amount, $self->svcnum);
2045 die "Error executing $sql: ". $sth->errstr
2046 unless defined($rv);
2047 die "Can't update $column for svcnum". $self->svcnum
2050 #$self->snapshot; #not necessary, we retain the old values
2051 #create an object with the updated usage values
2052 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2054 my $error = $new->replace($self);
2056 $dbh->rollback if $oldAutoCommit;
2057 return "Error replacing: $error";
2060 #overlimit_action eq 'cancel' handling
2061 my $cust_pkg = $self->cust_svc->cust_pkg;
2063 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2064 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2068 my $error = $cust_pkg->cancel; #XXX should have a reason
2070 $dbh->rollback if $oldAutoCommit;
2071 return "Error cancelling: $error";
2074 #nothing else is relevant if we're cancelling, so commit & return success
2075 warn "$me update successful; committing\n"
2077 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2082 my $action = $op2action{$op};
2084 if ( &{$op2condition{$op}}($self, $column, $amount) &&
2085 ( $action eq 'suspend' && !$self->overlimit
2086 || $action eq 'unsuspend' && $self->overlimit )
2089 my $error = $self->_op_overlimit($action);
2091 $dbh->rollback if $oldAutoCommit;
2097 if ( $conf->exists("svc_acct-usage_$action")
2098 && &{$op2condition{$op}}($self, $column, $amount) ) {
2099 #my $error = $self->$action();
2100 my $error = $self->cust_svc->cust_pkg->$action();
2101 # $error ||= $self->overlimit($action);
2103 $dbh->rollback if $oldAutoCommit;
2104 return "Error ${action}ing: $error";
2108 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2109 my $wqueue = new FS::queue {
2110 'svcnum' => $self->svcnum,
2111 'job' => 'FS::svc_acct::reached_threshold',
2116 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2120 my $error = $wqueue->insert(
2121 'svcnum' => $self->svcnum,
2123 'column' => $column,
2127 $dbh->rollback if $oldAutoCommit;
2128 return "Error queuing threshold activity: $error";
2132 warn "$me update successful; committing\n"
2134 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2140 my( $self, $action ) = @_;
2142 local $SIG{HUP} = 'IGNORE';
2143 local $SIG{INT} = 'IGNORE';
2144 local $SIG{QUIT} = 'IGNORE';
2145 local $SIG{TERM} = 'IGNORE';
2146 local $SIG{TSTP} = 'IGNORE';
2147 local $SIG{PIPE} = 'IGNORE';
2149 my $oldAutoCommit = $FS::UID::AutoCommit;
2150 local $FS::UID::AutoCommit = 0;
2153 my $cust_pkg = $self->cust_svc->cust_pkg;
2155 my @conf_overlimit =
2157 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2158 : $conf->config('overlimit_groups');
2160 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2162 my @groups = scalar(@conf_overlimit) ? @conf_overlimit
2163 : split(' ',$part_export->option('overlimit_groups'));
2164 next unless scalar(@groups);
2166 my $other = new FS::svc_acct $self->hashref;
2167 $other->usergroup(\@groups);
2170 if ($action eq 'suspend') {
2173 } else { # $action eq 'unsuspend'
2178 my $error = $part_export->export_replace($new, $old)
2179 || $self->overlimit($action);
2182 $dbh->rollback if $oldAutoCommit;
2183 return "Error replacing radius groups: $error";
2188 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2194 my( $self, $valueref, %options ) = @_;
2196 warn "$me set_usage called for svcnum ". $self->svcnum.
2197 ' ('. $self->email. "): ".
2198 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2201 local $SIG{HUP} = 'IGNORE';
2202 local $SIG{INT} = 'IGNORE';
2203 local $SIG{QUIT} = 'IGNORE';
2204 local $SIG{TERM} = 'IGNORE';
2205 local $SIG{TSTP} = 'IGNORE';
2206 local $SIG{PIPE} = 'IGNORE';
2208 local $FS::svc_Common::noexport_hack = 1;
2209 my $oldAutoCommit = $FS::UID::AutoCommit;
2210 local $FS::UID::AutoCommit = 0;
2215 if ( $options{null} ) {
2216 %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2217 qw( seconds upbytes downbytes totalbytes )
2220 foreach my $field (keys %$valueref){
2221 $reset = 1 if $valueref->{$field};
2222 $self->setfield($field, $valueref->{$field});
2223 $self->setfield( $field.'_threshold',
2224 int($self->getfield($field)
2225 * ( $conf->exists('svc_acct-usage_threshold')
2226 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2231 $handyhash{$field} = $self->getfield($field);
2232 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2234 #my $error = $self->replace; #NO! we avoid the call to ->check for
2235 #die $error if $error; #services not explicity changed via the UI
2237 my $sql = "UPDATE svc_acct SET " .
2238 join (',', map { "$_ = ?" } (keys %handyhash) ).
2239 " WHERE svcnum = ". $self->svcnum;
2244 if (scalar(keys %handyhash)) {
2245 my $sth = $dbh->prepare( $sql )
2246 or die "Error preparing $sql: ". $dbh->errstr;
2247 my $rv = $sth->execute(values %handyhash);
2248 die "Error executing $sql: ". $sth->errstr
2249 unless defined($rv);
2250 die "Can't update usage for svcnum ". $self->svcnum
2254 #$self->snapshot; #not necessary, we retain the old values
2255 #create an object with the updated usage values
2256 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2257 local($FS::Record::nowarn_identical) = 1;
2258 my $error = $new->replace($self); #call exports
2260 $dbh->rollback if $oldAutoCommit;
2261 return "Error replacing: $error";
2268 $error = $self->_op_overlimit('unsuspend')
2269 if $self->overlimit;;
2271 $error ||= $self->cust_svc->cust_pkg->unsuspend
2272 if $conf->exists("svc_acct-usage_unsuspend");
2275 $dbh->rollback if $oldAutoCommit;
2276 return "Error unsuspending: $error";
2281 warn "$me update successful; committing\n"
2283 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2289 =item recharge HASHREF
2291 Increments usage columns by the amount specified in HASHREF as
2292 column=>amount pairs.
2297 my ($self, $vhash) = @_;
2300 warn "[$me] recharge called on $self: ". Dumper($self).
2301 "\nwith vhash: ". Dumper($vhash);
2304 my $oldAutoCommit = $FS::UID::AutoCommit;
2305 local $FS::UID::AutoCommit = 0;
2309 foreach my $column (keys %$vhash){
2310 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2314 $dbh->rollback if $oldAutoCommit;
2316 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2321 =item is_rechargeable
2323 Returns true if this svc_account can be "recharged" and false otherwise.
2327 sub is_rechargable {
2329 $self->seconds ne ''
2330 || $self->upbytes ne ''
2331 || $self->downbytes ne ''
2332 || $self->totalbytes ne '';
2335 =item seconds_since TIMESTAMP
2337 Returns the number of seconds this account has been online since TIMESTAMP,
2338 according to the session monitor (see L<FS::Session>).
2340 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2341 L<Time::Local> and L<Date::Parse> for conversion functions.
2345 #note: POD here, implementation in FS::cust_svc
2348 $self->cust_svc->seconds_since(@_);
2351 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2353 Returns the numbers of seconds this account has been online between
2354 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2355 external SQL radacct table, specified via sqlradius export. Sessions which
2356 started in the specified range but are still open are counted from session
2357 start to the end of the range (unless they are over 1 day old, in which case
2358 they are presumed missing their stop record and not counted). Also, sessions
2359 which end in the range but started earlier are counted from the start of the
2360 range to session end. Finally, sessions which start before the range but end
2361 after are counted for the entire range.
2363 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2364 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2369 #note: POD here, implementation in FS::cust_svc
2370 sub seconds_since_sqlradacct {
2372 $self->cust_svc->seconds_since_sqlradacct(@_);
2375 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2377 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2378 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2379 TIMESTAMP_END (exclusive).
2381 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2382 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2387 #note: POD here, implementation in FS::cust_svc
2388 sub attribute_since_sqlradacct {
2390 $self->cust_svc->attribute_since_sqlradacct(@_);
2393 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2395 Returns an array of hash references of this customers login history for the
2396 given time range. (document this better)
2400 sub get_session_history {
2402 $self->cust_svc->get_session_history(@_);
2405 =item last_login_text
2407 Returns text describing the time of last login.
2411 sub last_login_text {
2413 $self->last_login ? ctime($self->last_login) : 'unknown';
2416 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2421 my($self, $start, $end, %opt ) = @_;
2423 my $did = $self->username; #yup
2425 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2427 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2429 #SELECT $for_update * FROM cdr
2430 # WHERE calldate >= $start #need a conversion
2431 # AND calldate < $end #ditto
2432 # AND ( charged_party = "$did"
2433 # OR charged_party = "$prefix$did" #if length($prefix);
2434 # OR ( ( charged_party IS NULL OR charged_party = '' )
2436 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2439 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2442 if ( length($prefix) ) {
2444 " AND ( charged_party = '$did'
2445 OR charged_party = '$prefix$did'
2446 OR ( ( charged_party IS NULL OR charged_party = '' )
2448 ( src = '$did' OR src = '$prefix$did' )
2454 " AND ( charged_party = '$did'
2455 OR ( ( charged_party IS NULL OR charged_party = '' )
2465 'select' => "$for_update *",
2468 #( freesidestatus IS NULL OR freesidestatus = '' )
2469 'freesidestatus' => '',
2471 'extra_sql' => $charged_or_src,
2477 # sub radius_groups has moved to svc_Radius_Mixin
2479 =item clone_suspended
2481 Constructor used by FS::part_export::_export_suspend fallback. Document
2486 sub clone_suspended {
2488 my %hash = $self->hash;
2489 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2490 new FS::svc_acct \%hash;
2493 =item clone_kludge_unsuspend
2495 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2500 sub clone_kludge_unsuspend {
2502 my %hash = $self->hash;
2503 $hash{_password} = '';
2504 new FS::svc_acct \%hash;
2507 =item check_password
2509 Checks the supplied password against the (possibly encrypted) password in the
2510 database. Returns true for a successful authentication, false for no match.
2512 Currently supported encryptions are: classic DES crypt() and MD5
2516 sub check_password {
2517 my($self, $check_password) = @_;
2519 #remove old-style SUSPENDED kludge, they should be allowed to login to
2520 #self-service and pay up
2521 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2523 if ( $self->_password_encoding eq 'ldap' ) {
2525 $password =~ s/^{PLAIN}/{CLEARTEXT}/;
2526 my $auth = from_rfc2307 Authen::Passphrase $password;
2527 return $auth->match($check_password);
2529 } elsif ( $self->_password_encoding eq 'crypt' ) {
2531 my $auth = from_crypt Authen::Passphrase $self->_password;
2532 return $auth->match($check_password);
2534 } elsif ( $self->_password_encoding eq 'plain' ) {
2536 return $check_password eq $password;
2540 #XXX this could be replaced with Authen::Passphrase stuff
2542 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2544 } elsif ( length($password) < 13 ) { #plaintext
2545 $check_password eq $password;
2546 } elsif ( length($password) == 13 ) { #traditional DES crypt
2547 crypt($check_password, $password) eq $password;
2548 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2549 unix_md5_crypt($check_password, $password) eq $password;
2550 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2551 warn "Can't check password: Blowfish encryption not yet supported, ".
2552 "svcnum ". $self->svcnum. "\n";
2555 warn "Can't check password: Unrecognized encryption for svcnum ".
2556 $self->svcnum. "\n";
2564 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2566 Returns an encrypted password, either by passing through an encrypted password
2567 in the database or by encrypting a plaintext password from the database.
2569 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2570 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2571 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2572 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2573 encryption type is only used if the password is not already encrypted in the
2578 sub crypt_password {
2581 if ( $self->_password_encoding eq 'ldap' ) {
2583 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2586 #XXX this could be replaced with Authen::Passphrase stuff
2588 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2589 if ( $encryption eq 'crypt' ) {
2592 $saltset[int(rand(64))].$saltset[int(rand(64))]
2594 } elsif ( $encryption eq 'md5' ) {
2595 return unix_md5_crypt( $self->_password );
2596 } elsif ( $encryption eq 'blowfish' ) {
2597 croak "unknown encryption method $encryption";
2599 croak "unknown encryption method $encryption";
2602 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2606 } elsif ( $self->_password_encoding eq 'crypt' ) {
2608 return $self->_password;
2610 } elsif ( $self->_password_encoding eq 'plain' ) {
2612 #XXX this could be replaced with Authen::Passphrase stuff
2614 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2615 if ( $encryption eq 'crypt' ) {
2618 $saltset[int(rand(64))].$saltset[int(rand(64))]
2620 } elsif ( $encryption eq 'md5' ) {
2621 return unix_md5_crypt( $self->_password );
2622 } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2623 my $pass = sha1_base64( $self->_password );
2624 $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2626 } elsif ( $encryption eq 'blowfish' ) {
2627 croak "unknown encryption method $encryption";
2629 croak "unknown encryption method $encryption";
2634 if ( length($self->_password) == 13
2635 || $self->_password =~ /^\$(1|2a?)\$/
2636 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2642 #XXX this could be replaced with Authen::Passphrase stuff
2644 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2645 if ( $encryption eq 'crypt' ) {
2648 $saltset[int(rand(64))].$saltset[int(rand(64))]
2650 } elsif ( $encryption eq 'md5' ) {
2651 return unix_md5_crypt( $self->_password );
2652 } elsif ( $encryption eq 'blowfish' ) {
2653 croak "unknown encryption method $encryption";
2655 croak "unknown encryption method $encryption";
2664 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2666 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2667 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2668 "{MD5}5426824942db4253f87a1009fd5d2d4".
2670 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2671 to work the same as the B</crypt_password> method.
2677 #eventually should check a "password-encoding" field
2679 if ( $self->_password_encoding eq 'ldap' ) {
2681 return $self->_password;
2683 } elsif ( $self->_password_encoding eq 'crypt' ) {
2685 if ( length($self->_password) == 13 ) { #crypt
2686 return '{CRYPT}'. $self->_password;
2687 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2689 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2690 # die "Blowfish encryption not supported in this context, svcnum ".
2691 # $self->svcnum. "\n";
2693 warn "encryption method not (yet?) supported in LDAP context";
2694 return '{CRYPT}*'; #unsupported, should not auth
2697 } elsif ( $self->_password_encoding eq 'plain' ) {
2699 return '{PLAIN}'. $self->_password;
2701 #return '{CLEARTEXT}'. $self->_password; #?
2705 if ( length($self->_password) == 13 ) { #crypt
2706 return '{CRYPT}'. $self->_password;
2707 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2709 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2710 warn "Blowfish encryption not supported in this context, svcnum ".
2711 $self->svcnum. "\n";
2714 #are these two necessary anymore?
2715 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2716 return '{SSHA}'. $1;
2717 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2718 return '{NS-MTA-MD5}'. $1;
2721 return '{PLAIN}'. $self->_password;
2723 #return '{CLEARTEXT}'. $self->_password; #?
2725 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2726 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2727 #if ( $encryption eq 'crypt' ) {
2728 # return '{CRYPT}'. crypt(
2730 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2732 #} elsif ( $encryption eq 'md5' ) {
2733 # unix_md5_crypt( $self->_password );
2734 #} elsif ( $encryption eq 'blowfish' ) {
2735 # croak "unknown encryption method $encryption";
2737 # croak "unknown encryption method $encryption";
2745 =item domain_slash_username
2747 Returns $domain/$username/
2751 sub domain_slash_username {
2753 $self->domain. '/'. $self->username. '/';
2756 =item virtual_maildir
2758 Returns $domain/maildirs/$username/
2762 sub virtual_maildir {
2764 $self->domain. '/maildirs/'. $self->username. '/';
2769 =head1 CLASS METHODS
2773 =item search HASHREF
2775 Class method which returns a qsearch hash expression to search for parameters
2776 specified in HASHREF. Valid parameters are
2790 Arrayref of pkgparts
2796 Arrayref of additional WHERE clauses, will be ANDed together.
2807 my ($class, $params) = @_;
2812 if ( $params->{'domain'} ) {
2813 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2814 #preserve previous behavior & bubble up an error if $svc_domain not found?
2815 push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2819 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2820 push @where, "domsvc = $1";
2824 push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2827 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2828 push @where, "cust_main.agentnum = $1";
2832 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2833 push @where, "custnum = $1";
2837 if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2838 #XXX untaint or sql quote
2840 'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2844 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2845 push @where, "popnum = $1";
2849 if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2850 push @where, "svcpart = $1";
2854 my @where_sector = $class->tower_sector_sql($params);
2855 push @where, @where_sector if @where_sector;
2857 # here is the agent virtualization
2858 #if ($params->{CurrentUser}) {
2860 # qsearchs('access_user', { username => $params->{CurrentUser} });
2862 # if ($access_user) {
2863 # push @where, $access_user->agentnums_sql('table'=>'cust_main');
2865 # push @where, "1=0";
2868 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2869 'table' => 'cust_main',
2870 'null_right' => 'View/link unlinked services',
2874 push @where, @{ $params->{'where'} } if $params->{'where'};
2876 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2878 my $addl_from = ' LEFT JOIN cust_svc USING ( svcnum ) '.
2879 ' LEFT JOIN part_svc USING ( svcpart ) '.
2880 ' LEFT JOIN cust_pkg USING ( pkgnum ) '.
2881 ' LEFT JOIN cust_main USING ( custnum ) ';
2883 $addl_from .= ' LEFT JOIN tower_sector USING ( sectornum )'
2886 my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2887 #if ( keys %svc_acct ) {
2888 # $count_query .= ' WHERE '.
2889 # join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2895 'table' => 'svc_acct',
2896 'hashref' => {}, # \%svc_acct,
2897 'select' => join(', ',
2900 'cust_main.custnum',
2901 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2903 'addl_from' => $addl_from,
2904 'extra_sql' => $extra_sql,
2905 'order_by' => $params->{'order_by'},
2906 'count_query' => $count_query,
2919 This is the FS::svc_acct job-queue-able version. It still uses
2920 FS::Misc::send_email under-the-hood.
2927 eval "use FS::Misc qw(send_email)";
2930 $opt{mimetype} ||= 'text/plain';
2931 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2933 my $error = send_email(
2934 'from' => $opt{from},
2936 'subject' => $opt{subject},
2937 'content-type' => $opt{mimetype},
2938 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2940 die $error if $error;
2943 =item check_and_rebuild_fuzzyfiles
2947 sub check_and_rebuild_fuzzyfiles {
2948 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2949 -e "$dir/svc_acct.username"
2950 or &rebuild_fuzzyfiles;
2953 =item rebuild_fuzzyfiles
2957 sub rebuild_fuzzyfiles {
2959 use Fcntl qw(:flock);
2961 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2965 open(USERNAMELOCK,">>$dir/svc_acct.username")
2966 or die "can't open $dir/svc_acct.username: $!";
2967 flock(USERNAMELOCK,LOCK_EX)
2968 or die "can't lock $dir/svc_acct.username: $!";
2970 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2972 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2973 or die "can't open $dir/svc_acct.username.tmp: $!";
2974 print USERNAMECACHE join("\n", @all_username), "\n";
2975 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2977 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2987 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2988 open(USERNAMECACHE,"<$dir/svc_acct.username")
2989 or die "can't open $dir/svc_acct.username: $!";
2990 my @array = map { chomp; $_; } <USERNAMECACHE>;
2991 close USERNAMECACHE;
2995 =item append_fuzzyfiles USERNAME
2999 sub append_fuzzyfiles {
3000 my $username = shift;
3002 &check_and_rebuild_fuzzyfiles;
3004 use Fcntl qw(:flock);
3006 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3008 open(USERNAME,">>$dir/svc_acct.username")
3009 or die "can't open $dir/svc_acct.username: $!";
3010 flock(USERNAME,LOCK_EX)
3011 or die "can't lock $dir/svc_acct.username: $!";
3013 print USERNAME "$username\n";
3015 flock(USERNAME,LOCK_UN)
3016 or die "can't unlock $dir/svc_acct.username: $!";
3023 =item reached_threshold
3025 Performs some activities when svc_acct thresholds (such as number of seconds
3026 remaining) are reached.
3030 sub reached_threshold {
3033 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3034 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3036 if ( $opt{'op'} eq '+' ){
3037 $svc_acct->setfield( $opt{'column'}.'_threshold',
3038 int($svc_acct->getfield($opt{'column'})
3039 * ( $conf->exists('svc_acct-usage_threshold')
3040 ? $conf->config('svc_acct-usage_threshold')/100
3045 my $error = $svc_acct->replace;
3046 die $error if $error;
3047 }elsif ( $opt{'op'} eq '-' ){
3049 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3050 return '' if ($threshold eq '' );
3052 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3053 my $error = $svc_acct->replace;
3054 die $error if $error; # email next time, i guess
3056 if ( $warning_template ) {
3057 eval "use FS::Misc qw(send_email)";
3060 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
3061 my $cust_main = $cust_pkg->cust_main;
3063 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3064 $cust_main->invoicing_list,
3065 ($opt{'to'} ? $opt{'to'} : ())
3068 my $mimetype = $warning_mimetype;
3069 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3071 my $body = $warning_template->fill_in( HASH => {
3072 'custnum' => $cust_main->custnum,
3073 'username' => $svc_acct->username,
3074 'password' => $svc_acct->_password,
3075 'first' => $cust_main->first,
3076 'last' => $cust_main->getfield('last'),
3077 'pkg' => $cust_pkg->part_pkg->pkg,
3078 'column' => $opt{'column'},
3079 'amount' => $opt{'column'} =~/bytes/
3080 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3081 : $svc_acct->getfield($opt{'column'}),
3082 'threshold' => $opt{'column'} =~/bytes/
3083 ? FS::UI::bytecount::display_bytecount($threshold)
3088 my $error = send_email(
3089 'from' => $warning_from,
3091 'subject' => $warning_subject,
3092 'content-type' => $mimetype,
3093 'body' => [ map "$_\n", split("\n", $body) ],
3095 die $error if $error;
3098 die "unknown op: " . $opt{'op'};
3106 The $recref stuff in sub check should be cleaned up.
3108 The suspend, unsuspend and cancel methods update the database, but not the
3109 current object. This is probably a bug as it's unexpected and
3112 insertion of RADIUS group stuff in insert could be done with child_objects now
3113 (would probably clean up export of them too)
3115 _op_usage and set_usage bypass the history... maybe they shouldn't
3119 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3120 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3121 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3122 L<freeside-queued>), L<FS::svc_acct_pop>,
3123 schema.html from the base documentation.