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