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