FS/FS/svc_acct.pm

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