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