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