FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
   5              $dir_prefix @shells $usernamemin
   6              $usernamemax $passwordmin $passwordmax
   7              $username_ampersand $username_letter $username_letterfirst
   8              $username_noperiod $username_nounderscore $username_nodash
   9              $username_uppercase $username_percent
  10              $password_noampersand $password_noexclamation
  11              $warning_template $warning_from $warning_subject $warning_mimetype
  12              $warning_cc
  13              $smtpmachine
  14              $radius_password $radius_ip
  15              $dirhash
  16              @saltset @pw_set );
  17 use Carp;
  18 use Fcntl qw(:flock);
  19 use Date::Format;
  20 use Crypt::PasswdMD5 1.2;
  21 use Data::Dumper;
  22 use Authen::Passphrase;
  23 use FS::UID qw( datasrc driver_name );
  24 use FS::Conf;
  25 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  26 use FS::Msgcat qw(gettext);
  27 use FS::UI::bytecount;
  28 use FS::svc_Common;
  29 use FS::cust_svc;
  30 use FS::part_svc;
  31 use FS::svc_acct_pop;
  32 use FS::cust_main_invoice;
  33 use FS::svc_domain;
  34 use FS::raddb;
  35 use FS::queue;
  36 use FS::radius_usergroup;
  37 use FS::export_svc;
  38 use FS::part_export;
  39 use FS::svc_forward;
  40 use FS::svc_www;
  41 use FS::cdr;
  42
  43 @ISA = qw( FS::svc_Common );
  44
  45 $DEBUG = 0;
  46 $me = '[FS::svc_acct]';
  47
  48 #ask FS::UID to run this stuff for us later
  49 $FS::UID::callback{'FS::svc_acct'} = sub {
  50   $conf = new FS::Conf;
  51   $dir_prefix = $conf->config('home');
  52   @shells = $conf->config('shells');
  53   $usernamemin = $conf->config('usernamemin') || 2;
  54   $usernamemax = $conf->config('usernamemax');
  55   $passwordmin = $conf->config('passwordmin') || 6;
  56   $passwordmax = $conf->config('passwordmax') || 8;
  57   $username_letter = $conf->exists('username-letter');
  58   $username_letterfirst = $conf->exists('username-letterfirst');
  59   $username_noperiod = $conf->exists('username-noperiod');
  60   $username_nounderscore = $conf->exists('username-nounderscore');
  61   $username_nodash = $conf->exists('username-nodash');
  62   $username_uppercase = $conf->exists('username-uppercase');
  63   $username_ampersand = $conf->exists('username-ampersand');
  64   $username_percent = $conf->exists('username-percent');
  65   $password_noampersand = $conf->exists('password-noexclamation');
  66   $password_noexclamation = $conf->exists('password-noexclamation');
  67   $dirhash = $conf->config('dirhash') || 0;
  68   if ( $conf->exists('warning_email') ) {
  69     $warning_template = new Text::Template (
  70       TYPE   => 'ARRAY',
  71       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
  72     ) or warn "can't create warning email template: $Text::Template::ERROR";
  73     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
  74     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
  75     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
  76     $warning_cc = $conf->config('warning_email-cc');
  77   } else {
  78     $warning_template = '';
  79     $warning_from = '';
  80     $warning_subject = '';
  81     $warning_mimetype = '';
  82     $warning_cc = '';
  83   }
  84   $smtpmachine = $conf->config('smtpmachine');
  85   $radius_password = $conf->config('radius-password') || 'Password';
  86   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  87   @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
  88 };
  89
  90 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  91 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  92
  93 sub _cache {
  94   my $self = shift;
  95   my ( $hashref, $cache ) = @_;
  96   if ( $hashref->{'svc_acct_svcnum'} ) {
  97     $self->{'_domsvc'} = FS::svc_domain->new( {
  98       'svcnum'   => $hashref->{'domsvc'},
  99       'domain'   => $hashref->{'svc_acct_domain'},
 100       'catchall' => $hashref->{'svc_acct_catchall'},
 101     } );
 102   }
 103 }
 104
 105 =head1 NAME
 106
 107 FS::svc_acct - Object methods for svc_acct records
 108
 109 =head1 SYNOPSIS
 110
 111   use FS::svc_acct;
 112
 113   $record = new FS::svc_acct \%hash;
 114   $record = new FS::svc_acct { 'column' => 'value' };
 115
 116   $error = $record->insert;
 117
 118   $error = $new_record->replace($old_record);
 119
 120   $error = $record->delete;
 121
 122   $error = $record->check;
 123
 124   $error = $record->suspend;
 125
 126   $error = $record->unsuspend;
 127
 128   $error = $record->cancel;
 129
 130   %hash = $record->radius;
 131
 132   %hash = $record->radius_reply;
 133
 134   %hash = $record->radius_check;
 135
 136   $domain = $record->domain;
 137
 138   $svc_domain = $record->svc_domain;
 139
 140   $email = $record->email;
 141
 142   $seconds_since = $record->seconds_since($timestamp);
 143
 144 =head1 DESCRIPTION
 145
 146 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 147 FS::svc_Common.  The following fields are currently supported:
 148
 149 =over 4
 150
 151 =item svcnum - primary key (assigned automatcially for new accounts)
 152
 153 =item username
 154
 155 =item _password - generated if blank
 156
 157 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
 158
 159 =item sec_phrase - security phrase
 160
 161 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 162
 163 =item uid
 164
 165 =item gid
 166
 167 =item finger - GECOS
 168
 169 =item dir - set automatically if blank (and uid is not)
 170
 171 =item shell
 172
 173 =item quota - (unimplementd)
 174
 175 =item slipip - IP address
 176
 177 =item seconds -
 178
 179 =item upbytes -
 180
 181 =item downbytes -
 182
 183 =item totalbytes -
 184
 185 =item domsvc - svcnum from svc_domain
 186
 187 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 188
 189 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 190
 191 =back
 192
 193 =head1 METHODS
 194
 195 =over 4
 196
 197 =item new HASHREF
 198
 199 Creates a new account.  To add the account to the database, see L<"insert">.
 200
 201 =cut
 202
 203 sub table_info {
 204   {
 205     'name'   => 'Account',
 206     'longname_plural' => 'Access accounts and mailboxes',
 207     'sorts' => [ 'username', 'uid', 'seconds' ],
 208     'display_weight' => 10,
 209     'cancel_weight'  => 50,
 210     'fields' => {
 211         'dir'       => 'Home directory',
 212         'uid'       => {
 213                          label     => 'UID',
 214                          def_label => 'UID (set to fixed and blank for no UIDs)',
 215                          type      => 'text',
 216                        },
 217         'slipip'    => 'IP address',
 218     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
 219         'popnum'    => {
 220                          label => 'Access number',
 221                          type => 'select',
 222                          select_table => 'svc_acct_pop',
 223                          select_key   => 'popnum',
 224                          select_label => 'city',
 225                          disable_select => 1,
 226                        },
 227         'username'  => {
 228                          label => 'Username',
 229                          type => 'text',
 230                          disable_default => 1,
 231                          disable_fixed => 1,
 232                          disable_select => 1,
 233                        },
 234         'quota'     => {
 235                          label => 'Quota',
 236                          type => 'text',
 237                          disable_inventory => 1,
 238                          disable_select => 1,
 239                        },
 240         '_password' => 'Password',
 241         'gid'       => {
 242                          label     => 'GID',
 243                          def_label => 'GID (when blank, defaults to UID)',
 244                          type      => 'text',
 245                        },
 246         'shell'     => {
 247                          #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
 248                          label    => 'Shell',
 249                          def_label=> 'Shell (set to blank for no shell tracking)',
 250                          type     =>'select',
 251                          select_list => [ $conf->config('shells') ],
 252                          disable_inventory => 1,
 253                          disable_select => 1,
 254                        },
 255         'finger'    => 'Real name (GECOS)',
 256         'domsvc'    => {
 257                          label     => 'Domain',
 258                          #def_label => 'svcnum from svc_domain',
 259                          type      => 'select',
 260                          select_table => 'svc_domain',
 261                          select_key   => 'svcnum',
 262                          select_label => 'domain',
 263                          disable_inventory => 1,
 264
 265                        },
 266         'usergroup' => {
 267                          label => 'RADIUS groups',
 268                          type  => 'radius_usergroup_selector',
 269                          disable_inventory => 1,
 270                          disable_select => 1,
 271                        },
 272         'seconds'   => { label => 'Seconds',
 273                          label_sort => 'with Time Remaining',
 274                          type  => 'text',
 275                          disable_inventory => 1,
 276                          disable_select => 1,
 277                        },
 278         'upbytes'   => { label => 'Upload',
 279                          type  => 'text',
 280                          disable_inventory => 1,
 281                          disable_select => 1,
 282                          'format' => \&FS::UI::bytecount::display_bytecount,
 283                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 284                        },
 285         'downbytes' => { label => 'Download',
 286                          type  => 'text',
 287                          disable_inventory => 1,
 288                          disable_select => 1,
 289                          'format' => \&FS::UI::bytecount::display_bytecount,
 290                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 291                        },
 292         'totalbytes'=> { label => 'Total up and download',
 293                          type  => 'text',
 294                          disable_inventory => 1,
 295                          disable_select => 1,
 296                          'format' => \&FS::UI::bytecount::display_bytecount,
 297                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 298                        },
 299         'seconds_threshold'   => { label => 'Seconds threshold',
 300                                    type  => 'text',
 301                                    disable_inventory => 1,
 302                                    disable_select => 1,
 303                                  },
 304         'upbytes_threshold'   => { label => 'Upload threshold',
 305                                    type  => 'text',
 306                                    disable_inventory => 1,
 307                                    disable_select => 1,
 308                                    'format' => \&FS::UI::bytecount::display_bytecount,
 309                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 310                                  },
 311         'downbytes_threshold' => { label => 'Download threshold',
 312                                    type  => 'text',
 313                                    disable_inventory => 1,
 314                                    disable_select => 1,
 315                                    'format' => \&FS::UI::bytecount::display_bytecount,
 316                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 317                                  },
 318         'totalbytes_threshold'=> { label => 'Total up and download threshold',
 319                                    type  => 'text',
 320                                    disable_inventory => 1,
 321                                    disable_select => 1,
 322                                    'format' => \&FS::UI::bytecount::display_bytecount,
 323                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 324                                  },
 325     },
 326   };
 327 }
 328
 329 sub table { 'svc_acct'; }
 330
 331 sub _fieldhandlers {
 332   {
 333     #false laziness with edit/svc_acct.cgi
 334     'usergroup' => sub {
 335                          my( $self, $groups ) = @_;
 336                          if ( ref($groups) eq 'ARRAY' ) {
 337                            $groups;
 338                          } elsif ( length($groups) ) {
 339                            [ split(/\s*,\s*/, $groups) ];
 340                          } else {
 341                            [];
 342                          }
 343                        },
 344   };
 345 }
 346
 347 =item search_sql STRING
 348
 349 Class method which returns an SQL fragment to search for the given string.
 350
 351 =cut
 352
 353 sub search_sql {
 354   my( $class, $string ) = @_;
 355   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 356     my( $username, $domain ) = ( $1, $2 );
 357     my $q_username = dbh->quote($username);
 358     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 359     if ( @svc_domain ) {
 360       "svc_acct.username = $q_username AND ( ".
 361         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 362       " )";
 363     } else {
 364       '1 = 0'; #false
 365     }
 366   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 367     ' ( '.
 368       $class->search_sql_field('slipip',   $string ).
 369     ' OR '.
 370       $class->search_sql_field('username', $string ).
 371     ' ) ';
 372   } else {
 373     $class->search_sql_field('username', $string);
 374   }
 375 }
 376
 377 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 378
 379 Returns the "username@domain" string for this account.
 380
 381 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 382 history records.
 383
 384 =cut
 385
 386 sub label {
 387   my $self = shift;
 388   $self->email(@_);
 389 }
 390
 391 =cut
 392
 393 =item insert [ , OPTION => VALUE ... ]
 394
 395 Adds this account to the database.  If there is an error, returns the error,
 396 otherwise returns false.
 397
 398 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 399 defined.  An FS::cust_svc record will be created and inserted.
 400
 401 The additional field I<usergroup> can optionally be defined; if so it should
 402 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 403
 404 The additional field I<child_objects> can optionally be defined; if so it
 405 should contain an arrayref of FS::tablename objects.  They will have their
 406 svcnum fields set and will be inserted after this record, but before any
 407 exports are run.  Each element of the array can also optionally be a
 408 two-element array reference containing the child object and the name of an
 409 alternate field to be filled in with the newly-inserted svcnum, for example
 410 C<[ $svc_forward, 'srcsvc' ]>
 411
 412 Currently available options are: I<depend_jobnum>
 413
 414 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 415 jobnums), all provisioning jobs will have a dependancy on the supplied
 416 jobnum(s) (they will not run until the specific job(s) complete(s)).
 417
 418 (TODOC: L<FS::queue> and L<freeside-queued>)
 419
 420 (TODOC: new exports!)
 421
 422 =cut
 423
 424 sub insert {
 425   my $self = shift;
 426   my %options = @_;
 427
 428   if ( $DEBUG ) {
 429     warn "[$me] insert called on $self: ". Dumper($self).
 430          "\nwith options: ". Dumper(%options);
 431   }
 432
 433   local $SIG{HUP} = 'IGNORE';
 434   local $SIG{INT} = 'IGNORE';
 435   local $SIG{QUIT} = 'IGNORE';
 436   local $SIG{TERM} = 'IGNORE';
 437   local $SIG{TSTP} = 'IGNORE';
 438   local $SIG{PIPE} = 'IGNORE';
 439
 440   my $oldAutoCommit = $FS::UID::AutoCommit;
 441   local $FS::UID::AutoCommit = 0;
 442   my $dbh = dbh;
 443
 444   my $error = $self->check;
 445   return $error if $error;
 446
 447   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 448     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 449     unless ( $cust_svc ) {
 450       $dbh->rollback if $oldAutoCommit;
 451       return "no cust_svc record found for svcnum ". $self->svcnum;
 452     }
 453     $self->pkgnum($cust_svc->pkgnum);
 454     $self->svcpart($cust_svc->svcpart);
 455   }
 456
 457   $error = $self->_check_duplicate;
 458   if ( $error ) {
 459     $dbh->rollback if $oldAutoCommit;
 460     return $error;
 461   }
 462
 463   my @jobnums;
 464   $error = $self->SUPER::insert(
 465     'jobnums'       => \@jobnums,
 466     'child_objects' => $self->child_objects,
 467     %options,
 468   );
 469   if ( $error ) {
 470     $dbh->rollback if $oldAutoCommit;
 471     return $error;
 472   }
 473
 474   if ( $self->usergroup ) {
 475     foreach my $groupname ( @{$self->usergroup} ) {
 476       my $radius_usergroup = new FS::radius_usergroup ( {
 477         svcnum    => $self->svcnum,
 478         groupname => $groupname,
 479       } );
 480       my $error = $radius_usergroup->insert;
 481       if ( $error ) {
 482         $dbh->rollback if $oldAutoCommit;
 483         return $error;
 484       }
 485     }
 486   }
 487
 488   unless ( $skip_fuzzyfiles ) {
 489     $error = $self->queue_fuzzyfiles_update;
 490     if ( $error ) {
 491       $dbh->rollback if $oldAutoCommit;
 492       return "updating fuzzy search cache: $error";
 493     }
 494   }
 495
 496   my $cust_pkg = $self->cust_svc->cust_pkg;
 497
 498   if ( $cust_pkg ) {
 499     my $cust_main = $cust_pkg->cust_main;
 500     my $agentnum = $cust_main->agentnum;
 501
 502     if (   $conf->exists('emailinvoiceautoalways')
 503         || $conf->exists('emailinvoiceauto')
 504         && ! $cust_main->invoicing_list_emailonly
 505        ) {
 506       my @invoicing_list = $cust_main->invoicing_list;
 507       push @invoicing_list, $self->email;
 508       $cust_main->invoicing_list(\@invoicing_list);
 509     }
 510
 511     #welcome email
 512     my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
 513       = ('','','','','','');
 514
 515     if ( $conf->exists('welcome_email', $agentnum) ) {
 516       $welcome_template = new Text::Template (
 517         TYPE   => 'ARRAY',
 518         SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
 519       ) or warn "can't create welcome email template: $Text::Template::ERROR";
 520       $welcome_from = $conf->config('welcome_email-from', $agentnum);
 521         # || 'your-isp-is-dum'
 522       $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
 523         || 'Welcome';
 524       $welcome_subject_template = new Text::Template (
 525         TYPE   => 'STRING',
 526         SOURCE => $welcome_subject,
 527       ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
 528       $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
 529         || 'text/plain';
 530     }
 531     if ( $welcome_template && $cust_pkg ) {
 532       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 533       if ( $to ) {
 534
 535         my %hash = (
 536                      'custnum'  => $self->custnum,
 537                      'username' => $self->username,
 538                      'password' => $self->_password,
 539                      'first'    => $cust_main->first,
 540                      'last'     => $cust_main->getfield('last'),
 541                      'pkg'      => $cust_pkg->part_pkg->pkg,
 542                    );
 543         my $wqueue = new FS::queue {
 544           'svcnum' => $self->svcnum,
 545           'job'    => 'FS::svc_acct::send_email'
 546         };
 547         my $error = $wqueue->insert(
 548           'to'       => $to,
 549           'from'     => $welcome_from,
 550           'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
 551           'mimetype' => $welcome_mimetype,
 552           'body'     => $welcome_template->fill_in( HASH => \%hash, ),
 553         );
 554         if ( $error ) {
 555           $dbh->rollback if $oldAutoCommit;
 556           return "error queuing welcome email: $error";
 557         }
 558
 559         if ( $options{'depend_jobnum'} ) {
 560           warn "$me depend_jobnum found; adding to welcome email dependancies"
 561             if $DEBUG;
 562           if ( ref($options{'depend_jobnum'}) ) {
 563             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 564                  "to welcome email dependancies"
 565               if $DEBUG;
 566             push @jobnums, @{ $options{'depend_jobnum'} };
 567           } else {
 568             warn "$me adding job $options{'depend_jobnum'} ".
 569                  "to welcome email dependancies"
 570               if $DEBUG;
 571             push @jobnums, $options{'depend_jobnum'};
 572           }
 573         }
 574
 575         foreach my $jobnum ( @jobnums ) {
 576           my $error = $wqueue->depend_insert($jobnum);
 577           if ( $error ) {
 578             $dbh->rollback if $oldAutoCommit;
 579             return "error queuing welcome email job dependancy: $error";
 580           }
 581         }
 582
 583       }
 584
 585     }
 586
 587   } # if ( $cust_pkg )
 588
 589   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 590   ''; #no error
 591 }
 592
 593 =item delete
 594
 595 Deletes this account from the database.  If there is an error, returns the
 596 error, otherwise returns false.
 597
 598 The corresponding FS::cust_svc record will be deleted as well.
 599
 600 (TODOC: new exports!)
 601
 602 =cut
 603
 604 sub delete {
 605   my $self = shift;
 606
 607   return "can't delete system account" if $self->_check_system;
 608
 609   return "Can't delete an account which is a (svc_forward) source!"
 610     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 611
 612   return "Can't delete an account which is a (svc_forward) destination!"
 613     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 614
 615   return "Can't delete an account with (svc_www) web service!"
 616     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 617
 618   # what about records in session ? (they should refer to history table)
 619
 620   local $SIG{HUP} = 'IGNORE';
 621   local $SIG{INT} = 'IGNORE';
 622   local $SIG{QUIT} = 'IGNORE';
 623   local $SIG{TERM} = 'IGNORE';
 624   local $SIG{TSTP} = 'IGNORE';
 625   local $SIG{PIPE} = 'IGNORE';
 626
 627   my $oldAutoCommit = $FS::UID::AutoCommit;
 628   local $FS::UID::AutoCommit = 0;
 629   my $dbh = dbh;
 630
 631   foreach my $cust_main_invoice (
 632     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 633   ) {
 634     unless ( defined($cust_main_invoice) ) {
 635       warn "WARNING: something's wrong with qsearch";
 636       next;
 637     }
 638     my %hash = $cust_main_invoice->hash;
 639     $hash{'dest'} = $self->email;
 640     my $new = new FS::cust_main_invoice \%hash;
 641     my $error = $new->replace($cust_main_invoice);
 642     if ( $error ) {
 643       $dbh->rollback if $oldAutoCommit;
 644       return $error;
 645     }
 646   }
 647
 648   foreach my $svc_domain (
 649     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 650   ) {
 651     my %hash = new FS::svc_domain->hash;
 652     $hash{'catchall'} = '';
 653     my $new = new FS::svc_domain \%hash;
 654     my $error = $new->replace($svc_domain);
 655     if ( $error ) {
 656       $dbh->rollback if $oldAutoCommit;
 657       return $error;
 658     }
 659   }
 660
 661   my $error = $self->SUPER::delete;
 662   if ( $error ) {
 663     $dbh->rollback if $oldAutoCommit;
 664     return $error;
 665   }
 666
 667   foreach my $radius_usergroup (
 668     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 669   ) {
 670     my $error = $radius_usergroup->delete;
 671     if ( $error ) {
 672       $dbh->rollback if $oldAutoCommit;
 673       return $error;
 674     }
 675   }
 676
 677   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 678   '';
 679 }
 680
 681 =item replace OLD_RECORD
 682
 683 Replaces OLD_RECORD with this one in the database.  If there is an error,
 684 returns the error, otherwise returns false.
 685
 686 The additional field I<usergroup> can optionally be defined; if so it should
 687 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 688
 689
 690 =cut
 691
 692 sub replace {
 693   my ( $new, $old ) = ( shift, shift );
 694   my $error;
 695   warn "$me replacing $old with $new\n" if $DEBUG;
 696
 697   # We absolutely have to have an old vs. new record to make this work.
 698   if (!defined($old)) {
 699     $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
 700   }
 701
 702   return "can't modify system account" if $old->_check_system;
 703
 704   {
 705     #no warnings 'numeric';  #alas, a 5.006-ism
 706     local($^W) = 0;
 707
 708     foreach my $xid (qw( uid gid )) {
 709
 710       return "Can't change $xid!"
 711         if ! $conf->exists("svc_acct-edit_$xid")
 712            && $old->$xid() != $new->$xid()
 713            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 714     }
 715
 716   }
 717
 718   #change homdir when we change username
 719   $new->setfield('dir', '') if $old->username ne $new->username;
 720
 721   local $SIG{HUP} = 'IGNORE';
 722   local $SIG{INT} = 'IGNORE';
 723   local $SIG{QUIT} = 'IGNORE';
 724   local $SIG{TERM} = 'IGNORE';
 725   local $SIG{TSTP} = 'IGNORE';
 726   local $SIG{PIPE} = 'IGNORE';
 727
 728   my $oldAutoCommit = $FS::UID::AutoCommit;
 729   local $FS::UID::AutoCommit = 0;
 730   my $dbh = dbh;
 731
 732   # redundant, but so $new->usergroup gets set
 733   $error = $new->check;
 734   return $error if $error;
 735
 736   $old->usergroup( [ $old->radius_groups ] );
 737   if ( $DEBUG ) {
 738     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
 739     warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
 740   }
 741   if ( $new->usergroup ) {
 742     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 743     my @newgroups = @{$new->usergroup};
 744     foreach my $oldgroup ( @{$old->usergroup} ) {
 745       if ( grep { $oldgroup eq $_ } @newgroups ) {
 746         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 747         next;
 748       }
 749       my $radius_usergroup = qsearchs('radius_usergroup', {
 750         svcnum    => $old->svcnum,
 751         groupname => $oldgroup,
 752       } );
 753       my $error = $radius_usergroup->delete;
 754       if ( $error ) {
 755         $dbh->rollback if $oldAutoCommit;
 756         return "error deleting radius_usergroup $oldgroup: $error";
 757       }
 758     }
 759
 760     foreach my $newgroup ( @newgroups ) {
 761       my $radius_usergroup = new FS::radius_usergroup ( {
 762         svcnum    => $new->svcnum,
 763         groupname => $newgroup,
 764       } );
 765       my $error = $radius_usergroup->insert;
 766       if ( $error ) {
 767         $dbh->rollback if $oldAutoCommit;
 768         return "error adding radius_usergroup $newgroup: $error";
 769       }
 770     }
 771
 772   }
 773
 774   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 775     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 776     $error = $new->_check_duplicate;
 777     if ( $error ) {
 778       $dbh->rollback if $oldAutoCommit;
 779       return $error;
 780     }
 781   }
 782
 783   $error = $new->SUPER::replace($old, @_);
 784   if ( $error ) {
 785     $dbh->rollback if $oldAutoCommit;
 786     return $error if $error;
 787   }
 788
 789   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 790     $error = $new->queue_fuzzyfiles_update;
 791     if ( $error ) {
 792       $dbh->rollback if $oldAutoCommit;
 793       return "updating fuzzy search cache: $error";
 794     }
 795   }
 796
 797   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 798   ''; #no error
 799 }
 800
 801 =item queue_fuzzyfiles_update
 802
 803 Used by insert & replace to update the fuzzy search cache
 804
 805 =cut
 806
 807 sub queue_fuzzyfiles_update {
 808   my $self = shift;
 809
 810   local $SIG{HUP} = 'IGNORE';
 811   local $SIG{INT} = 'IGNORE';
 812   local $SIG{QUIT} = 'IGNORE';
 813   local $SIG{TERM} = 'IGNORE';
 814   local $SIG{TSTP} = 'IGNORE';
 815   local $SIG{PIPE} = 'IGNORE';
 816
 817   my $oldAutoCommit = $FS::UID::AutoCommit;
 818   local $FS::UID::AutoCommit = 0;
 819   my $dbh = dbh;
 820
 821   my $queue = new FS::queue {
 822     'svcnum' => $self->svcnum,
 823     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 824   };
 825   my $error = $queue->insert($self->username);
 826   if ( $error ) {
 827     $dbh->rollback if $oldAutoCommit;
 828     return "queueing job (transaction rolled back): $error";
 829   }
 830
 831   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 832   '';
 833
 834 }
 835
 836
 837 =item suspend
 838
 839 Suspends this account by calling export-specific suspend hooks.  If there is
 840 an error, returns the error, otherwise returns false.
 841
 842 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 843
 844 =cut
 845
 846 sub suspend {
 847   my $self = shift;
 848   return "can't suspend system account" if $self->_check_system;
 849   $self->SUPER::suspend(@_);
 850 }
 851
 852 =item unsuspend
 853
 854 Unsuspends this account by by calling export-specific suspend hooks.  If there
 855 is an error, returns the error, otherwise returns false.
 856
 857 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 858
 859 =cut
 860
 861 sub unsuspend {
 862   my $self = shift;
 863   my %hash = $self->hash;
 864   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 865     $hash{_password} = $1;
 866     my $new = new FS::svc_acct ( \%hash );
 867     my $error = $new->replace($self);
 868     return $error if $error;
 869   }
 870
 871   $self->SUPER::unsuspend(@_);
 872 }
 873
 874 =item cancel
 875
 876 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 877
 878 If the B<auto_unset_catchall> configuration option is set, this method will
 879 automatically remove any references to the canceled service in the catchall
 880 field of svc_domain.  This allows packages that contain both a svc_domain and
 881 its catchall svc_acct to be canceled in one step.
 882
 883 =cut
 884
 885 sub cancel {
 886   # Only one thing to do at this level
 887   my $self = shift;
 888   foreach my $svc_domain (
 889       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 890     if($conf->exists('auto_unset_catchall')) {
 891       my %hash = $svc_domain->hash;
 892       $hash{catchall} = '';
 893       my $new = new FS::svc_domain ( \%hash );
 894       my $error = $new->replace($svc_domain);
 895       return $error if $error;
 896     } else {
 897       return "cannot unprovision svc_acct #".$self->svcnum.
 898           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 899     }
 900   }
 901
 902   $self->SUPER::cancel(@_);
 903 }
 904
 905
 906 =item check
 907
 908 Checks all fields to make sure this is a valid service.  If there is an error,
 909 returns the error, otherwise returns false.  Called by the insert and replace
 910 methods.
 911
 912 Sets any fixed values; see L<FS::part_svc>.
 913
 914 =cut
 915
 916 sub check {
 917   my $self = shift;
 918
 919   my($recref) = $self->hashref;
 920
 921   my $x = $self->setfixed( $self->_fieldhandlers );
 922   return $x unless ref($x);
 923   my $part_svc = $x;
 924
 925   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 926     $self->usergroup(
 927       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 928   }
 929
 930   my $error = $self->ut_numbern('svcnum')
 931               #|| $self->ut_number('domsvc')
 932               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 933               || $self->ut_textn('sec_phrase')
 934               || $self->ut_snumbern('seconds')
 935               || $self->ut_snumbern('upbytes')
 936               || $self->ut_snumbern('downbytes')
 937               || $self->ut_snumbern('totalbytes')
 938               || $self->ut_enum( '_password_encoding',
 939                                  [ '', qw( plain crypt ldap ) ]
 940                                )
 941   ;
 942   return $error if $error;
 943
 944   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 945   if ( $username_uppercase ) {
 946     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
 947       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 948     $recref->{username} = $1;
 949   } else {
 950     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
 951       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 952     $recref->{username} = $1;
 953   }
 954
 955   if ( $username_letterfirst ) {
 956     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 957   } elsif ( $username_letter ) {
 958     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 959   }
 960   if ( $username_noperiod ) {
 961     $recref->{username} =~ /\./ and return gettext('illegal_username');
 962   }
 963   if ( $username_nounderscore ) {
 964     $recref->{username} =~ /_/ and return gettext('illegal_username');
 965   }
 966   if ( $username_nodash ) {
 967     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 968   }
 969   unless ( $username_ampersand ) {
 970     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 971   }
 972   unless ( $username_percent ) {
 973     $recref->{username} =~ /\%/ and return gettext('illegal_username');
 974   }
 975
 976   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 977   $recref->{popnum} = $1;
 978   return "Unknown popnum" unless
 979     ! $recref->{popnum} ||
 980     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 981
 982   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 983
 984     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 985     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 986
 987     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 988     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 989     #not all systems use gid=uid
 990     #you can set a fixed gid in part_svc
 991
 992     return "Only root can have uid 0"
 993       if $recref->{uid} == 0
 994          && $recref->{username} !~ /^(root|toor|smtp)$/;
 995
 996     unless ( $recref->{username} eq 'sync' ) {
 997       if ( grep $_ eq $recref->{shell}, @shells ) {
 998         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 999       } else {
1000         return "Illegal shell \`". $self->shell. "\'; ".
1001                "shells configuration value contains: @shells";
1002       }
1003     } else {
1004       $recref->{shell} = '/bin/sync';
1005     }
1006
1007   } else {
1008     $recref->{gid} ne '' ?
1009       return "Can't have gid without uid" : ( $recref->{gid}='' );
1010     #$recref->{dir} ne '' ?
1011     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1012     $recref->{shell} ne '' ?
1013       return "Can't have shell without uid" : ( $recref->{shell}='' );
1014   }
1015
1016   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1017
1018     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1019       or return "Illegal directory: ". $recref->{dir};
1020     $recref->{dir} = $1;
1021     return "Illegal directory"
1022       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1023     return "Illegal directory"
1024       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1025     unless ( $recref->{dir} ) {
1026       $recref->{dir} = $dir_prefix . '/';
1027       if ( $dirhash > 0 ) {
1028         for my $h ( 1 .. $dirhash ) {
1029           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1030         }
1031       } elsif ( $dirhash < 0 ) {
1032         for my $h ( reverse $dirhash .. -1 ) {
1033           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1034         }
1035       }
1036       $recref->{dir} .= $recref->{username};
1037     ;
1038     }
1039
1040   }
1041
1042   #  $error = $self->ut_textn('finger');
1043   #  return $error if $error;
1044   if ( $self->getfield('finger') eq '' ) {
1045     my $cust_pkg = $self->svcnum
1046       ? $self->cust_svc->cust_pkg
1047       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1048     if ( $cust_pkg ) {
1049       my $cust_main = $cust_pkg->cust_main;
1050       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1051     }
1052   }
1053   $self->getfield('finger') =~
1054     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1055       or return "Illegal finger: ". $self->getfield('finger');
1056   $self->setfield('finger', $1);
1057
1058   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1059   $recref->{quota} = $1;
1060
1061   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1062     if ( $recref->{slipip} eq '' ) {
1063       $recref->{slipip} = '';
1064     } elsif ( $recref->{slipip} eq '0e0' ) {
1065       $recref->{slipip} = '0e0';
1066     } else {
1067       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1068         or return "Illegal slipip: ". $self->slipip;
1069       $recref->{slipip} = $1;
1070     }
1071
1072   }
1073
1074   #arbitrary RADIUS stuff; allow ut_textn for now
1075   foreach ( grep /^radius_/, fields('svc_acct') ) {
1076     $self->ut_textn($_);
1077   }
1078
1079   if ( $recref->{_password_encoding} eq 'ldap' ) {
1080
1081     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1082       $recref->{_password} = uc($1).$2;
1083     } else {
1084       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1085     }
1086
1087   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1088
1089     if ( $recref->{_password} =~
1090            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1091            /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1092        ) {
1093
1094       $recref->{_password} = $1.$2;
1095
1096     } else {
1097       return 'Illegal (crypt-encoded) password';
1098     }
1099
1100   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1101
1102     #generate a password if it is blank
1103     $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1104       unless length( $recref->{_password} );
1105
1106     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1107       $recref->{_password} = $1;
1108     } else {
1109       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1110              FS::Msgcat::_gettext('illegal_password_characters').
1111              ": ". $recref->{_password};
1112     }
1113
1114     if ( $password_noampersand ) {
1115       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1116     }
1117     if ( $password_noexclamation ) {
1118       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1119     }
1120
1121   } else {
1122
1123     #carp "warning: _password_encoding unspecified\n";
1124
1125     #generate a password if it is blank
1126     unless ( length( $recref->{_password} ) ) {
1127
1128       $recref->{_password} =
1129         join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1130       $recref->{_password_encoding} = 'plain';
1131
1132     } else {
1133
1134       #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1135       if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1136         $recref->{_password} = $1.$3;
1137         $recref->{_password_encoding} = 'plain';
1138       } elsif ( $recref->{_password} =~
1139                   /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1140               ) {
1141         $recref->{_password} = $1.$3;
1142         $recref->{_password_encoding} = 'crypt';
1143       } elsif ( $recref->{_password} eq '*' ) {
1144         $recref->{_password} = '*';
1145         $recref->{_password_encoding} = 'crypt';
1146       } elsif ( $recref->{_password} eq '!' ) {
1147         $recref->{_password_encoding} = 'crypt';
1148         $recref->{_password} = '!';
1149       } elsif ( $recref->{_password} eq '!!' ) {
1150         $recref->{_password} = '!!';
1151         $recref->{_password_encoding} = 'crypt';
1152       } else {
1153         #return "Illegal password";
1154         return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1155                FS::Msgcat::_gettext('illegal_password_characters').
1156                ": ". $recref->{_password};
1157       }
1158
1159     }
1160
1161   }
1162
1163   $self->SUPER::check;
1164
1165 }
1166
1167 =item _check_system
1168
1169 Internal function to check the username against the list of system usernames
1170 from the I<system_usernames> configuration value.  Returns true if the username
1171 is listed on the system username list.
1172
1173 =cut
1174
1175 sub _check_system {
1176   my $self = shift;
1177   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1178                $conf->config('system_usernames')
1179         );
1180 }
1181
1182 =item _check_duplicate
1183
1184 Internal function to check for duplicates usernames, username@domain pairs and
1185 uids.
1186
1187 If the I<global_unique-username> configuration value is set to B<username> or
1188 B<username@domain>, enforces global username or username@domain uniqueness.
1189
1190 In all cases, check for duplicate uids and usernames or username@domain pairs
1191 per export and with identical I<svcpart> values.
1192
1193 =cut
1194
1195 sub _check_duplicate {
1196   my $self = shift;
1197
1198   my $global_unique = $conf->config('global_unique-username') || 'none';
1199   return '' if $global_unique eq 'disabled';
1200
1201   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1202   if ( driver_name =~ /^Pg/i ) {
1203     dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1204       or die dbh->errstr;
1205   } elsif ( driver_name =~ /^mysql/i ) {
1206     dbh->do("SELECT * FROM duplicate_lock
1207                WHERE lockname = 'svc_acct'
1208                FOR UPDATE"
1209            ) or die dbh->errstr;
1210   } else {
1211     die "unknown database ". driver_name.
1212         "; don't know how to lock for duplicate search";
1213   }
1214   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1215
1216   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1217   unless ( $part_svc ) {
1218     return 'unknown svcpart '. $self->svcpart;
1219   }
1220
1221   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1222                  qsearch( 'svc_acct', { 'username' => $self->username } );
1223   return gettext('username_in_use')
1224     if $global_unique eq 'username' && @dup_user;
1225
1226   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1227                        qsearch( 'svc_acct', { 'username' => $self->username,
1228                                               'domsvc'   => $self->domsvc } );
1229   return gettext('username_in_use')
1230     if $global_unique eq 'username@domain' && @dup_userdomain;
1231
1232   my @dup_uid;
1233   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1234        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1235     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1236                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1237   } else {
1238     @dup_uid = ();
1239   }
1240
1241   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1242     my $exports = FS::part_export::export_info('svc_acct');
1243     my %conflict_user_svcpart;
1244     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1245
1246     foreach my $part_export ( $part_svc->part_export ) {
1247
1248       #this will catch to the same exact export
1249       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1250
1251       #this will catch to exports w/same exporthost+type ???
1252       #my @other_part_export = qsearch('part_export', {
1253       #  'machine'    => $part_export->machine,
1254       #  'exporttype' => $part_export->exporttype,
1255       #} );
1256       #foreach my $other_part_export ( @other_part_export ) {
1257       #  push @svcparts, map { $_->svcpart }
1258       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1259       #}
1260
1261       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1262       #silly kludge to avoid uninitialized value errors
1263       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1264                      ? $exports->{$part_export->exporttype}{'nodomain'}
1265                      : '';
1266       if ( $nodomain =~ /^Y/i ) {
1267         $conflict_user_svcpart{$_} = $part_export->exportnum
1268           foreach @svcparts;
1269       } else {
1270         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1271           foreach @svcparts;
1272       }
1273     }
1274
1275     foreach my $dup_user ( @dup_user ) {
1276       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1277       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1278         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1279                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1280       }
1281     }
1282
1283     foreach my $dup_userdomain ( @dup_userdomain ) {
1284       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1285       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1286         return "duplicate username\@domain: conflicts with svcnum ".
1287                $dup_userdomain->svcnum. " via exportnum ".
1288                $conflict_userdomain_svcpart{$dup_svcpart};
1289       }
1290     }
1291
1292     foreach my $dup_uid ( @dup_uid ) {
1293       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1294       if ( exists($conflict_user_svcpart{$dup_svcpart})
1295            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1296         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1297                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1298                                  || $conflict_userdomain_svcpart{$dup_svcpart};
1299       }
1300     }
1301
1302   }
1303
1304   return '';
1305
1306 }
1307
1308 =item radius
1309
1310 Depriciated, use radius_reply instead.
1311
1312 =cut
1313
1314 sub radius {
1315   carp "FS::svc_acct::radius depriciated, use radius_reply";
1316   $_[0]->radius_reply;
1317 }
1318
1319 =item radius_reply
1320
1321 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1322 reply attributes of this record.
1323
1324 Note that this is now the preferred method for reading RADIUS attributes -
1325 accessing the columns directly is discouraged, as the column names are
1326 expected to change in the future.
1327
1328 =cut
1329
1330 sub radius_reply {
1331   my $self = shift;
1332
1333   return %{ $self->{'radius_reply'} }
1334     if exists $self->{'radius_reply'};
1335
1336   my %reply =
1337     map {
1338       /^(radius_(.*))$/;
1339       my($column, $attrib) = ($1, $2);
1340       #$attrib =~ s/_/\-/g;
1341       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1342     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1343
1344   if ( $self->slipip && $self->slipip ne '0e0' ) {
1345     $reply{$radius_ip} = $self->slipip;
1346   }
1347
1348   if ( $self->seconds !~ /^$/ ) {
1349     $reply{'Session-Timeout'} = $self->seconds;
1350   }
1351
1352   %reply;
1353 }
1354
1355 =item radius_check
1356
1357 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1358 check attributes of this record.
1359
1360 Note that this is now the preferred method for reading RADIUS attributes -
1361 accessing the columns directly is discouraged, as the column names are
1362 expected to change in the future.
1363
1364 =cut
1365
1366 sub radius_check {
1367   my $self = shift;
1368
1369   return %{ $self->{'radius_check'} }
1370     if exists $self->{'radius_check'};
1371
1372   my %check =
1373     map {
1374       /^(rc_(.*))$/;
1375       my($column, $attrib) = ($1, $2);
1376       #$attrib =~ s/_/\-/g;
1377       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1378     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1379
1380   my $password = $self->_password;
1381   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';  $check{$pw_attrib} = $password;
1382
1383   my $cust_svc = $self->cust_svc;
1384   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1385     unless $cust_svc;
1386   my $cust_pkg = $cust_svc->cust_pkg;
1387   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1388     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1389   }
1390
1391   %check;
1392
1393 }
1394
1395 =item snapshot
1396
1397 This method instructs the object to "snapshot" or freeze RADIUS check and
1398 reply attributes to the current values.
1399
1400 =cut
1401
1402 #bah, my english is too broken this morning
1403 #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
1404 #the FS::cust_pkg's replace method to trigger the correct export updates when
1405 #package dates change)
1406
1407 sub snapshot {
1408   my $self = shift;
1409
1410   $self->{$_} = { $self->$_() }
1411     foreach qw( radius_reply radius_check );
1412
1413 }
1414
1415 =item forget_snapshot
1416
1417 This methos instructs the object to forget any previously snapshotted
1418 RADIUS check and reply attributes.
1419
1420 =cut
1421
1422 sub forget_snapshot {
1423   my $self = shift;
1424
1425   delete $self->{$_}
1426     foreach qw( radius_reply radius_check );
1427
1428 }
1429
1430 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1431
1432 Returns the domain associated with this account.
1433
1434 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1435 history records.
1436
1437 =cut
1438
1439 sub domain {
1440   my $self = shift;
1441   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1442   my $svc_domain = $self->svc_domain(@_)
1443     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1444   $svc_domain->domain;
1445 }
1446
1447 =item svc_domain
1448
1449 Returns the FS::svc_domain record for this account's domain (see
1450 L<FS::svc_domain>).
1451
1452 =cut
1453
1454 # FS::h_svc_acct has a history-aware svc_domain override
1455
1456 sub svc_domain {
1457   my $self = shift;
1458   $self->{'_domsvc'}
1459     ? $self->{'_domsvc'}
1460     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1461 }
1462
1463 =item cust_svc
1464
1465 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1466
1467 =cut
1468
1469 #inherited from svc_Common
1470
1471 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1472
1473 Returns an email address associated with the account.
1474
1475 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1476 history records.
1477
1478 =cut
1479
1480 sub email {
1481   my $self = shift;
1482   $self->username. '@'. $self->domain(@_);
1483 }
1484
1485 =item acct_snarf
1486
1487 Returns an array of FS::acct_snarf records associated with the account.
1488 If the acct_snarf table does not exist or there are no associated records,
1489 an empty list is returned
1490
1491 =cut
1492
1493 sub acct_snarf {
1494   my $self = shift;
1495   return () unless dbdef->table('acct_snarf');
1496   eval "use FS::acct_snarf;";
1497   die $@ if $@;
1498   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1499 }
1500
1501 =item decrement_upbytes OCTETS
1502
1503 Decrements the I<upbytes> field of this record by the given amount.  If there
1504 is an error, returns the error, otherwise returns false.
1505
1506 =cut
1507
1508 sub decrement_upbytes {
1509   shift->_op_usage('-', 'upbytes', @_);
1510 }
1511
1512 =item increment_upbytes OCTETS
1513
1514 Increments the I<upbytes> field of this record by the given amount.  If there
1515 is an error, returns the error, otherwise returns false.
1516
1517 =cut
1518
1519 sub increment_upbytes {
1520   shift->_op_usage('+', 'upbytes', @_);
1521 }
1522
1523 =item decrement_downbytes OCTETS
1524
1525 Decrements the I<downbytes> field of this record by the given amount.  If there
1526 is an error, returns the error, otherwise returns false.
1527
1528 =cut
1529
1530 sub decrement_downbytes {
1531   shift->_op_usage('-', 'downbytes', @_);
1532 }
1533
1534 =item increment_downbytes OCTETS
1535
1536 Increments the I<downbytes> field of this record by the given amount.  If there
1537 is an error, returns the error, otherwise returns false.
1538
1539 =cut
1540
1541 sub increment_downbytes {
1542   shift->_op_usage('+', 'downbytes', @_);
1543 }
1544
1545 =item decrement_totalbytes OCTETS
1546
1547 Decrements the I<totalbytes> field of this record by the given amount.  If there
1548 is an error, returns the error, otherwise returns false.
1549
1550 =cut
1551
1552 sub decrement_totalbytes {
1553   shift->_op_usage('-', 'totalbytes', @_);
1554 }
1555
1556 =item increment_totalbytes OCTETS
1557
1558 Increments the I<totalbytes> field of this record by the given amount.  If there
1559 is an error, returns the error, otherwise returns false.
1560
1561 =cut
1562
1563 sub increment_totalbytes {
1564   shift->_op_usage('+', 'totalbytes', @_);
1565 }
1566
1567 =item decrement_seconds SECONDS
1568
1569 Decrements the I<seconds> field of this record by the given amount.  If there
1570 is an error, returns the error, otherwise returns false.
1571
1572 =cut
1573
1574 sub decrement_seconds {
1575   shift->_op_usage('-', 'seconds', @_);
1576 }
1577
1578 =item increment_seconds SECONDS
1579
1580 Increments the I<seconds> field of this record by the given amount.  If there
1581 is an error, returns the error, otherwise returns false.
1582
1583 =cut
1584
1585 sub increment_seconds {
1586   shift->_op_usage('+', 'seconds', @_);
1587 }
1588
1589
1590 my %op2action = (
1591   '-' => 'suspend',
1592   '+' => 'unsuspend',
1593 );
1594 my %op2condition = (
1595   '-' => sub { my($self, $column, $amount) = @_;
1596                $self->$column - $amount <= 0;
1597              },
1598   '+' => sub { my($self, $column, $amount) = @_;
1599                $self->$column + $amount > 0;
1600              },
1601 );
1602 my %op2warncondition = (
1603   '-' => sub { my($self, $column, $amount) = @_;
1604                my $threshold = $column . '_threshold';
1605                $self->$column - $amount <= $self->$threshold + 0;
1606              },
1607   '+' => sub { my($self, $column, $amount) = @_;
1608                $self->$column + $amount > 0;
1609              },
1610 );
1611
1612 sub _op_usage {
1613   my( $self, $op, $column, $amount ) = @_;
1614
1615   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1616        ' ('. $self->email. "): $op $amount\n"
1617     if $DEBUG;
1618
1619   return '' unless $amount;
1620
1621   local $SIG{HUP} = 'IGNORE';
1622   local $SIG{INT} = 'IGNORE';
1623   local $SIG{QUIT} = 'IGNORE';
1624   local $SIG{TERM} = 'IGNORE';
1625   local $SIG{TSTP} = 'IGNORE';
1626   local $SIG{PIPE} = 'IGNORE';
1627
1628   my $oldAutoCommit = $FS::UID::AutoCommit;
1629   local $FS::UID::AutoCommit = 0;
1630   my $dbh = dbh;
1631
1632   my $sql = "UPDATE svc_acct SET $column = ".
1633             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1634             " $op ? WHERE svcnum = ?";
1635   warn "$me $sql\n"
1636     if $DEBUG;
1637
1638   my $sth = $dbh->prepare( $sql )
1639     or die "Error preparing $sql: ". $dbh->errstr;
1640   my $rv = $sth->execute($amount, $self->svcnum);
1641   die "Error executing $sql: ". $sth->errstr
1642     unless defined($rv);
1643   die "Can't update $column for svcnum". $self->svcnum
1644     if $rv == 0;
1645
1646   my $action = $op2action{$op};
1647
1648   if ( &{$op2condition{$op}}($self, $column, $amount) &&
1649         ( $action eq 'suspend'   && !$self->overlimit
1650        || $action eq 'unsuspend' &&  $self->overlimit )
1651      ) {
1652     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1653       if ($part_export->option('overlimit_groups')) {
1654         my ($new,$old);
1655         my $other = new FS::svc_acct $self->hashref;
1656         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1657                        ($self, $part_export->option('overlimit_groups'));
1658         $other->usergroup( $groups );
1659         if ($action eq 'suspend'){
1660           $new = $other; $old = $self;
1661         }else{
1662           $new = $self; $old = $other;
1663         }
1664         my $error = $part_export->export_replace($new, $old);
1665         $error ||= $self->overlimit($action);
1666         if ( $error ) {
1667           $dbh->rollback if $oldAutoCommit;
1668           return "Error replacing radius groups in export, ${op}: $error";
1669         }
1670       }
1671     }
1672   }
1673
1674   if ( $conf->exists("svc_acct-usage_$action")
1675        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1676     #my $error = $self->$action();
1677     my $error = $self->cust_svc->cust_pkg->$action();
1678     # $error ||= $self->overlimit($action);
1679     if ( $error ) {
1680       $dbh->rollback if $oldAutoCommit;
1681       return "Error ${action}ing: $error";
1682     }
1683   }
1684
1685   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1686     my $wqueue = new FS::queue {
1687       'svcnum' => $self->svcnum,
1688       'job'    => 'FS::svc_acct::reached_threshold',
1689     };
1690
1691     my $to = '';
1692     if ($op eq '-'){
1693       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1694     }
1695
1696     # x_threshold race
1697     my $error = $wqueue->insert(
1698       'svcnum' => $self->svcnum,
1699       'op'     => $op,
1700       'column' => $column,
1701       'to'     => $to,
1702     );
1703     if ( $error ) {
1704       $dbh->rollback if $oldAutoCommit;
1705       return "Error queuing threshold activity: $error";
1706     }
1707   }
1708
1709   warn "$me update successful; committing\n"
1710     if $DEBUG;
1711   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1712   '';
1713
1714 }
1715
1716 sub set_usage {
1717   my( $self, $valueref ) = @_;
1718
1719   warn "$me set_usage called for svcnum ". $self->svcnum.
1720        ' ('. $self->email. "): ".
1721        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1722     if $DEBUG;
1723
1724   local $SIG{HUP} = 'IGNORE';
1725   local $SIG{INT} = 'IGNORE';
1726   local $SIG{QUIT} = 'IGNORE';
1727   local $SIG{TERM} = 'IGNORE';
1728   local $SIG{TSTP} = 'IGNORE';
1729   local $SIG{PIPE} = 'IGNORE';
1730
1731   local $FS::svc_Common::noexport_hack = 1;
1732   my $oldAutoCommit = $FS::UID::AutoCommit;
1733   local $FS::UID::AutoCommit = 0;
1734   my $dbh = dbh;
1735
1736   my $reset = 0;
1737   my %handyhash = ();
1738   foreach my $field (keys %$valueref){
1739     $reset = 1 if $valueref->{$field};
1740     $self->setfield($field, $valueref->{$field});
1741     $self->setfield( $field.'_threshold',
1742                      int($self->getfield($field)
1743                          * ( $conf->exists('svc_acct-usage_threshold')
1744                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1745                              : 0.20
1746                            )
1747                        )
1748                      );
1749     $handyhash{$field} = $self->getfield($field);
1750     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1751   }
1752   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1753   #die $error if $error;         #services not explicity changed via the UI
1754
1755   my $sql = "UPDATE svc_acct SET " .
1756     join (',', map { "$_ =  ?" } (keys %handyhash) ).
1757     " WHERE svcnum = ?";
1758
1759   warn "$me $sql\n"
1760     if $DEBUG;
1761
1762   if (scalar(keys %handyhash)) {
1763     my $sth = $dbh->prepare( $sql )
1764       or die "Error preparing $sql: ". $dbh->errstr;
1765     my $rv = $sth->execute((values %handyhash), $self->svcnum);
1766     die "Error executing $sql: ". $sth->errstr
1767       unless defined($rv);
1768     die "Can't update usage for svcnum ". $self->svcnum
1769       if $rv == 0;
1770   }
1771
1772   if ( $reset ) {
1773     my $error;
1774
1775     if ($self->overlimit) {
1776       $error = $self->overlimit('unsuspend');
1777       foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1778         if ($part_export->option('overlimit_groups')) {
1779           my $old = new FS::svc_acct $self->hashref;
1780           my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1781                          ($self, $part_export->option('overlimit_groups'));
1782           $old->usergroup( $groups );
1783           $error ||= $part_export->export_replace($self, $old);
1784         }
1785       }
1786     }
1787
1788     if ( $conf->exists("svc_acct-usage_unsuspend")) {
1789       $error ||= $self->cust_svc->cust_pkg->unsuspend;
1790     }
1791     if ( $error ) {
1792       $dbh->rollback if $oldAutoCommit;
1793       return "Error unsuspending: $error";
1794     }
1795   }
1796
1797   warn "$me update successful; committing\n"
1798     if $DEBUG;
1799   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1800   '';
1801
1802 }
1803
1804
1805 =item recharge HASHREF
1806
1807   Increments usage columns by the amount specified in HASHREF as
1808   column=>amount pairs.
1809
1810 =cut
1811
1812 sub recharge {
1813   my ($self, $vhash) = @_;
1814
1815   if ( $DEBUG ) {
1816     warn "[$me] recharge called on $self: ". Dumper($self).
1817          "\nwith vhash: ". Dumper($vhash);
1818   }
1819
1820   my $oldAutoCommit = $FS::UID::AutoCommit;
1821   local $FS::UID::AutoCommit = 0;
1822   my $dbh = dbh;
1823   my $error = '';
1824
1825   foreach my $column (keys %$vhash){
1826     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1827   }
1828
1829   if ( $error ) {
1830     $dbh->rollback if $oldAutoCommit;
1831   }else{
1832     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1833   }
1834   return $error;
1835 }
1836
1837 =item is_rechargeable
1838
1839 Returns true if this svc_account can be "recharged" and false otherwise.
1840
1841 =cut
1842
1843 sub is_rechargable {
1844   my $self = shift;
1845   $self->seconds ne ''
1846     || $self->upbytes ne ''
1847     || $self->downbytes ne ''
1848     || $self->totalbytes ne '';
1849 }
1850
1851 =item seconds_since TIMESTAMP
1852
1853 Returns the number of seconds this account has been online since TIMESTAMP,
1854 according to the session monitor (see L<FS::Session>).
1855
1856 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1857 L<Time::Local> and L<Date::Parse> for conversion functions.
1858
1859 =cut
1860
1861 #note: POD here, implementation in FS::cust_svc
1862 sub seconds_since {
1863   my $self = shift;
1864   $self->cust_svc->seconds_since(@_);
1865 }
1866
1867 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1868
1869 Returns the numbers of seconds this account has been online between
1870 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1871 external SQL radacct table, specified via sqlradius export.  Sessions which
1872 started in the specified range but are still open are counted from session
1873 start to the end of the range (unless they are over 1 day old, in which case
1874 they are presumed missing their stop record and not counted).  Also, sessions
1875 which end in the range but started earlier are counted from the start of the
1876 range to session end.  Finally, sessions which start before the range but end
1877 after are counted for the entire range.
1878
1879 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1880 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1881 functions.
1882
1883 =cut
1884
1885 #note: POD here, implementation in FS::cust_svc
1886 sub seconds_since_sqlradacct {
1887   my $self = shift;
1888   $self->cust_svc->seconds_since_sqlradacct(@_);
1889 }
1890
1891 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1892
1893 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1894 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1895 TIMESTAMP_END (exclusive).
1896
1897 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1898 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1899 functions.
1900
1901 =cut
1902
1903 #note: POD here, implementation in FS::cust_svc
1904 sub attribute_since_sqlradacct {
1905   my $self = shift;
1906   $self->cust_svc->attribute_since_sqlradacct(@_);
1907 }
1908
1909 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1910
1911 Returns an array of hash references of this customers login history for the
1912 given time range.  (document this better)
1913
1914 =cut
1915
1916 sub get_session_history {
1917   my $self = shift;
1918   $self->cust_svc->get_session_history(@_);
1919 }
1920
1921 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1922
1923 =cut
1924
1925 sub get_cdrs {
1926   my($self, $start, $end, %opt ) = @_;
1927
1928   my $did = $self->username; #yup
1929
1930   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1931
1932   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1933
1934   #SELECT $for_update * FROM cdr
1935   #  WHERE calldate >= $start #need a conversion
1936   #    AND calldate <  $end   #ditto
1937   #    AND (    charged_party = "$did"
1938   #          OR charged_party = "$prefix$did" #if length($prefix);
1939   #          OR ( ( charged_party IS NULL OR charged_party = '' )
1940   #               AND
1941   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1942   #             )
1943   #        )
1944   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
1945
1946   my $charged_or_src;
1947   if ( length($prefix) ) {
1948     $charged_or_src =
1949       " AND (    charged_party = '$did'
1950               OR charged_party = '$prefix$did'
1951               OR ( ( charged_party IS NULL OR charged_party = '' )
1952                    AND
1953                    ( src = '$did' OR src = '$prefix$did' )
1954                  )
1955             )
1956       ";
1957   } else {
1958     $charged_or_src =
1959       " AND (    charged_party = '$did'
1960               OR ( ( charged_party IS NULL OR charged_party = '' )
1961                    AND
1962                    src = '$did'
1963                  )
1964             )
1965       ";
1966
1967   }
1968
1969   qsearch(
1970     'select'    => "$for_update *",
1971     'table'     => 'cdr',
1972     'hashref'   => {
1973                      #( freesidestatus IS NULL OR freesidestatus = '' )
1974                      'freesidestatus' => '',
1975                    },
1976     'extra_sql' => $charged_or_src,
1977
1978   );
1979
1980 }
1981
1982 =item radius_groups
1983
1984 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1985
1986 =cut
1987
1988 sub radius_groups {
1989   my $self = shift;
1990   if ( $self->usergroup ) {
1991     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1992       unless ref($self->usergroup) eq 'ARRAY';
1993     #when provisioning records, export callback runs in svc_Common.pm before
1994     #radius_usergroup records can be inserted...
1995     @{$self->usergroup};
1996   } else {
1997     map { $_->groupname }
1998       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1999   }
2000 }
2001
2002 =item clone_suspended
2003
2004 Constructor used by FS::part_export::_export_suspend fallback.  Document
2005 better.
2006
2007 =cut
2008
2009 sub clone_suspended {
2010   my $self = shift;
2011   my %hash = $self->hash;
2012   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2013   new FS::svc_acct \%hash;
2014 }
2015
2016 =item clone_kludge_unsuspend
2017
2018 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2019 better.
2020
2021 =cut
2022
2023 sub clone_kludge_unsuspend {
2024   my $self = shift;
2025   my %hash = $self->hash;
2026   $hash{_password} = '';
2027   new FS::svc_acct \%hash;
2028 }
2029
2030 =item check_password
2031
2032 Checks the supplied password against the (possibly encrypted) password in the
2033 database.  Returns true for a successful authentication, false for no match.
2034
2035 Currently supported encryptions are: classic DES crypt() and MD5
2036
2037 =cut
2038
2039 sub check_password {
2040   my($self, $check_password) = @_;
2041
2042   #remove old-style SUSPENDED kludge, they should be allowed to login to
2043   #self-service and pay up
2044   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2045
2046   if ( $self->_password_encoding eq 'ldap' ) {
2047
2048     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2049     return $auth->match($check_password);
2050
2051   } elsif ( $self->_password_encoding eq 'crypt' ) {
2052
2053     my $auth = from_crypt Authen::Passphrase $self->_password;
2054     return $auth->match($check_password);
2055
2056   } elsif ( $self->_password_encoding eq 'plain' ) {
2057
2058     return $check_password eq $password;
2059
2060   } else {
2061
2062     #XXX this could be replaced with Authen::Passphrase stuff
2063
2064     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2065       return 0;
2066     } elsif ( length($password) < 13 ) { #plaintext
2067       $check_password eq $password;
2068     } elsif ( length($password) == 13 ) { #traditional DES crypt
2069       crypt($check_password, $password) eq $password;
2070     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2071       unix_md5_crypt($check_password, $password) eq $password;
2072     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2073       warn "Can't check password: Blowfish encryption not yet supported, ".
2074            "svcnum ".  $self->svcnum. "\n";
2075       0;
2076     } else {
2077       warn "Can't check password: Unrecognized encryption for svcnum ".
2078            $self->svcnum. "\n";
2079       0;
2080     }
2081
2082   }
2083
2084 }
2085
2086 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2087
2088 Returns an encrypted password, either by passing through an encrypted password
2089 in the database or by encrypting a plaintext password from the database.
2090
2091 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2092 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2093 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2094 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2095 encryption type is only used if the password is not already encrypted in the
2096 database.
2097
2098 =cut
2099
2100 sub crypt_password {
2101   my $self = shift;
2102
2103   if ( $self->_password_encoding eq 'ldap' ) {
2104
2105     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2106       my $plain = $2;
2107
2108       #XXX this could be replaced with Authen::Passphrase stuff
2109
2110       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2111       if ( $encryption eq 'crypt' ) {
2112         crypt(
2113           $self->_password,
2114           $saltset[int(rand(64))].$saltset[int(rand(64))]
2115         );
2116       } elsif ( $encryption eq 'md5' ) {
2117         unix_md5_crypt( $self->_password );
2118       } elsif ( $encryption eq 'blowfish' ) {
2119         croak "unknown encryption method $encryption";
2120       } else {
2121         croak "unknown encryption method $encryption";
2122       }
2123
2124     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2125       $1;
2126     }
2127
2128   } elsif ( $self->_password_encoding eq 'crypt' ) {
2129
2130     return $self->_password;
2131
2132   } elsif ( $self->_password_encoding eq 'plain' ) {
2133
2134     #XXX this could be replaced with Authen::Passphrase stuff
2135
2136     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2137     if ( $encryption eq 'crypt' ) {
2138       crypt(
2139         $self->_password,
2140         $saltset[int(rand(64))].$saltset[int(rand(64))]
2141       );
2142     } elsif ( $encryption eq 'md5' ) {
2143       unix_md5_crypt( $self->_password );
2144     } elsif ( $encryption eq 'blowfish' ) {
2145       croak "unknown encryption method $encryption";
2146     } else {
2147       croak "unknown encryption method $encryption";
2148     }
2149
2150   } else {
2151
2152     if ( length($self->_password) == 13
2153          || $self->_password =~ /^\$(1|2a?)\$/
2154          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2155        )
2156     {
2157       $self->_password;
2158     } else {
2159
2160       #XXX this could be replaced with Authen::Passphrase stuff
2161
2162       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2163       if ( $encryption eq 'crypt' ) {
2164         crypt(
2165           $self->_password,
2166           $saltset[int(rand(64))].$saltset[int(rand(64))]
2167         );
2168       } elsif ( $encryption eq 'md5' ) {
2169         unix_md5_crypt( $self->_password );
2170       } elsif ( $encryption eq 'blowfish' ) {
2171         croak "unknown encryption method $encryption";
2172       } else {
2173         croak "unknown encryption method $encryption";
2174       }
2175
2176     }
2177
2178   }
2179
2180 }
2181
2182 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2183
2184 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2185 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2186 "{MD5}5426824942db4253f87a1009fd5d2d4".
2187
2188 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2189 to work the same as the B</crypt_password> method.
2190
2191 =cut
2192
2193 sub ldap_password {
2194   my $self = shift;
2195   #eventually should check a "password-encoding" field
2196
2197   if ( $self->_password_encoding eq 'ldap' ) {
2198
2199     return $self->_password;
2200
2201   } elsif ( $self->_password_encoding eq 'crypt' ) {
2202
2203     if ( length($self->_password) == 13 ) { #crypt
2204       return '{CRYPT}'. $self->_password;
2205     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2206       return '{MD5}'. $1;
2207     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2208     #  die "Blowfish encryption not supported in this context, svcnum ".
2209     #      $self->svcnum. "\n";
2210     } else {
2211       warn "encryption method not (yet?) supported in LDAP context";
2212       return '{CRYPT}*'; #unsupported, should not auth
2213     }
2214
2215   } elsif ( $self->_password_encoding eq 'plain' ) {
2216
2217     return '{PLAIN}'. $self->_password;
2218
2219     #return '{CLEARTEXT}'. $self->_password; #?
2220
2221   } else {
2222
2223     if ( length($self->_password) == 13 ) { #crypt
2224       return '{CRYPT}'. $self->_password;
2225     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2226       return '{MD5}'. $1;
2227     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2228       warn "Blowfish encryption not supported in this context, svcnum ".
2229           $self->svcnum. "\n";
2230       return '{CRYPT}*';
2231
2232     #are these two necessary anymore?
2233     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2234       return '{SSHA}'. $1;
2235     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2236       return '{NS-MTA-MD5}'. $1;
2237
2238     } else { #plaintext
2239       return '{PLAIN}'. $self->_password;
2240
2241       #return '{CLEARTEXT}'. $self->_password; #?
2242
2243       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2244       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2245       #if ( $encryption eq 'crypt' ) {
2246       #  return '{CRYPT}'. crypt(
2247       #    $self->_password,
2248       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2249       #  );
2250       #} elsif ( $encryption eq 'md5' ) {
2251       #  unix_md5_crypt( $self->_password );
2252       #} elsif ( $encryption eq 'blowfish' ) {
2253       #  croak "unknown encryption method $encryption";
2254       #} else {
2255       #  croak "unknown encryption method $encryption";
2256       #}
2257     }
2258
2259   }
2260
2261 }
2262
2263 =item domain_slash_username
2264
2265 Returns $domain/$username/
2266
2267 =cut
2268
2269 sub domain_slash_username {
2270   my $self = shift;
2271   $self->domain. '/'. $self->username. '/';
2272 }
2273
2274 =item virtual_maildir
2275
2276 Returns $domain/maildirs/$username/
2277
2278 =cut
2279
2280 sub virtual_maildir {
2281   my $self = shift;
2282   $self->domain. '/maildirs/'. $self->username. '/';
2283 }
2284
2285 =back
2286
2287 =head1 SUBROUTINES
2288
2289 =over 4
2290
2291 =item send_email
2292
2293 This is the FS::svc_acct job-queue-able version.  It still uses
2294 FS::Misc::send_email under-the-hood.
2295
2296 =cut
2297
2298 sub send_email {
2299   my %opt = @_;
2300
2301   eval "use FS::Misc qw(send_email)";
2302   die $@ if $@;
2303
2304   $opt{mimetype} ||= 'text/plain';
2305   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2306
2307   my $error = send_email(
2308     'from'         => $opt{from},
2309     'to'           => $opt{to},
2310     'subject'      => $opt{subject},
2311     'content-type' => $opt{mimetype},
2312     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2313   );
2314   die $error if $error;
2315 }
2316
2317 =item check_and_rebuild_fuzzyfiles
2318
2319 =cut
2320
2321 sub check_and_rebuild_fuzzyfiles {
2322   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2323   -e "$dir/svc_acct.username"
2324     or &rebuild_fuzzyfiles;
2325 }
2326
2327 =item rebuild_fuzzyfiles
2328
2329 =cut
2330
2331 sub rebuild_fuzzyfiles {
2332
2333   use Fcntl qw(:flock);
2334
2335   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2336
2337   #username
2338
2339   open(USERNAMELOCK,">>$dir/svc_acct.username")
2340     or die "can't open $dir/svc_acct.username: $!";
2341   flock(USERNAMELOCK,LOCK_EX)
2342     or die "can't lock $dir/svc_acct.username: $!";
2343
2344   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2345
2346   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2347     or die "can't open $dir/svc_acct.username.tmp: $!";
2348   print USERNAMECACHE join("\n", @all_username), "\n";
2349   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2350
2351   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2352   close USERNAMELOCK;
2353
2354 }
2355
2356 =item all_username
2357
2358 =cut
2359
2360 sub all_username {
2361   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2362   open(USERNAMECACHE,"<$dir/svc_acct.username")
2363     or die "can't open $dir/svc_acct.username: $!";
2364   my @array = map { chomp; $_; } <USERNAMECACHE>;
2365   close USERNAMECACHE;
2366   \@array;
2367 }
2368
2369 =item append_fuzzyfiles USERNAME
2370
2371 =cut
2372
2373 sub append_fuzzyfiles {
2374   my $username = shift;
2375
2376   &check_and_rebuild_fuzzyfiles;
2377
2378   use Fcntl qw(:flock);
2379
2380   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2381
2382   open(USERNAME,">>$dir/svc_acct.username")
2383     or die "can't open $dir/svc_acct.username: $!";
2384   flock(USERNAME,LOCK_EX)
2385     or die "can't lock $dir/svc_acct.username: $!";
2386
2387   print USERNAME "$username\n";
2388
2389   flock(USERNAME,LOCK_UN)
2390     or die "can't unlock $dir/svc_acct.username: $!";
2391   close USERNAME;
2392
2393   1;
2394 }
2395
2396
2397
2398 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2399
2400 =cut
2401
2402 sub radius_usergroup_selector {
2403   my $sel_groups = shift;
2404   my %sel_groups = map { $_=>1 } @$sel_groups;
2405
2406   my $selectname = shift || 'radius_usergroup';
2407
2408   my $dbh = dbh;
2409   my $sth = $dbh->prepare(
2410     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2411   ) or die $dbh->errstr;
2412   $sth->execute() or die $sth->errstr;
2413   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2414
2415   my $html = <<END;
2416     <SCRIPT>
2417     function ${selectname}_doadd(object) {
2418       var myvalue = object.${selectname}_add.value;
2419       var optionName = new Option(myvalue,myvalue,false,true);
2420       var length = object.$selectname.length;
2421       object.$selectname.options[length] = optionName;
2422       object.${selectname}_add.value = "";
2423     }
2424     </SCRIPT>
2425     <SELECT MULTIPLE NAME="$selectname">
2426 END
2427
2428   foreach my $group ( @all_groups ) {
2429     $html .= qq(<OPTION VALUE="$group");
2430     if ( $sel_groups{$group} ) {
2431       $html .= ' SELECTED';
2432       $sel_groups{$group} = 0;
2433     }
2434     $html .= ">$group</OPTION>\n";
2435   }
2436   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2437     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2438   };
2439   $html .= '</SELECT>';
2440
2441   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2442            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2443
2444   $html;
2445 }
2446
2447 =item reached_threshold
2448
2449 Performs some activities when svc_acct thresholds (such as number of seconds
2450 remaining) are reached.
2451
2452 =cut
2453
2454 sub reached_threshold {
2455   my %opt = @_;
2456
2457   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2458   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2459
2460   if ( $opt{'op'} eq '+' ){
2461     $svc_acct->setfield( $opt{'column'}.'_threshold',
2462                          int($svc_acct->getfield($opt{'column'})
2463                              * ( $conf->exists('svc_acct-usage_threshold')
2464                                  ? $conf->config('svc_acct-usage_threshold')/100
2465                                  : 0.80
2466                                )
2467                          )
2468                        );
2469     my $error = $svc_acct->replace;
2470     die $error if $error;
2471   }elsif ( $opt{'op'} eq '-' ){
2472
2473     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2474     return '' if ($threshold eq '' );
2475
2476     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2477     my $error = $svc_acct->replace;
2478     die $error if $error; # email next time, i guess
2479
2480     if ( $warning_template ) {
2481       eval "use FS::Misc qw(send_email)";
2482       die $@ if $@;
2483
2484       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2485       my $cust_main = $cust_pkg->cust_main;
2486
2487       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2488                                $cust_main->invoicing_list,
2489                                ($opt{'to'} ? $opt{'to'} : ())
2490                    );
2491
2492       my $mimetype = $warning_mimetype;
2493       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2494
2495       my $body       =  $warning_template->fill_in( HASH => {
2496                         'custnum'   => $cust_main->custnum,
2497                         'username'  => $svc_acct->username,
2498                         'password'  => $svc_acct->_password,
2499                         'first'     => $cust_main->first,
2500                         'last'      => $cust_main->getfield('last'),
2501                         'pkg'       => $cust_pkg->part_pkg->pkg,
2502                         'column'    => $opt{'column'},
2503                         'amount'    => $opt{'column'} =~/bytes/
2504                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2505                                        : $svc_acct->getfield($opt{'column'}),
2506                         'threshold' => $opt{'column'} =~/bytes/
2507                                        ? FS::UI::bytecount::display_bytecount($threshold)
2508                                        : $threshold,
2509                       } );
2510
2511
2512       my $error = send_email(
2513         'from'         => $warning_from,
2514         'to'           => $to,
2515         'subject'      => $warning_subject,
2516         'content-type' => $mimetype,
2517         'body'         => [ map "$_\n", split("\n", $body) ],
2518       );
2519       die $error if $error;
2520     }
2521   }else{
2522     die "unknown op: " . $opt{'op'};
2523   }
2524 }
2525
2526 =back
2527
2528 =head1 BUGS
2529
2530 The $recref stuff in sub check should be cleaned up.
2531
2532 The suspend, unsuspend and cancel methods update the database, but not the
2533 current object.  This is probably a bug as it's unexpected and
2534 counterintuitive.
2535
2536 radius_usergroup_selector?  putting web ui components in here?  they should
2537 probably live somewhere else...
2538
2539 insertion of RADIUS group stuff in insert could be done with child_objects now
2540 (would probably clean up export of them too)
2541
2542 =head1 SEE ALSO
2543
2544 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2545 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2546 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2547 L<freeside-queued>), L<FS::svc_acct_pop>,
2548 schema.html from the base documentation.
2549
2550 =cut
2551
2552 1;
2553