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