FS/FS/svc_acct.pm

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