FS/FS/svc_acct.pm

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