4 use base qw( FS::svc_Domain_Mixin
15 use vars qw( $DEBUG $me $conf $skip_fuzzyfiles
16 $dir_prefix @shells $usernamemin
17 $usernamemax $passwordmin $passwordmax
18 $username_ampersand $username_letter $username_letterfirst
19 $username_noperiod $username_nounderscore $username_nodash
20 $username_uppercase $username_percent $username_colon
21 $username_slash $username_equals $username_pound
23 $password_noampersand $password_noexclamation
24 $warning_template $warning_from $warning_subject $warning_mimetype
27 $radius_password $radius_ip
30 use Scalar::Util qw( blessed );
35 use Crypt::PasswdMD5 1.2;
36 use Digest::SHA 'sha1_base64';
37 use Digest::MD5 'md5_base64';
40 use Authen::Passphrase;
41 use FS::UID qw( datasrc driver_name );
43 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
44 use FS::Msgcat qw(gettext);
45 use FS::UI::bytecount;
47 use FS::PagedSearch qw( psearch ); # XXX in v4, replace with FS::Cursor
51 use FS::cust_main_invoice;
56 use FS::radius_usergroup;
67 $me = '[FS::svc_acct]';
69 #ask FS::UID to run this stuff for us later
70 FS::UID->install_callback( sub {
72 $dir_prefix = $conf->config('home');
73 @shells = $conf->config('shells');
74 $usernamemin = $conf->config('usernamemin') || 2;
75 $usernamemax = $conf->config('usernamemax');
76 $passwordmin = $conf->config('passwordmin'); # || 6;
78 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
81 $passwordmax = $conf->config('passwordmax') || 8;
82 $username_letter = $conf->exists('username-letter');
83 $username_letterfirst = $conf->exists('username-letterfirst');
84 $username_noperiod = $conf->exists('username-noperiod');
85 $username_nounderscore = $conf->exists('username-nounderscore');
86 $username_nodash = $conf->exists('username-nodash');
87 $username_uppercase = $conf->exists('username-uppercase');
88 $username_ampersand = $conf->exists('username-ampersand');
89 $username_percent = $conf->exists('username-percent');
90 $username_colon = $conf->exists('username-colon');
91 $username_slash = $conf->exists('username-slash');
92 $username_equals = $conf->exists('username-equals');
93 $username_pound = $conf->exists('username-pound');
94 $username_exclamation = $conf->exists('username-exclamation');
95 $password_noampersand = $conf->exists('password-noexclamation');
96 $password_noexclamation = $conf->exists('password-noexclamation');
97 $dirhash = $conf->config('dirhash') || 0;
98 if ( $conf->exists('warning_email') ) {
99 $warning_template = new Text::Template (
101 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
102 ) or warn "can't create warning email template: $Text::Template::ERROR";
103 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
104 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
105 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
106 $warning_cc = $conf->config('warning_email-cc');
108 $warning_template = '';
110 $warning_subject = '';
111 $warning_mimetype = '';
114 $smtpmachine = $conf->config('smtpmachine');
115 $radius_password = $conf->config('radius-password') || 'Password';
116 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
117 @pw_set = FS::svc_acct->pw_set;
121 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
125 my ( $hashref, $cache ) = @_;
126 if ( $hashref->{'svc_acct_svcnum'} ) {
127 $self->{'_domsvc'} = FS::svc_domain->new( {
128 'svcnum' => $hashref->{'domsvc'},
129 'domain' => $hashref->{'svc_acct_domain'},
130 'catchall' => $hashref->{'svc_acct_catchall'},
137 FS::svc_acct - Object methods for svc_acct records
143 $record = new FS::svc_acct \%hash;
144 $record = new FS::svc_acct { 'column' => 'value' };
146 $error = $record->insert;
148 $error = $new_record->replace($old_record);
150 $error = $record->delete;
152 $error = $record->check;
154 $error = $record->suspend;
156 $error = $record->unsuspend;
158 $error = $record->cancel;
160 %hash = $record->radius;
162 %hash = $record->radius_reply;
164 %hash = $record->radius_check;
166 $domain = $record->domain;
168 $svc_domain = $record->svc_domain;
170 $email = $record->email;
172 $seconds_since = $record->seconds_since($timestamp);
176 An FS::svc_acct object represents an account. FS::svc_acct inherits from
177 FS::svc_Common. The following fields are currently supported:
183 Primary key (assigned automatcially for new accounts)
191 =item _password_encoding
193 plain, crypt, ldap (or empty for autodetection)
201 Point of presence (see L<FS::svc_acct_pop>)
213 set automatically if blank (and uid is not)
233 svcnum from svc_domain
237 Optional svcnum from svc_pbx
239 =item radius_I<Radius_Attribute>
241 I<Radius-Attribute> (reply)
243 =item rc_I<Radius_Attribute>
245 I<Radius-Attribute> (check)
255 Creates a new account. To add the account to the database, see L<"insert">.
262 'longname_plural' => 'Access accounts and mailboxes',
263 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
264 'display_weight' => 10,
265 'cancel_weight' => 50,
266 'ip_field' => 'slipip',
267 'manual_require' => 1,
269 'dir' => 'Home directory',
272 def_info => 'set to fixed and blank for no UIDs',
275 'slipip' => 'IP address',
276 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
278 label => 'Access number',
280 select_table => 'svc_acct_pop',
281 select_key => 'popnum',
282 select_label => 'city',
288 disable_default => 1,
293 'password_selfchange' => { label => 'Password modification',
296 'password_recover' => { label => 'Password recovery',
300 label => 'Quota', #Mail storage limit
302 disable_inventory => 1,
305 label => 'File storage limit',
307 disable_inventory => 1,
310 label => 'Number of files limit',
312 disable_inventory => 1,
315 label => 'File size limit',
317 disable_inventory => 1,
319 '_password' => { label => 'Password',
324 def_info => 'when blank, defaults to UID',
329 def_info => 'set to blank for no shell tracking',
331 #select_list => [ $conf->config('shells') ],
332 select_list => [ $conf ? $conf->config('shells') : () ],
333 disable_inventory => 1,
336 'finger' => 'Real name', # (GECOS)',
341 select_table => 'svc_domain',
342 select_key => 'svcnum',
343 select_label => 'domain',
344 disable_inventory => 1,
347 'pbxsvc' => { label => 'PBX',
348 type => 'select-svc_pbx.html',
349 disable_inventory => 1,
350 disable_select => 1, #UI wonky, pry works otherwise
352 'sectornum' => 'Tower sector',
353 'routernum' => 'Router/block',
355 'label' => 'Address block',
357 'select_table' => 'addr_block',
358 'select_key' => 'blocknum',
359 'select_label' => 'cidr',
360 'disable_inventory' => 1,
363 label => 'RADIUS groups',
364 type => 'select-radius_group.html',
365 disable_inventory => 1,
369 'seconds' => { label => 'Seconds',
370 label_sort => 'with Time Remaining',
372 disable_inventory => 1,
374 disable_part_svc_column => 1,
376 'upbytes' => { label => 'Upload',
378 disable_inventory => 1,
380 'format' => \&FS::UI::bytecount::display_bytecount,
381 'parse' => \&FS::UI::bytecount::parse_bytecount,
382 disable_part_svc_column => 1,
384 'downbytes' => { label => 'Download',
386 disable_inventory => 1,
388 'format' => \&FS::UI::bytecount::display_bytecount,
389 'parse' => \&FS::UI::bytecount::parse_bytecount,
390 disable_part_svc_column => 1,
392 'totalbytes'=> { label => 'Total up and download',
394 disable_inventory => 1,
396 'format' => \&FS::UI::bytecount::display_bytecount,
397 'parse' => \&FS::UI::bytecount::parse_bytecount,
398 disable_part_svc_column => 1,
400 'seconds_threshold' => { label => 'Seconds threshold',
402 disable_inventory => 1,
404 disable_part_svc_column => 1,
406 'upbytes_threshold' => { label => 'Upload threshold',
408 disable_inventory => 1,
410 'format' => \&FS::UI::bytecount::display_bytecount,
411 'parse' => \&FS::UI::bytecount::parse_bytecount,
412 disable_part_svc_column => 1,
414 'downbytes_threshold' => { label => 'Download threshold',
416 disable_inventory => 1,
418 'format' => \&FS::UI::bytecount::display_bytecount,
419 'parse' => \&FS::UI::bytecount::parse_bytecount,
420 disable_part_svc_column => 1,
422 'totalbytes_threshold'=> { label => 'Total up and download threshold',
424 disable_inventory => 1,
426 'format' => \&FS::UI::bytecount::display_bytecount,
427 'parse' => \&FS::UI::bytecount::parse_bytecount,
428 disable_part_svc_column => 1,
431 label => 'Last login',
435 label => 'Last logout',
440 label => 'Communigate aliases',
442 disable_inventory => 1,
447 label => 'Communigate account type',
449 select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )],
450 disable_inventory => 1,
453 'cgp_accessmodes' => {
454 label => 'Communigate enabled services',
455 type => 'communigate_pro-accessmodes',
456 disable_inventory => 1,
459 'cgp_rulesallowed' => {
460 label => 'Allowed mail rules',
462 select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ],
463 disable_inventory => 1,
466 'cgp_rpopallowed' => { label => 'RPOP modifications',
469 'cgp_mailtoall' => { label => 'Accepts mail to "all"',
472 'cgp_addmailtrailer' => { label => 'Add trailer to sent mail',
475 'cgp_archiveafter' => {
476 label => 'Archive messages after',
479 -2 => 'default(730 days)',
486 1209600 => '2 weeks',
487 2592000 => '30 days',
488 7776000 => '90 days',
489 15552000 => '180 days',
490 31536000 => '365 days',
491 63072000 => '730 days',
493 disable_inventory => 1,
499 'cgp_deletemode' => {
500 label => 'Communigate message delete method',
502 select_list => [ 'Move To Trash', 'Immediately', 'Mark' ],
503 disable_inventory => 1,
506 'cgp_emptytrash' => {
507 label => 'Communigate on logout remove trash',
509 select_list => __PACKAGE__->cgp_emptytrash_values,
510 disable_inventory => 1,
514 label => 'Communigate language',
516 select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ],
517 disable_inventory => 1,
521 label => 'Communigate time zone',
523 select_list => __PACKAGE__->cgp_timezone_values,
524 disable_inventory => 1,
528 label => 'Communigate layout',
530 select_list => [ '', '***', 'GoldFleece', 'Skin2' ],
531 disable_inventory => 1,
534 'cgp_prontoskinname' => {
535 label => 'Communigate Pronto style',
537 select_list => [ '', 'Pronto', 'Pronto-darkflame', 'Pronto-steel', 'Pronto-twilight', ],
538 disable_inventory => 1,
541 'cgp_sendmdnmode' => {
542 label => 'Communigate send read receipts',
544 select_list => [ '', 'Never', 'Manually', 'Automatically' ],
545 disable_inventory => 1,
556 sub table { 'svc_acct'; }
558 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
561 shift->_lastlog('in', @_);
565 shift->_lastlog('out', @_);
569 my( $self, $op, $time ) = @_;
571 if ( defined($time) ) {
572 warn "$me last_log$op called on svcnum ". $self->svcnum.
573 ' ('. $self->email. "): $time\n"
578 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
582 my $sth = $dbh->prepare( $sql )
583 or die "Error preparing $sql: ". $dbh->errstr;
584 my $rv = $sth->execute($time, $self->svcnum);
585 die "Error executing $sql: ". $sth->errstr
587 die "Can't update last_log$op for svcnum". $self->svcnum
590 $self->{'Hash'}->{"last_log$op"} = $time;
592 $self->getfield("last_log$op");
596 =item search_sql STRING
598 Class method which returns an SQL fragment to search for the given string.
603 my( $class, $string ) = @_;
604 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
605 my( $username, $domain ) = ( $1, $2 );
606 my $q_username = dbh->quote($username);
607 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
609 "svc_acct.username = $q_username AND ( ".
610 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
615 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
617 $class->search_sql_field('slipip', $string ).
619 $class->search_sql_field('username', $string ).
622 $class->search_sql_field('username', $string);
626 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
628 Returns the "username@domain" string for this account.
630 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
640 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
642 Returns a longer string label for this acccount ("Real Name <username@domain>"
643 if available, or "username@domain").
645 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
652 my $label = $self->label(@_);
653 my $finger = $self->finger;
654 return $label unless $finger =~ /\S/;
655 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
656 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
660 =item insert [ , OPTION => VALUE ... ]
662 Adds this account to the database. If there is an error, returns the error,
663 otherwise returns false.
665 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
666 defined. An FS::cust_svc record will be created and inserted.
668 The additional field I<usergroup> can optionally be defined; if so it should
669 contain an arrayref of group names. See L<FS::radius_usergroup>.
671 The additional field I<child_objects> can optionally be defined; if so it
672 should contain an arrayref of FS::tablename objects. They will have their
673 svcnum fields set and will be inserted after this record, but before any
674 exports are run. Each element of the array can also optionally be a
675 two-element array reference containing the child object and the name of an
676 alternate field to be filled in with the newly-inserted svcnum, for example
677 C<[ $svc_forward, 'srcsvc' ]>
679 Currently available options are: I<depend_jobnum>
681 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
682 jobnums), all provisioning jobs will have a dependancy on the supplied
683 jobnum(s) (they will not run until the specific job(s) complete(s)).
685 (TODOC: L<FS::queue> and L<freeside-queued>)
687 (TODOC: new exports!)
696 warn "[$me] insert called on $self: ". Dumper($self).
697 "\nwith options: ". Dumper(%options);
700 local $SIG{HUP} = 'IGNORE';
701 local $SIG{INT} = 'IGNORE';
702 local $SIG{QUIT} = 'IGNORE';
703 local $SIG{TERM} = 'IGNORE';
704 local $SIG{TSTP} = 'IGNORE';
705 local $SIG{PIPE} = 'IGNORE';
707 my $oldAutoCommit = $FS::UID::AutoCommit;
708 local $FS::UID::AutoCommit = 0;
712 my $error = $self->SUPER::insert( # usergroup is here
713 'jobnums' => \@jobnums,
714 'child_objects' => $self->child_objects,
718 $error ||= $self->insert_password_history;
721 $dbh->rollback if $oldAutoCommit;
725 unless ( $skip_fuzzyfiles ) {
726 $error = $self->queue_fuzzyfiles_update;
728 $dbh->rollback if $oldAutoCommit;
729 return "updating fuzzy search cache: $error";
733 my $cust_pkg = $self->cust_svc->cust_pkg;
736 my $cust_main = $cust_pkg->cust_main;
737 my $agentnum = $cust_main->agentnum;
739 if ( $conf->exists('emailinvoiceautoalways')
740 || $conf->exists('emailinvoiceauto')
741 && ! $cust_main->invoicing_list_emailonly
743 my @invoicing_list = $cust_main->invoicing_list;
744 push @invoicing_list, $self->email;
745 $cust_main->invoicing_list(\@invoicing_list);
749 my @welcome_exclude_svcparts = $conf->config('svc_acct_welcome_exclude');
750 unless ($FS::svc_Common::noexport_hack or ( grep { $_ eq $self->svcpart } @welcome_exclude_svcparts )) {
752 my $msgnum = $conf->config('welcome_msgnum', $agentnum);
754 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
755 $error = $msg_template->send('cust_main' => $cust_main,
759 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
760 = ('','','','','','');
762 if ( $conf->exists('welcome_email', $agentnum) ) {
763 $welcome_template = new Text::Template (
765 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
766 ) or warn "can't create welcome email template: $Text::Template::ERROR";
767 $welcome_from = $conf->config('welcome_email-from', $agentnum);
768 # || 'your-isp-is-dum'
769 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
771 $welcome_subject_template = new Text::Template (
773 SOURCE => $welcome_subject,
774 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
775 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
778 if ( $welcome_template ) {
779 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
783 'custnum' => $self->custnum,
784 'username' => $self->username,
785 'password' => $self->_password,
786 'first' => $cust_main->first,
787 'last' => $cust_main->getfield('last'),
788 'pkg' => $cust_pkg->part_pkg->pkg,
790 my $wqueue = new FS::queue {
791 'svcnum' => $self->svcnum,
792 'job' => 'FS::svc_acct::send_email'
794 my $error = $wqueue->insert(
796 'from' => $welcome_from,
797 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
798 'mimetype' => $welcome_mimetype,
799 'body' => $welcome_template->fill_in( HASH => \%hash, ),
802 $dbh->rollback if $oldAutoCommit;
803 return "error queuing welcome email: $error";
806 if ( $options{'depend_jobnum'} ) {
807 warn "$me depend_jobnum found; adding to welcome email dependancies"
809 if ( ref($options{'depend_jobnum'}) ) {
810 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
811 "to welcome email dependancies"
813 push @jobnums, @{ $options{'depend_jobnum'} };
815 warn "$me adding job $options{'depend_jobnum'} ".
816 "to welcome email dependancies"
818 push @jobnums, $options{'depend_jobnum'};
822 foreach my $jobnum ( @jobnums ) {
823 my $error = $wqueue->depend_insert($jobnum);
825 $dbh->rollback if $oldAutoCommit;
826 return "error queuing welcome email job dependancy: $error";
832 } # if $welcome_template
837 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
841 # set usage fields and thresholds if unset but set in a package def
842 # AND the package already has a last bill date (otherwise they get double added)
843 sub preinsert_hook_first {
846 return '' unless $self->pkgnum;
848 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
849 return '' unless $cust_pkg && $cust_pkg->last_bill;
851 my $part_pkg = $cust_pkg->part_pkg;
852 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
854 my %values = $part_pkg->usage_valuehash;
855 my $multiplier = $conf->exists('svc_acct-usage_threshold')
856 ? 1 - $conf->config('svc_acct-usage_threshold')/100
857 : 0.20; #doesn't matter
859 foreach ( keys %values ) {
860 next if $self->getfield($_);
861 $self->setfield( $_, $values{$_} );
862 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
863 if $conf->exists('svc_acct-usage_threshold');
871 Deletes this account from the database. If there is an error, returns the
872 error, otherwise returns false.
874 The corresponding FS::cust_svc record will be deleted as well.
876 (TODOC: new exports!)
883 return "can't delete system account" if $self->_check_system;
885 return "Can't delete an account which is a (svc_forward) source!"
886 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
888 return "Can't delete an account which is a (svc_forward) destination!"
889 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
891 return "Can't delete an account with (svc_www) web service!"
892 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
894 # what about records in session ? (they should refer to history table)
896 local $SIG{HUP} = 'IGNORE';
897 local $SIG{INT} = 'IGNORE';
898 local $SIG{QUIT} = 'IGNORE';
899 local $SIG{TERM} = 'IGNORE';
900 local $SIG{TSTP} = 'IGNORE';
901 local $SIG{PIPE} = 'IGNORE';
903 my $oldAutoCommit = $FS::UID::AutoCommit;
904 local $FS::UID::AutoCommit = 0;
907 foreach my $cust_main_invoice (
908 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
910 unless ( defined($cust_main_invoice) ) {
911 warn "WARNING: something's wrong with qsearch";
914 my %hash = $cust_main_invoice->hash;
915 $hash{'dest'} = $self->email;
916 my $new = new FS::cust_main_invoice \%hash;
917 my $error = $new->replace($cust_main_invoice);
919 $dbh->rollback if $oldAutoCommit;
924 foreach my $svc_domain (
925 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
927 my %hash = new FS::svc_domain->hash;
928 $hash{'catchall'} = '';
929 my $new = new FS::svc_domain \%hash;
930 my $error = $new->replace($svc_domain);
932 $dbh->rollback if $oldAutoCommit;
937 foreach my $svc_phone (
938 qsearch( 'svc_phone', { 'forward_svcnum' => $self->svcnum })
940 $svc_phone->set('forward_svcnum', '');
941 my $error = $svc_phone->replace;
943 $dbh->rollback if $oldAutoCommit;
948 my $error = $self->delete_password_history
949 || $self->SUPER::delete; # usergroup here
951 $dbh->rollback if $oldAutoCommit;
955 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
959 =item replace OLD_RECORD
961 Replaces OLD_RECORD with this one in the database. If there is an error,
962 returns the error, otherwise returns false.
964 The additional field I<usergroup> can optionally be defined; if so it should
965 contain an arrayref of group names. See L<FS::radius_usergroup>.
973 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
977 warn "$me replacing $old with $new\n" if $DEBUG;
981 return "can't modify system account" if $old->_check_system;
984 #no warnings 'numeric'; #alas, a 5.006-ism
987 foreach my $xid (qw( uid gid )) {
989 return "Can't change $xid!"
990 if ! $conf->exists("svc_acct-edit_$xid")
991 && $old->$xid() != $new->$xid()
992 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
997 return "can't change username"
998 if $old->username ne $new->username
999 && $conf->exists('svc_acct-no_edit_username');
1001 #change homdir when we change username
1002 $new->setfield('dir', '') if $old->username ne $new->username;
1004 local $SIG{HUP} = 'IGNORE';
1005 local $SIG{INT} = 'IGNORE';
1006 local $SIG{QUIT} = 'IGNORE';
1007 local $SIG{TERM} = 'IGNORE';
1008 local $SIG{TSTP} = 'IGNORE';
1009 local $SIG{PIPE} = 'IGNORE';
1011 my $oldAutoCommit = $FS::UID::AutoCommit;
1012 local $FS::UID::AutoCommit = 0;
1015 $error = $new->SUPER::replace($old, @_); # usergroup here
1017 # don't need to record this unless the password was changed
1018 if ( $old->_password ne $new->_password ) {
1019 $error ||= $new->insert_password_history;
1023 $dbh->rollback if $oldAutoCommit;
1024 return $error if $error;
1027 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1028 $error = $new->queue_fuzzyfiles_update;
1030 $dbh->rollback if $oldAutoCommit;
1031 return "updating fuzzy search cache: $error";
1035 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1039 =item queue_fuzzyfiles_update
1041 Used by insert & replace to update the fuzzy search cache
1045 sub queue_fuzzyfiles_update {
1048 local $SIG{HUP} = 'IGNORE';
1049 local $SIG{INT} = 'IGNORE';
1050 local $SIG{QUIT} = 'IGNORE';
1051 local $SIG{TERM} = 'IGNORE';
1052 local $SIG{TSTP} = 'IGNORE';
1053 local $SIG{PIPE} = 'IGNORE';
1055 my $oldAutoCommit = $FS::UID::AutoCommit;
1056 local $FS::UID::AutoCommit = 0;
1059 my $queue = new FS::queue {
1060 'svcnum' => $self->svcnum,
1061 'job' => 'FS::svc_acct::append_fuzzyfiles'
1063 my $error = $queue->insert($self->username);
1065 $dbh->rollback if $oldAutoCommit;
1066 return "queueing job (transaction rolled back): $error";
1069 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1077 Suspends this account by calling export-specific suspend hooks. If there is
1078 an error, returns the error, otherwise returns false.
1080 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1086 return "can't suspend system account" if $self->_check_system;
1087 $self->SUPER::suspend(@_);
1092 Unsuspends this account by by calling export-specific suspend hooks. If there
1093 is an error, returns the error, otherwise returns false.
1095 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1101 my %hash = $self->hash;
1102 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1103 $hash{_password} = $1;
1104 my $new = new FS::svc_acct ( \%hash );
1105 my $error = $new->replace($self);
1106 return $error if $error;
1109 $self->SUPER::unsuspend(@_);
1114 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1116 If the B<auto_unset_catchall> configuration option is set, this method will
1117 automatically remove any references to the canceled service in the catchall
1118 field of svc_domain. This allows packages that contain both a svc_domain and
1119 its catchall svc_acct to be canceled in one step.
1124 # Only one thing to do at this level
1126 foreach my $svc_domain (
1127 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1128 if($conf->exists('auto_unset_catchall')) {
1129 my %hash = $svc_domain->hash;
1130 $hash{catchall} = '';
1131 my $new = new FS::svc_domain ( \%hash );
1132 my $error = $new->replace($svc_domain);
1133 return $error if $error;
1135 return "cannot unprovision svc_acct #".$self->svcnum.
1136 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1140 $self->SUPER::cancel(@_);
1146 Checks all fields to make sure this is a valid service. If there is an error,
1147 returns the error, otherwise returns false. Called by the insert and replace
1150 Sets any fixed values; see L<FS::part_svc>.
1157 my($recref) = $self->hashref;
1159 my $x = $self->setfixed;
1160 return $x unless ref($x);
1163 my $error = $self->ut_numbern('svcnum')
1164 #|| $self->ut_number('domsvc')
1165 || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1166 || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx', 'svcnum' )
1167 || $self->ut_foreign_keyn('sectornum','tower_sector','sectornum')
1168 || $self->ut_foreign_keyn('routernum','router','routernum')
1169 || $self->ut_foreign_keyn('blocknum','addr_block','blocknum')
1170 || $self->ut_textn('sec_phrase')
1171 || $self->ut_snumbern('seconds')
1172 || $self->ut_snumbern('upbytes')
1173 || $self->ut_snumbern('downbytes')
1174 || $self->ut_snumbern('totalbytes')
1175 || $self->ut_snumbern('seconds_threshold')
1176 || $self->ut_snumbern('upbytes_threshold')
1177 || $self->ut_snumbern('downbytes_threshold')
1178 || $self->ut_snumbern('totalbytes_threshold')
1179 || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1180 || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1181 || $self->ut_enum('password_recover', [ '', 'Y' ])
1183 || $self->ut_anything('cf_privatekey')
1185 || $self->ut_textn('cgp_accessmodes')
1186 || $self->ut_alphan('cgp_type')
1187 || $self->ut_textn('cgp_aliases' ) #well
1189 || $self->ut_alphasn('cgp_rulesallowed')
1190 || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1191 || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1192 || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1193 || $self->ut_snumbern('cgp_archiveafter')
1195 || $self->ut_alphasn('cgp_deletemode')
1196 || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1197 || $self->ut_alphan('cgp_language')
1198 || $self->ut_textn('cgp_timezone')
1199 || $self->ut_textn('cgp_skinname')
1200 || $self->ut_textn('cgp_prontoskinname')
1201 || $self->ut_alphan('cgp_sendmdnmode')
1203 return $error if $error;
1205 # assign IP address, etc.
1206 if ( $conf->exists('svc_acct-ip_addr') ) {
1207 my $error = $self->svc_ip_check;
1208 return $error if $error;
1209 } else { # I think this is correct
1210 $self->routernum('');
1211 $self->blocknum('');
1215 local $username_letter = $username_letter;
1216 local $username_uppercase = $username_uppercase;
1217 if ($self->svcnum) {
1218 my $cust_svc = $self->cust_svc
1219 or return "no cust_svc record found for svcnum ". $self->svcnum;
1220 my $cust_pkg = $cust_svc->cust_pkg;
1222 if ($self->pkgnum) {
1223 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1227 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1228 $username_uppercase =
1229 $conf->exists('username-uppercase', $cust_pkg->cust_main->agentnum);
1232 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1234 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#\!]{$usernamemin,$ulen})$/i
1235 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1236 $recref->{username} = $1;
1238 my $uerror = gettext('illegal_username'). ': '. $recref->{username};
1240 unless ( $username_uppercase ) {
1241 $recref->{username} =~ /[A-Z]/ and return $uerror;
1243 if ( $username_letterfirst ) {
1244 $recref->{username} =~ /^[a-z]/ or return $uerror;
1245 } elsif ( $username_letter ) {
1246 $recref->{username} =~ /[a-z]/ or return $uerror;
1248 if ( $username_noperiod ) {
1249 $recref->{username} =~ /\./ and return $uerror;
1251 if ( $username_nounderscore ) {
1252 $recref->{username} =~ /_/ and return $uerror;
1254 if ( $username_nodash ) {
1255 $recref->{username} =~ /\-/ and return $uerror;
1257 unless ( $username_ampersand ) {
1258 $recref->{username} =~ /\&/ and return $uerror;
1260 unless ( $username_percent ) {
1261 $recref->{username} =~ /\%/ and return $uerror;
1263 unless ( $username_colon ) {
1264 $recref->{username} =~ /\:/ and return $uerror;
1266 unless ( $username_slash ) {
1267 $recref->{username} =~ /\// and return $uerror;
1269 unless ( $username_equals ) {
1270 $recref->{username} =~ /\=/ and return $uerror;
1272 unless ( $username_pound ) {
1273 $recref->{username} =~ /\#/ and return $uerror;
1275 unless ( $username_exclamation ) {
1276 $recref->{username} =~ /\!/ and return $uerror;
1280 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1281 $recref->{popnum} = $1;
1282 return "Unknown popnum" unless
1283 ! $recref->{popnum} ||
1284 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1286 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1288 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1289 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1291 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1292 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1293 #not all systems use gid=uid
1294 #you can set a fixed gid in part_svc
1296 return "Only root can have uid 0"
1297 if $recref->{uid} == 0
1298 && $recref->{username} !~ /^(root|toor|smtp)$/;
1300 unless ( $recref->{username} eq 'sync' ) {
1301 if ( grep $_ eq $recref->{shell}, @shells ) {
1302 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1304 return "Illegal shell \`". $self->shell. "\'; ".
1305 "shells configuration value contains: @shells";
1308 $recref->{shell} = '/bin/sync';
1312 $recref->{gid} ne '' ?
1313 return "Can't have gid without uid" : ( $recref->{gid}='' );
1314 #$recref->{dir} ne '' ?
1315 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1316 $recref->{shell} ne '' ?
1317 return "Can't have shell without uid" : ( $recref->{shell}='' );
1320 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1322 $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1323 or return "Illegal directory: ". $recref->{dir};
1324 $recref->{dir} = $1;
1325 return "Illegal directory"
1326 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1327 return "Illegal directory"
1328 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1329 unless ( $recref->{dir} ) {
1330 $recref->{dir} = $dir_prefix . '/';
1331 if ( $dirhash > 0 ) {
1332 for my $h ( 1 .. $dirhash ) {
1333 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1335 } elsif ( $dirhash < 0 ) {
1336 for my $h ( reverse $dirhash .. -1 ) {
1337 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1340 $recref->{dir} .= $recref->{username};
1346 if ( $self->getfield('finger') eq '' ) {
1347 my $cust_pkg = $self->svcnum
1348 ? $self->cust_svc->cust_pkg
1349 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1351 my $cust_main = $cust_pkg->cust_main;
1352 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1355 # $error = $self->ut_textn('finger');
1356 # return $error if $error;
1357 $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]*)$/
1358 or return "Illegal finger: ". $self->getfield('finger');
1359 $self->setfield('finger', $1);
1361 for (qw( quota file_quota file_maxsize )) {
1362 $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1365 $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1366 $recref->{file_maxnum} = $1;
1368 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1369 if ( $recref->{slipip} eq '' ) {
1370 $recref->{slipip} = ''; # eh?
1371 } elsif ( $recref->{slipip} eq '0e0' ) {
1372 $recref->{slipip} = '0e0';
1374 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1375 or return "Illegal slipip: ". $self->slipip;
1376 $recref->{slipip} = $1;
1380 #arbitrary RADIUS stuff; allow ut_textn for now
1381 foreach ( grep /^radius_/, fields('svc_acct') ) {
1382 $self->ut_textn($_);
1385 # First, if _password is blank, generate one and set default encoding.
1386 if ( ! $recref->{_password} ) {
1387 $error = $self->set_password('');
1389 # But if there's a _password but no encoding, assume it's plaintext and
1390 # set it to default encoding.
1391 elsif ( ! $recref->{_password_encoding} ) {
1392 $error = $self->set_password($recref->{_password});
1394 return $error if $error;
1396 # Next, check _password to ensure compliance with the encoding.
1397 if ( $recref->{_password_encoding} eq 'ldap' ) {
1399 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1400 $recref->{_password} = uc($1).$2;
1402 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1405 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1407 if ( $recref->{_password} =~
1408 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1409 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1412 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1415 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1418 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1419 # Password randomization is now in set_password.
1420 # Strip whitespace characters, check length requirements, etc.
1421 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1422 $recref->{_password} = $1;
1424 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1425 FS::Msgcat::_gettext('illegal_password_characters');
1428 if ( $password_noampersand ) {
1429 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1431 if ( $password_noexclamation ) {
1432 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1436 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1439 $self->SUPER::check;
1444 sub _password_encryption {
1446 my $encoding = lc($self->_password_encoding);
1447 return if !$encoding;
1448 return 'plain' if $encoding eq 'plain';
1449 if($encoding eq 'crypt') {
1450 my $pass = $self->_password;
1451 $pass =~ s/^\*SUSPENDED\* //;
1453 return 'md5' if $pass =~ /^\$1\$/;
1454 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1455 return 'des' if length($pass) == 13;
1458 if($encoding eq 'ldap') {
1459 uc($self->_password) =~ /^\{([\w-]+)\}/;
1460 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1461 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1462 return 'md5' if $1 eq 'MD5';
1463 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1470 sub get_cleartext_password {
1472 if($self->_password_encryption eq 'plain') {
1473 if($self->_password_encoding eq 'ldap') {
1474 $self->_password =~ /\{\w+\}(.*)$/;
1478 return $self->_password;
1487 Set the cleartext password for the account. If _password_encoding is set, the
1488 new password will be encoded according to the existing method (including
1489 encryption mode, if it can be determined). Otherwise,
1490 config('default-password-encoding') is used.
1492 If no password is supplied (or a zero-length password when minimum password length
1493 is >0), one will be generated randomly.
1498 my( $self, $pass ) = ( shift, shift );
1500 warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1503 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1504 FS::Msgcat::_gettext('illegal_password_characters').
1507 my( $encoding, $encryption ) = ('', '');
1509 if ( $self->_password_encoding ) {
1510 $encoding = $self->_password_encoding;
1511 # identify existing encryption method, try to use it.
1512 $encryption = $self->_password_encryption;
1514 # use the system default
1520 # set encoding to system default
1521 ($encoding, $encryption) =
1522 split(/-/, lc($conf->config('default-password-encoding') || ''));
1523 $encoding ||= 'legacy';
1524 $self->_password_encoding($encoding);
1527 if ( $encoding eq 'legacy' ) {
1529 # The legacy behavior from check():
1530 # If the password is blank, randomize it and set encoding to 'plain'.
1531 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1532 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1533 $self->_password_encoding('plain');
1535 # Prefix + valid-length password
1536 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1538 $self->_password_encoding('plain');
1539 # Prefix + crypt string
1540 } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1542 $self->_password_encoding('crypt');
1543 # Various disabled crypt passwords
1544 } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1545 $self->_password_encoding('crypt');
1551 $self->_password($pass);
1557 if $passwordmin && length($pass) < $passwordmin
1558 or $passwordmax && length($pass) > $passwordmax;
1560 if ( $encoding eq 'crypt' ) {
1561 if ($encryption eq 'md5') {
1562 $pass = unix_md5_crypt($pass);
1563 } elsif ($encryption eq 'des') {
1564 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1567 } elsif ( $encoding eq 'ldap' ) {
1568 if ($encryption eq 'md5') {
1569 $pass = md5_base64($pass);
1570 } elsif ($encryption eq 'sha1') {
1571 $pass = sha1_base64($pass);
1572 } elsif ($encryption eq 'crypt') {
1573 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1575 # else $encryption eq 'plain', do nothing
1576 $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1577 if $encryption eq 'md5' || $encryption eq 'sha1';
1578 $pass = '{'.uc($encryption).'}'.$pass;
1580 # else encoding eq 'plain'
1582 $self->_password($pass);
1588 Internal function to check the username against the list of system usernames
1589 from the I<system_usernames> configuration value. Returns true if the username
1590 is listed on the system username list.
1596 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1597 $conf->config('system_usernames')
1601 =item _check_duplicate
1603 Internal method to check for duplicates usernames, username@domain pairs and
1606 If the I<global_unique-username> configuration value is set to B<username> or
1607 B<username@domain>, enforces global username or username@domain uniqueness.
1609 In all cases, check for duplicate uids and usernames or username@domain pairs
1610 per export and with identical I<svcpart> values.
1614 sub _check_duplicate {
1617 my $global_unique = $conf->config('global_unique-username') || 'none';
1618 return '' if $global_unique eq 'disabled';
1622 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1623 unless ( $part_svc ) {
1624 return 'unknown svcpart '. $self->svcpart;
1627 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1628 qsearch( 'svc_acct', { 'username' => $self->username } );
1629 return gettext('username_in_use')
1630 if $global_unique eq 'username' && @dup_user;
1632 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1633 qsearch( 'svc_acct', { 'username' => $self->username,
1634 'domsvc' => $self->domsvc } );
1635 return gettext('username_in_use')
1636 if $global_unique eq 'username@domain' && @dup_userdomain;
1639 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1640 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1641 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1642 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1647 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1648 my $exports = FS::part_export::export_info('svc_acct');
1649 my %conflict_user_svcpart;
1650 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1652 foreach my $part_export ( $part_svc->part_export ) {
1654 #this will catch to the same exact export
1655 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1657 #this will catch to exports w/same exporthost+type ???
1658 #my @other_part_export = qsearch('part_export', {
1659 # 'machine' => $part_export->machine,
1660 # 'exporttype' => $part_export->exporttype,
1662 #foreach my $other_part_export ( @other_part_export ) {
1663 # push @svcparts, map { $_->svcpart }
1664 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1667 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1668 #silly kludge to avoid uninitialized value errors
1669 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1670 ? $exports->{$part_export->exporttype}{'nodomain'}
1672 if ( $nodomain =~ /^Y/i ) {
1673 $conflict_user_svcpart{$_} = $part_export->exportnum
1676 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1681 foreach my $dup_user ( @dup_user ) {
1682 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1683 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1684 return "duplicate username ". $self->username.
1685 ": conflicts with svcnum ". $dup_user->svcnum.
1686 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1690 foreach my $dup_userdomain ( @dup_userdomain ) {
1691 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1692 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1693 return "duplicate username\@domain ". $self->email.
1694 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1695 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1699 foreach my $dup_uid ( @dup_uid ) {
1700 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1701 if ( exists($conflict_user_svcpart{$dup_svcpart})
1702 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1703 return "duplicate uid ". $self->uid.
1704 ": conflicts with svcnum ". $dup_uid->svcnum.
1706 ( $conflict_user_svcpart{$dup_svcpart}
1707 || $conflict_userdomain_svcpart{$dup_svcpart} );
1719 Depriciated, use radius_reply instead.
1724 carp "FS::svc_acct::radius depriciated, use radius_reply";
1725 $_[0]->radius_reply;
1730 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1731 reply attributes of this record.
1733 Note that this is now the preferred method for reading RADIUS attributes -
1734 accessing the columns directly is discouraged, as the column names are
1735 expected to change in the future.
1742 return %{ $self->{'radius_reply'} }
1743 if exists $self->{'radius_reply'};
1748 my($column, $attrib) = ($1, $2);
1749 #$attrib =~ s/_/\-/g;
1750 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1751 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1753 if ( $self->slipip && $self->slipip ne '0e0' ) {
1754 $reply{$radius_ip} = $self->slipip;
1757 if ( $self->seconds !~ /^$/ ) {
1758 $reply{'Session-Timeout'} = $self->seconds;
1761 if ( $conf->exists('radius-chillispot-max') ) {
1762 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1764 #hmm. just because sqlradius.pm says so?
1771 foreach my $what (qw( input output total )) {
1772 my $is = $whatis{$what}.'bytes';
1773 if ( $self->$is() =~ /\d/ ) {
1774 my $big = new Math::BigInt $self->$is();
1775 $big = new Math::BigInt '0' if $big->is_neg();
1776 my $att = "Chillispot-Max-\u$what";
1777 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1778 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1789 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1790 check attributes of this record.
1792 Note that this is now the preferred method for reading RADIUS attributes -
1793 accessing the columns directly is discouraged, as the column names are
1794 expected to change in the future.
1801 return %{ $self->{'radius_check'} }
1802 if exists $self->{'radius_check'};
1807 my($column, $attrib) = ($1, $2);
1808 #$attrib =~ s/_/\-/g;
1809 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1810 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1813 my($pw_attrib, $password) = $self->radius_password;
1814 $check{$pw_attrib} = $password;
1816 my $cust_svc = $self->cust_svc;
1818 my $cust_pkg = $cust_svc->cust_pkg;
1819 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1820 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1823 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1824 "; can't set Expiration\n"
1832 =item radius_password
1834 Returns a key/value pair containing the RADIUS attribute name and value
1839 sub radius_password {
1843 if ( $self->_password_encoding eq 'ldap' ) {
1844 $pw_attrib = 'Password-With-Header';
1845 } elsif ( $self->_password_encoding eq 'crypt' ) {
1846 $pw_attrib = 'Crypt-Password';
1847 } elsif ( $self->_password_encoding eq 'plain' ) {
1848 $pw_attrib = $radius_password;
1850 $pw_attrib = length($self->_password) <= 12
1855 ($pw_attrib, $self->_password);
1861 This method instructs the object to "snapshot" or freeze RADIUS check and
1862 reply attributes to the current values.
1866 #bah, my english is too broken this morning
1867 #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
1868 #the FS::cust_pkg's replace method to trigger the correct export updates when
1869 #package dates change)
1874 $self->{$_} = { $self->$_() }
1875 foreach qw( radius_reply radius_check );
1879 =item forget_snapshot
1881 This methos instructs the object to forget any previously snapshotted
1882 RADIUS check and reply attributes.
1886 sub forget_snapshot {
1890 foreach qw( radius_reply radius_check );
1894 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1896 Returns the domain associated with this account.
1898 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1905 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1906 my $svc_domain = $self->svc_domain(@_)
1907 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1908 $svc_domain->domain;
1913 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1917 #inherited from svc_Common
1919 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1921 Returns an email address associated with the account.
1923 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1930 $self->username. '@'. $self->domain(@_);
1936 Returns an array of FS::acct_snarf records associated with the account.
1940 # unused as originally intended, but now by Communigate Pro "RPOP"
1944 'table' => 'acct_snarf',
1945 'hashref' => { 'svcnum' => $self->svcnum },
1946 #'order_by' => 'ORDER BY priority ASC',
1950 =item cgp_rpop_hashref
1952 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1956 sub cgp_rpop_hashref {
1958 { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1961 =item decrement_upbytes OCTETS
1963 Decrements the I<upbytes> field of this record by the given amount. If there
1964 is an error, returns the error, otherwise returns false.
1968 sub decrement_upbytes {
1969 shift->_op_usage('-', 'upbytes', @_);
1972 =item increment_upbytes OCTETS
1974 Increments the I<upbytes> field of this record by the given amount. If there
1975 is an error, returns the error, otherwise returns false.
1979 sub increment_upbytes {
1980 shift->_op_usage('+', 'upbytes', @_);
1983 =item decrement_downbytes OCTETS
1985 Decrements the I<downbytes> field of this record by the given amount. If there
1986 is an error, returns the error, otherwise returns false.
1990 sub decrement_downbytes {
1991 shift->_op_usage('-', 'downbytes', @_);
1994 =item increment_downbytes OCTETS
1996 Increments the I<downbytes> field of this record by the given amount. If there
1997 is an error, returns the error, otherwise returns false.
2001 sub increment_downbytes {
2002 shift->_op_usage('+', 'downbytes', @_);
2005 =item decrement_totalbytes OCTETS
2007 Decrements the I<totalbytes> field of this record by the given amount. If there
2008 is an error, returns the error, otherwise returns false.
2012 sub decrement_totalbytes {
2013 shift->_op_usage('-', 'totalbytes', @_);
2016 =item increment_totalbytes OCTETS
2018 Increments the I<totalbytes> field of this record by the given amount. If there
2019 is an error, returns the error, otherwise returns false.
2023 sub increment_totalbytes {
2024 shift->_op_usage('+', 'totalbytes', @_);
2027 =item decrement_seconds SECONDS
2029 Decrements the I<seconds> field of this record by the given amount. If there
2030 is an error, returns the error, otherwise returns false.
2034 sub decrement_seconds {
2035 shift->_op_usage('-', 'seconds', @_);
2038 =item increment_seconds SECONDS
2040 Increments the I<seconds> field of this record by the given amount. If there
2041 is an error, returns the error, otherwise returns false.
2045 sub increment_seconds {
2046 shift->_op_usage('+', 'seconds', @_);
2054 my %op2condition = (
2055 '-' => sub { my($self, $column, $amount) = @_;
2056 $self->$column - $amount <= 0;
2058 '+' => sub { my($self, $column, $amount) = @_;
2059 ($self->$column || 0) + $amount > 0;
2062 my %op2warncondition = (
2063 '-' => sub { my($self, $column, $amount) = @_;
2064 my $threshold = $column . '_threshold';
2065 $self->$column - $amount <= $self->$threshold + 0;
2067 '+' => sub { my($self, $column, $amount) = @_;
2068 ($self->$column || 0) + $amount > 0;
2073 my( $self, $op, $column, $amount ) = @_;
2075 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2076 ' ('. $self->email. "): $op $amount\n"
2079 return '' unless $amount;
2081 local $SIG{HUP} = 'IGNORE';
2082 local $SIG{INT} = 'IGNORE';
2083 local $SIG{QUIT} = 'IGNORE';
2084 local $SIG{TERM} = 'IGNORE';
2085 local $SIG{TSTP} = 'IGNORE';
2086 local $SIG{PIPE} = 'IGNORE';
2088 my $oldAutoCommit = $FS::UID::AutoCommit;
2089 local $FS::UID::AutoCommit = 0;
2092 my $sql = "UPDATE svc_acct SET $column = ".
2093 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2094 " $op ? WHERE svcnum = ?";
2098 my $sth = $dbh->prepare( $sql )
2099 or die "Error preparing $sql: ". $dbh->errstr;
2100 my $rv = $sth->execute($amount, $self->svcnum);
2101 die "Error executing $sql: ". $sth->errstr
2102 unless defined($rv);
2103 die "Can't update $column for svcnum". $self->svcnum
2106 #$self->snapshot; #not necessary, we retain the old values
2107 #create an object with the updated usage values
2108 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2110 my $error = $new->replace($self);
2112 $dbh->rollback if $oldAutoCommit;
2113 return "Error replacing: $error";
2116 #overlimit_action eq 'cancel' handling
2117 my $cust_pkg = $self->cust_svc->cust_pkg;
2119 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2120 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2124 my $error = $cust_pkg->cancel; #XXX should have a reason
2126 $dbh->rollback if $oldAutoCommit;
2127 return "Error cancelling: $error";
2130 #nothing else is relevant if we're cancelling, so commit & return success
2131 warn "$me update successful; committing\n"
2133 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2138 my $action = $op2action{$op};
2140 if ( &{$op2condition{$op}}($self, $column, $amount) &&
2141 ( $action eq 'suspend' && !$self->overlimit
2142 || $action eq 'unsuspend' && $self->overlimit )
2145 my $error = $self->_op_overlimit($action);
2147 $dbh->rollback if $oldAutoCommit;
2153 if ( $conf->exists("svc_acct-usage_$action")
2154 && &{$op2condition{$op}}($self, $column, $amount) ) {
2155 #my $error = $self->$action();
2156 my $error = $self->cust_svc->cust_pkg->$action();
2157 # $error ||= $self->overlimit($action);
2159 $dbh->rollback if $oldAutoCommit;
2160 return "Error ${action}ing: $error";
2164 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2165 my $wqueue = new FS::queue {
2166 'svcnum' => $self->svcnum,
2167 'job' => 'FS::svc_acct::reached_threshold',
2172 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2176 my $error = $wqueue->insert(
2177 'svcnum' => $self->svcnum,
2179 'column' => $column,
2183 $dbh->rollback if $oldAutoCommit;
2184 return "Error queuing threshold activity: $error";
2188 warn "$me update successful; committing\n"
2190 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2196 my( $self, $action ) = @_;
2198 local $SIG{HUP} = 'IGNORE';
2199 local $SIG{INT} = 'IGNORE';
2200 local $SIG{QUIT} = 'IGNORE';
2201 local $SIG{TERM} = 'IGNORE';
2202 local $SIG{TSTP} = 'IGNORE';
2203 local $SIG{PIPE} = 'IGNORE';
2205 my $oldAutoCommit = $FS::UID::AutoCommit;
2206 local $FS::UID::AutoCommit = 0;
2209 my $cust_pkg = $self->cust_svc->cust_pkg;
2211 my @conf_overlimit =
2213 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2214 : $conf->config('overlimit_groups');
2216 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2218 my @groups = scalar(@conf_overlimit) ? @conf_overlimit
2219 : split(' ',$part_export->option('overlimit_groups'));
2220 next unless scalar(@groups);
2222 my $other = new FS::svc_acct $self->hashref;
2223 $other->usergroup(\@groups);
2226 if ($action eq 'suspend') {
2229 } else { # $action eq 'unsuspend'
2234 my $error = $part_export->export_replace($new, $old)
2235 || $self->overlimit($action);
2238 $dbh->rollback if $oldAutoCommit;
2239 return "Error replacing radius groups: $error";
2244 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2250 my( $self, $valueref, %options ) = @_;
2252 warn "$me set_usage called for svcnum ". $self->svcnum.
2253 ' ('. $self->email. "): ".
2254 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2257 local $SIG{HUP} = 'IGNORE';
2258 local $SIG{INT} = 'IGNORE';
2259 local $SIG{QUIT} = 'IGNORE';
2260 local $SIG{TERM} = 'IGNORE';
2261 local $SIG{TSTP} = 'IGNORE';
2262 local $SIG{PIPE} = 'IGNORE';
2264 local $FS::svc_Common::noexport_hack = 1;
2265 my $oldAutoCommit = $FS::UID::AutoCommit;
2266 local $FS::UID::AutoCommit = 0;
2271 if ( $options{null} ) {
2272 %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2273 qw( seconds upbytes downbytes totalbytes )
2276 foreach my $field (keys %$valueref){
2277 $reset = 1 if $valueref->{$field};
2278 $self->setfield($field, $valueref->{$field});
2279 $self->setfield( $field.'_threshold',
2280 int($self->getfield($field)
2281 * ( $conf->exists('svc_acct-usage_threshold')
2282 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2287 $handyhash{$field} = $self->getfield($field);
2288 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2290 #my $error = $self->replace; #NO! we avoid the call to ->check for
2291 #die $error if $error; #services not explicity changed via the UI
2293 my $sql = "UPDATE svc_acct SET " .
2294 join (',', map { "$_ = ?" } (keys %handyhash) ).
2295 " WHERE svcnum = ". $self->svcnum;
2300 if (scalar(keys %handyhash)) {
2301 my $sth = $dbh->prepare( $sql )
2302 or die "Error preparing $sql: ". $dbh->errstr;
2303 my $rv = $sth->execute(values %handyhash);
2304 die "Error executing $sql: ". $sth->errstr
2305 unless defined($rv);
2306 die "Can't update usage for svcnum ". $self->svcnum
2310 #$self->snapshot; #not necessary, we retain the old values
2311 #create an object with the updated usage values
2312 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2313 local($FS::Record::nowarn_identical) = 1;
2314 my $error = $new->replace($self); #call exports
2316 $dbh->rollback if $oldAutoCommit;
2317 return "Error replacing: $error";
2324 $error = $self->_op_overlimit('unsuspend')
2325 if $self->overlimit;;
2327 $error ||= $self->cust_svc->cust_pkg->unsuspend
2328 if $conf->exists("svc_acct-usage_unsuspend");
2331 $dbh->rollback if $oldAutoCommit;
2332 return "Error unsuspending: $error";
2337 warn "$me update successful; committing\n"
2339 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2345 =item recharge HASHREF
2347 Increments usage columns by the amount specified in HASHREF as
2348 column=>amount pairs.
2353 my ($self, $vhash) = @_;
2356 warn "[$me] recharge called on $self: ". Dumper($self).
2357 "\nwith vhash: ". Dumper($vhash);
2360 my $oldAutoCommit = $FS::UID::AutoCommit;
2361 local $FS::UID::AutoCommit = 0;
2365 foreach my $column (keys %$vhash){
2366 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2370 $dbh->rollback if $oldAutoCommit;
2372 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2377 =item is_rechargeable
2379 Returns true if this svc_account can be "recharged" and false otherwise.
2383 sub is_rechargable {
2385 $self->seconds ne ''
2386 || $self->upbytes ne ''
2387 || $self->downbytes ne ''
2388 || $self->totalbytes ne '';
2391 =item seconds_since TIMESTAMP
2393 Returns the number of seconds this account has been online since TIMESTAMP,
2394 according to the session monitor (see L<FS::Session>).
2396 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2397 L<Time::Local> and L<Date::Parse> for conversion functions.
2401 #note: POD here, implementation in FS::cust_svc
2404 $self->cust_svc->seconds_since(@_);
2407 =item last_login_text
2409 Returns text describing the time of last login.
2413 sub last_login_text {
2415 $self->last_login ? ctime($self->last_login) : 'unknown';
2418 =item psearch_cdrs OPTIONS
2420 Returns a paged search (L<FS::PagedSearch>) for Call Detail Records
2421 associated with this service. For svc_acct, "associated with" means that
2422 either the "src" or the "charged_party" field of the CDR matches either
2423 the "username" field of the service or the username@domain label.
2428 my($self, %options) = @_;
2433 my $did = dbh->quote($self->username);
2434 my $diddomain = dbh->quote($self->label);
2436 my $prefix = $options{'default_prefix'} || ''; #convergent.au '+61'
2437 my $prefixdid = dbh->quote($prefix . $self->username);
2439 my $for_update = $options{'for_update'} ? 'FOR UPDATE' : '';
2441 if ( $options{inbound} ) {
2442 # these will be selected under their DIDs
2443 push @where, "FALSE";
2447 if (!$options{'disable_charged_party'}) {
2449 "charged_party = $did",
2450 "charged_party = $prefixdid",
2451 "charged_party = $diddomain"
2454 if (!$options{'disable_src'}) {
2456 "src = $did AND charged_party IS NULL",
2457 "src = $prefixdid AND charged_party IS NULL",
2458 "src = $diddomain AND charged_party IS NULL"
2461 push @where, '(' . join(' OR ', @orwhere) . ')';
2463 # $options{'status'} = '' is meaningful; for the rest of them it's not
2464 if ( exists $options{'status'} ) {
2465 $hash{'freesidestatus'} = $options{'status'};
2467 if ( $options{'cdrtypenum'} ) {
2468 $hash{'cdrtypenum'} = $options{'cdrtypenum'};
2470 if ( $options{'calltypenum'} ) {
2471 $hash{'calltypenum'} = $options{'calltypenum'};
2473 if ( $options{'begin'} ) {
2474 push @where, 'startdate >= '. $options{'begin'};
2476 if ( $options{'end'} ) {
2477 push @where, 'startdate < '. $options{'end'};
2479 if ( $options{'nonzero'} ) {
2480 push @where, 'duration > 0';
2483 my $extra_sql = join(' AND ', @where);
2486 $extra_sql = " AND ".$extra_sql;
2488 $extra_sql = " WHERE ".$extra_sql;
2494 'hashref' => \%hash,
2495 'extra_sql' => $extra_sql,
2496 'order_by' => "ORDER BY startdate $for_update",
2500 =item get_cdrs (DEPRECATED)
2502 Like psearch_cdrs, but returns all the L<FS::cdr> objects at once, in a
2503 single list. Arguments are the same as for psearch_cdrs.
2509 my $psearch = $self->psearch_cdrs(@_);
2510 qsearch ( $psearch->{query} )
2513 # sub radius_groups has moved to svc_Radius_Mixin
2515 =item clone_suspended
2517 Constructor used by FS::part_export::_export_suspend fallback. Document
2522 sub clone_suspended {
2524 my %hash = $self->hash;
2525 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2526 new FS::svc_acct \%hash;
2529 =item clone_kludge_unsuspend
2531 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2536 sub clone_kludge_unsuspend {
2538 my %hash = $self->hash;
2539 $hash{_password} = '';
2540 new FS::svc_acct \%hash;
2543 =item check_password
2545 Checks the supplied password against the (possibly encrypted) password in the
2546 database. Returns true for a successful authentication, false for no match.
2548 Currently supported encryptions are: classic DES crypt() and MD5
2552 sub check_password {
2553 my($self, $check_password) = @_;
2555 #remove old-style SUSPENDED kludge, they should be allowed to login to
2556 #self-service and pay up
2557 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2559 if ( $self->_password_encoding eq 'ldap' ) {
2561 $password =~ s/^{PLAIN}/{CLEARTEXT}/;
2562 my $auth = from_rfc2307 Authen::Passphrase $password;
2563 return $auth->match($check_password);
2565 } elsif ( $self->_password_encoding eq 'crypt' ) {
2567 my $auth = from_crypt Authen::Passphrase $self->_password;
2568 return $auth->match($check_password);
2570 } elsif ( $self->_password_encoding eq 'plain' ) {
2572 return $check_password eq $password;
2576 #XXX this could be replaced with Authen::Passphrase stuff
2578 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2580 } elsif ( length($password) < 13 ) { #plaintext
2581 $check_password eq $password;
2582 } elsif ( length($password) == 13 ) { #traditional DES crypt
2583 crypt($check_password, $password) eq $password;
2584 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2585 unix_md5_crypt($check_password, $password) eq $password;
2586 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2587 warn "Can't check password: Blowfish encryption not yet supported, ".
2588 "svcnum ". $self->svcnum. "\n";
2591 warn "Can't check password: Unrecognized encryption for svcnum ".
2592 $self->svcnum. "\n";
2600 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2602 Returns an encrypted password, either by passing through an encrypted password
2603 in the database or by encrypting a plaintext password from the database.
2605 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2606 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2607 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2608 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2609 encryption type is only used if the password is not already encrypted in the
2614 sub crypt_password {
2617 if ( $self->_password_encoding eq 'ldap' ) {
2619 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2622 #XXX this could be replaced with Authen::Passphrase stuff
2624 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2625 if ( $encryption eq 'crypt' ) {
2628 $saltset[int(rand(64))].$saltset[int(rand(64))]
2630 } elsif ( $encryption eq 'md5' ) {
2631 return unix_md5_crypt( $self->_password );
2632 } elsif ( $encryption eq 'blowfish' ) {
2633 croak "unknown encryption method $encryption";
2635 croak "unknown encryption method $encryption";
2638 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2642 } elsif ( $self->_password_encoding eq 'crypt' ) {
2644 return $self->_password;
2646 } elsif ( $self->_password_encoding eq 'plain' ) {
2648 #XXX this could be replaced with Authen::Passphrase stuff
2650 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2651 if ( $encryption eq 'crypt' ) {
2654 $saltset[int(rand(64))].$saltset[int(rand(64))]
2656 } elsif ( $encryption eq 'md5' ) {
2657 return unix_md5_crypt( $self->_password );
2658 } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2659 my $pass = sha1_base64( $self->_password );
2660 $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2662 } elsif ( $encryption eq 'blowfish' ) {
2663 croak "unknown encryption method $encryption";
2665 croak "unknown encryption method $encryption";
2670 if ( length($self->_password) == 13
2671 || $self->_password =~ /^\$(1|2a?)\$/
2672 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2678 #XXX this could be replaced with Authen::Passphrase stuff
2680 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2681 if ( $encryption eq 'crypt' ) {
2684 $saltset[int(rand(64))].$saltset[int(rand(64))]
2686 } elsif ( $encryption eq 'md5' ) {
2687 return unix_md5_crypt( $self->_password );
2688 } elsif ( $encryption eq 'blowfish' ) {
2689 croak "unknown encryption method $encryption";
2691 croak "unknown encryption method $encryption";
2700 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2702 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2703 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2704 "{MD5}5426824942db4253f87a1009fd5d2d4".
2706 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2707 to work the same as the B</crypt_password> method.
2713 #eventually should check a "password-encoding" field
2715 if ( $self->_password_encoding eq 'ldap' ) {
2717 return $self->_password;
2719 } elsif ( $self->_password_encoding eq 'crypt' ) {
2721 if ( length($self->_password) == 13 ) { #crypt
2722 return '{CRYPT}'. $self->_password;
2723 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2725 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2726 # die "Blowfish encryption not supported in this context, svcnum ".
2727 # $self->svcnum. "\n";
2729 warn "encryption method not (yet?) supported in LDAP context";
2730 return '{CRYPT}*'; #unsupported, should not auth
2733 } elsif ( $self->_password_encoding eq 'plain' ) {
2735 return '{PLAIN}'. $self->_password;
2737 #return '{CLEARTEXT}'. $self->_password; #?
2741 if ( length($self->_password) == 13 ) { #crypt
2742 return '{CRYPT}'. $self->_password;
2743 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2745 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2746 warn "Blowfish encryption not supported in this context, svcnum ".
2747 $self->svcnum. "\n";
2750 #are these two necessary anymore?
2751 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2752 return '{SSHA}'. $1;
2753 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2754 return '{NS-MTA-MD5}'. $1;
2757 return '{PLAIN}'. $self->_password;
2759 #return '{CLEARTEXT}'. $self->_password; #?
2761 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2762 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2763 #if ( $encryption eq 'crypt' ) {
2764 # return '{CRYPT}'. crypt(
2766 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2768 #} elsif ( $encryption eq 'md5' ) {
2769 # unix_md5_crypt( $self->_password );
2770 #} elsif ( $encryption eq 'blowfish' ) {
2771 # croak "unknown encryption method $encryption";
2773 # croak "unknown encryption method $encryption";
2781 =item domain_slash_username
2783 Returns $domain/$username/
2787 sub domain_slash_username {
2789 $self->domain. '/'. $self->username. '/';
2792 =item virtual_maildir
2794 Returns $domain/maildirs/$username/
2798 sub virtual_maildir {
2800 $self->domain. '/maildirs/'. $self->username. '/';
2803 =item password_svc_check
2805 Override, for L<FS::Password_Mixin>. Not really intended for other use.
2809 sub password_svc_check {
2810 my ($self, $password) = @_;
2811 foreach my $field ( qw(username finger) ) {
2812 foreach my $word (split(/\W+/,$self->get($field))) {
2813 next unless length($word) > 2;
2814 if ($password =~ /$word/i) {
2815 return qq(Password contains account information '$word');
2824 =head1 CLASS METHODS
2828 =item search HASHREF
2830 Class method which returns a qsearch hash expression to search for parameters
2831 specified in HASHREF. Valid parameters are
2845 Arrayref of pkgparts
2851 Arrayref of additional WHERE clauses, will be ANDed together.
2862 my( $class, $params, $from, $where ) = @_;
2864 #these two should probably move to svc_Domain_Mixin ?
2867 if ( $params->{'domain'} ) {
2868 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2869 #preserve previous behavior & bubble up an error if $svc_domain not found?
2870 push @$where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2874 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2875 push @$where, "domsvc = $1";
2880 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2881 push @$where, "popnum = $1";
2885 #and these in svc_Tower_Mixin, or maybe we never should have done svc_acct
2886 # towers (or, as mark thought, never should have done svc_broadband)
2889 my @where_sector = $class->tower_sector_sql($params);
2890 if ( @where_sector ) {
2891 push @$where, @where_sector;
2892 push @$from, ' LEFT JOIN tower_sector USING ( sectornum )';
2905 This is the FS::svc_acct job-queue-able version. It still uses
2906 FS::Misc::send_email under-the-hood.
2913 eval "use FS::Misc qw(send_email)";
2916 $opt{mimetype} ||= 'text/plain';
2917 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2919 my $error = send_email(
2920 'from' => $opt{from},
2922 'subject' => $opt{subject},
2923 'content-type' => $opt{mimetype},
2924 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2926 die $error if $error;
2929 =item check_and_rebuild_fuzzyfiles
2933 sub check_and_rebuild_fuzzyfiles {
2934 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2935 -e "$dir/svc_acct.username"
2936 or &rebuild_fuzzyfiles;
2939 =item rebuild_fuzzyfiles
2943 sub rebuild_fuzzyfiles {
2945 use Fcntl qw(:flock);
2947 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2951 open(USERNAMELOCK,">>$dir/svc_acct.username")
2952 or die "can't open $dir/svc_acct.username: $!";
2953 flock(USERNAMELOCK,LOCK_EX)
2954 or die "can't lock $dir/svc_acct.username: $!";
2956 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2958 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2959 or die "can't open $dir/svc_acct.username.tmp: $!";
2960 print USERNAMECACHE join("\n", @all_username), "\n";
2961 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2963 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2973 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2974 open(USERNAMECACHE,"<$dir/svc_acct.username")
2975 or die "can't open $dir/svc_acct.username: $!";
2976 my @array = map { chomp; $_; } <USERNAMECACHE>;
2977 close USERNAMECACHE;
2981 =item append_fuzzyfiles USERNAME
2985 sub append_fuzzyfiles {
2986 my $username = shift;
2988 &check_and_rebuild_fuzzyfiles;
2990 use Fcntl qw(:flock);
2992 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2994 open(USERNAME,">>$dir/svc_acct.username")
2995 or die "can't open $dir/svc_acct.username: $!";
2996 flock(USERNAME,LOCK_EX)
2997 or die "can't lock $dir/svc_acct.username: $!";
2999 print USERNAME "$username\n";
3001 flock(USERNAME,LOCK_UN)
3002 or die "can't unlock $dir/svc_acct.username: $!";
3009 =item reached_threshold
3011 Performs some activities when svc_acct thresholds (such as number of seconds
3012 remaining) are reached.
3016 sub reached_threshold {
3019 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3020 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3022 if ( $opt{'op'} eq '+' ){
3023 $svc_acct->setfield( $opt{'column'}.'_threshold',
3024 int($svc_acct->getfield($opt{'column'})
3025 * ( $conf->exists('svc_acct-usage_threshold')
3026 ? $conf->config('svc_acct-usage_threshold')/100
3031 my $error = $svc_acct->replace;
3032 die $error if $error;
3033 }elsif ( $opt{'op'} eq '-' ){
3035 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3036 return '' if ($threshold eq '' );
3038 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3039 my $error = $svc_acct->replace;
3040 die $error if $error; # email next time, i guess
3042 if ( $warning_template ) {
3043 eval "use FS::Misc qw(send_email)";
3046 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
3047 my $cust_main = $cust_pkg->cust_main;
3049 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3050 $cust_main->invoicing_list,
3051 ($opt{'to'} ? $opt{'to'} : ())
3054 my $mimetype = $warning_mimetype;
3055 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3057 my $body = $warning_template->fill_in( HASH => {
3058 'custnum' => $cust_main->custnum,
3059 'username' => $svc_acct->username,
3060 'password' => $svc_acct->_password,
3061 'first' => $cust_main->first,
3062 'last' => $cust_main->getfield('last'),
3063 'pkg' => $cust_pkg->part_pkg->pkg,
3064 'column' => $opt{'column'},
3065 'amount' => $opt{'column'} =~/bytes/
3066 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3067 : $svc_acct->getfield($opt{'column'}),
3068 'threshold' => $opt{'column'} =~/bytes/
3069 ? FS::UI::bytecount::display_bytecount($threshold)
3074 my $error = send_email(
3075 'from' => $warning_from,
3077 'subject' => $warning_subject,
3078 'content-type' => $mimetype,
3079 'body' => [ map "$_\n", split("\n", $body) ],
3081 die $error if $error;
3084 die "unknown op: " . $opt{'op'};
3092 The $recref stuff in sub check should be cleaned up.
3094 The suspend, unsuspend and cancel methods update the database, but not the
3095 current object. This is probably a bug as it's unexpected and
3098 insertion of RADIUS group stuff in insert could be done with child_objects now
3099 (would probably clean up export of them too)
3101 _op_usage and set_usage bypass the history... maybe they shouldn't
3105 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3106 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3107 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3108 L<freeside-queued>), L<FS::svc_acct_pop>,
3109 schema.html from the base documentation.