FS/FS/svc_acct.pm

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