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