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