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') =~ /^([\w \,\.\-\'\&]+)$/
1373       or return "Illegal finger: ". $self->getfield('finger');
1374   $self->setfield('finger', $1);
1375
1376   for (qw( quota file_quota file_maxsize )) {
1377     $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1378     $recref->{$_} = $1;
1379   }
1380   $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1381   $recref->{file_maxnum} = $1;
1382
1383   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1384     if ( $recref->{slipip} eq '' ) {
1385       $recref->{slipip} = '';
1386     } elsif ( $recref->{slipip} eq '0e0' ) {
1387       $recref->{slipip} = '0e0';
1388     } else {
1389       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1390         or return "Illegal slipip: ". $self->slipip;
1391       $recref->{slipip} = $1;
1392     }
1393
1394   }
1395
1396   #arbitrary RADIUS stuff; allow ut_textn for now
1397   foreach ( grep /^radius_/, fields('svc_acct') ) {
1398     $self->ut_textn($_);
1399   }
1400
1401   # First, if _password is blank, generate one and set default encoding.
1402   if ( ! $recref->{_password} ) {
1403     $error = $self->set_password('');
1404   }
1405   # But if there's a _password but no encoding, assume it's plaintext and
1406   # set it to default encoding.
1407   elsif ( ! $recref->{_password_encoding} ) {
1408     $error = $self->set_password($recref->{_password});
1409   }
1410   return $error if $error;
1411
1412   # Next, check _password to ensure compliance with the encoding.
1413   if ( $recref->{_password_encoding} eq 'ldap' ) {
1414
1415     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1416       $recref->{_password} = uc($1).$2;
1417     } else {
1418       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1419     }
1420
1421   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1422
1423     if ( $recref->{_password} =~
1424            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1425            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1426        ) {
1427
1428       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1429
1430     } else {
1431       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1432     }
1433
1434   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1435     # Password randomization is now in set_password.
1436     # Strip whitespace characters, check length requirements, etc.
1437     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1438       $recref->{_password} = $1;
1439     } else {
1440       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1441              FS::Msgcat::_gettext('illegal_password_characters').
1442              ": ". $recref->{_password};
1443     }
1444
1445     if ( $password_noampersand ) {
1446       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1447     }
1448     if ( $password_noexclamation ) {
1449       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1450     }
1451   }
1452   else {
1453     return "invalid password encoding ('".$recref->{_password_encoding}."'";
1454   }
1455   $self->SUPER::check;
1456
1457 }
1458
1459
1460 sub _password_encryption {
1461   my $self = shift;
1462   my $encoding = lc($self->_password_encoding);
1463   return if !$encoding;
1464   return 'plain' if $encoding eq 'plain';
1465   if($encoding eq 'crypt') {
1466     my $pass = $self->_password;
1467     $pass =~ s/^\*SUSPENDED\* //;
1468     $pass =~ s/^!!?//;
1469     return 'md5' if $pass =~ /^\$1\$/;
1470     #return 'blowfish' if $self->_password =~ /^\$2\$/;
1471     return 'des' if length($pass) == 13;
1472     return;
1473   }
1474   if($encoding eq 'ldap') {
1475     uc($self->_password) =~ /^\{([\w-]+)\}/;
1476     return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1477     return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1478     return 'md5' if $1 eq 'MD5';
1479     return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1480
1481     return;
1482   }
1483   return;
1484 }
1485
1486 sub get_cleartext_password {
1487   my $self = shift;
1488   if($self->_password_encryption eq 'plain') {
1489     if($self->_password_encoding eq 'ldap') {
1490       $self->_password =~ /\{\w+\}(.*)$/;
1491       return $1;
1492     }
1493     else {
1494       return $self->_password;
1495     }
1496   }
1497   return;
1498 }
1499
1500
1501 =item set_password
1502
1503 Set the cleartext password for the account.  If _password_encoding is set, the
1504 new password will be encoded according to the existing method (including
1505 encryption mode, if it can be determined).  Otherwise,
1506 config('default-password-encoding') is used.
1507
1508 If no password is supplied (or a zero-length password when minimum password length
1509 is >0), one will be generated randomly.
1510
1511 =cut
1512
1513 sub set_password {
1514   my( $self, $pass ) = ( shift, shift );
1515
1516   warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1517      if $DEBUG;
1518
1519   my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1520                 FS::Msgcat::_gettext('illegal_password_characters').
1521                 ": ". $pass;
1522
1523   my( $encoding, $encryption ) = ('', '');
1524
1525   if ( $self->_password_encoding ) {
1526     $encoding = $self->_password_encoding;
1527     # identify existing encryption method, try to use it.
1528     $encryption = $self->_password_encryption;
1529     if (!$encryption) {
1530       # use the system default
1531       undef $encoding;
1532     }
1533   }
1534
1535   if ( !$encoding ) {
1536     # set encoding to system default
1537     ($encoding, $encryption) =
1538       split(/-/, lc($conf->config('default-password-encoding')));
1539     $encoding ||= 'legacy';
1540     $self->_password_encoding($encoding);
1541   }
1542
1543   if ( $encoding eq 'legacy' ) {
1544
1545     # The legacy behavior from check():
1546     # If the password is blank, randomize it and set encoding to 'plain'.
1547     if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1548       $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1549       $self->_password_encoding('plain');
1550     } else {
1551       # Prefix + valid-length password
1552       if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1553         $pass = $1.$3;
1554         $self->_password_encoding('plain');
1555       # Prefix + crypt string
1556       } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1557         $pass = $1.$3;
1558         $self->_password_encoding('crypt');
1559       # Various disabled crypt passwords
1560       } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1561         $self->_password_encoding('crypt');
1562       } else {
1563         return $failure;
1564       }
1565     }
1566
1567     $self->_password($pass);
1568     return;
1569
1570   }
1571
1572   return $failure
1573     if $passwordmin && length($pass) < $passwordmin
1574     or $passwordmax && length($pass) > $passwordmax;
1575
1576   if ( $encoding eq 'crypt' ) {
1577     if ($encryption eq 'md5') {
1578       $pass = unix_md5_crypt($pass);
1579     } elsif ($encryption eq 'des') {
1580       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1581     }
1582
1583   } elsif ( $encoding eq 'ldap' ) {
1584     if ($encryption eq 'md5') {
1585       $pass = md5_base64($pass);
1586     } elsif ($encryption eq 'sha1') {
1587       $pass = sha1_base64($pass);
1588     } elsif ($encryption eq 'crypt') {
1589       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1590     }
1591     # else $encryption eq 'plain', do nothing
1592     $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1593       if $encryption eq 'md5' || $encryption eq 'sha1';
1594     $pass = '{'.uc($encryption).'}'.$pass;
1595   }
1596   # else encoding eq 'plain'
1597
1598   $self->_password($pass);
1599   return;
1600 }
1601
1602 =item _check_system
1603
1604 Internal function to check the username against the list of system usernames
1605 from the I<system_usernames> configuration value.  Returns true if the username
1606 is listed on the system username list.
1607
1608 =cut
1609
1610 sub _check_system {
1611   my $self = shift;
1612   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1613                $conf->config('system_usernames')
1614         );
1615 }
1616
1617 =item _check_duplicate
1618
1619 Internal method to check for duplicates usernames, username@domain pairs and
1620 uids.
1621
1622 If the I<global_unique-username> configuration value is set to B<username> or
1623 B<username@domain>, enforces global username or username@domain uniqueness.
1624
1625 In all cases, check for duplicate uids and usernames or username@domain pairs
1626 per export and with identical I<svcpart> values.
1627
1628 =cut
1629
1630 sub _check_duplicate {
1631   my $self = shift;
1632
1633   my $global_unique = $conf->config('global_unique-username') || 'none';
1634   return '' if $global_unique eq 'disabled';
1635
1636   $self->lock_table;
1637
1638   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1639   unless ( $part_svc ) {
1640     return 'unknown svcpart '. $self->svcpart;
1641   }
1642
1643   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1644                  qsearch( 'svc_acct', { 'username' => $self->username } );
1645   return gettext('username_in_use')
1646     if $global_unique eq 'username' && @dup_user;
1647
1648   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1649                        qsearch( 'svc_acct', { 'username' => $self->username,
1650                                               'domsvc'   => $self->domsvc } );
1651   return gettext('username_in_use')
1652     if $global_unique eq 'username@domain' && @dup_userdomain;
1653
1654   my @dup_uid;
1655   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1656        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1657     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1658                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1659   } else {
1660     @dup_uid = ();
1661   }
1662
1663   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1664     my $exports = FS::part_export::export_info('svc_acct');
1665     my %conflict_user_svcpart;
1666     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1667
1668     foreach my $part_export ( $part_svc->part_export ) {
1669
1670       #this will catch to the same exact export
1671       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1672
1673       #this will catch to exports w/same exporthost+type ???
1674       #my @other_part_export = qsearch('part_export', {
1675       #  'machine'    => $part_export->machine,
1676       #  'exporttype' => $part_export->exporttype,
1677       #} );
1678       #foreach my $other_part_export ( @other_part_export ) {
1679       #  push @svcparts, map { $_->svcpart }
1680       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1681       #}
1682
1683       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1684       #silly kludge to avoid uninitialized value errors
1685       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1686                      ? $exports->{$part_export->exporttype}{'nodomain'}
1687                      : '';
1688       if ( $nodomain =~ /^Y/i ) {
1689         $conflict_user_svcpart{$_} = $part_export->exportnum
1690           foreach @svcparts;
1691       } else {
1692         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1693           foreach @svcparts;
1694       }
1695     }
1696
1697     foreach my $dup_user ( @dup_user ) {
1698       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1699       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1700         return "duplicate username ". $self->username.
1701                ": conflicts with svcnum ". $dup_user->svcnum.
1702                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1703       }
1704     }
1705
1706     foreach my $dup_userdomain ( @dup_userdomain ) {
1707       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1708       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1709         return "duplicate username\@domain ". $self->email.
1710                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1711                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1712       }
1713     }
1714
1715     foreach my $dup_uid ( @dup_uid ) {
1716       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1717       if ( exists($conflict_user_svcpart{$dup_svcpart})
1718            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1719         return "duplicate uid ". $self->uid.
1720                ": conflicts with svcnum ". $dup_uid->svcnum.
1721                " via exportnum ".
1722                ( $conflict_user_svcpart{$dup_svcpart}
1723                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1724       }
1725     }
1726
1727   }
1728
1729   return '';
1730
1731 }
1732
1733 =item radius
1734
1735 Depriciated, use radius_reply instead.
1736
1737 =cut
1738
1739 sub radius {
1740   carp "FS::svc_acct::radius depriciated, use radius_reply";
1741   $_[0]->radius_reply;
1742 }
1743
1744 =item radius_reply
1745
1746 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1747 reply attributes of this record.
1748
1749 Note that this is now the preferred method for reading RADIUS attributes -
1750 accessing the columns directly is discouraged, as the column names are
1751 expected to change in the future.
1752
1753 =cut
1754
1755 sub radius_reply {
1756   my $self = shift;
1757
1758   return %{ $self->{'radius_reply'} }
1759     if exists $self->{'radius_reply'};
1760
1761   my %reply =
1762     map {
1763       /^(radius_(.*))$/;
1764       my($column, $attrib) = ($1, $2);
1765       #$attrib =~ s/_/\-/g;
1766       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1767     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1768
1769   if ( $self->slipip && $self->slipip ne '0e0' ) {
1770     $reply{$radius_ip} = $self->slipip;
1771   }
1772
1773   if ( $self->seconds !~ /^$/ ) {
1774     $reply{'Session-Timeout'} = $self->seconds;
1775   }
1776
1777   if ( $conf->exists('radius-chillispot-max') ) {
1778     #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1779
1780     #hmm.  just because sqlradius.pm says so?
1781     my %whatis = (
1782       'input'  => 'up',
1783       'output' => 'down',
1784       'total'  => 'total',
1785     );
1786
1787     foreach my $what (qw( input output total )) {
1788       my $is = $whatis{$what}.'bytes';
1789       if ( $self->$is() =~ /\d/ ) {
1790         my $big = new Math::BigInt $self->$is();
1791         $big = new Math::BigInt '0' if $big->is_neg();
1792         my $att = "Chillispot-Max-\u$what";
1793         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1794         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1795       }
1796     }
1797
1798   }
1799
1800   %reply;
1801 }
1802
1803 =item radius_check
1804
1805 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1806 check attributes of this record.
1807
1808 Note that this is now the preferred method for reading RADIUS attributes -
1809 accessing the columns directly is discouraged, as the column names are
1810 expected to change in the future.
1811
1812 =cut
1813
1814 sub radius_check {
1815   my $self = shift;
1816
1817   return %{ $self->{'radius_check'} }
1818     if exists $self->{'radius_check'};
1819
1820   my %check =
1821     map {
1822       /^(rc_(.*))$/;
1823       my($column, $attrib) = ($1, $2);
1824       #$attrib =~ s/_/\-/g;
1825       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1826     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1827
1828
1829   my($pw_attrib, $password) = $self->radius_password;
1830   $check{$pw_attrib} = $password;
1831
1832   my $cust_svc = $self->cust_svc;
1833   if ( $cust_svc ) {
1834     my $cust_pkg = $cust_svc->cust_pkg;
1835     if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1836       $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1837     }
1838   } else {
1839     warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1840          "; can't set Expiration\n"
1841       unless $cust_svc;
1842   }
1843
1844   %check;
1845
1846 }
1847
1848 =item radius_password
1849
1850 Returns a key/value pair containing the RADIUS attribute name and value
1851 for the password.
1852
1853 =cut
1854
1855 sub radius_password {
1856   my $self = shift;
1857
1858   my $pw_attrib;
1859   if ( $self->_password_encoding eq 'ldap' ) {
1860     $pw_attrib = 'Password-With-Header';
1861   } elsif ( $self->_password_encoding eq 'crypt' ) {
1862     $pw_attrib = 'Crypt-Password';
1863   } elsif ( $self->_password_encoding eq 'plain' ) {
1864     $pw_attrib = $radius_password;
1865   } else {
1866     $pw_attrib = length($self->_password) <= 12
1867                    ? $radius_password
1868                    : 'Crypt-Password';
1869   }
1870
1871   ($pw_attrib, $self->_password);
1872
1873 }
1874
1875 =item snapshot
1876
1877 This method instructs the object to "snapshot" or freeze RADIUS check and
1878 reply attributes to the current values.
1879
1880 =cut
1881
1882 #bah, my english is too broken this morning
1883 #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
1884 #the FS::cust_pkg's replace method to trigger the correct export updates when
1885 #package dates change)
1886
1887 sub snapshot {
1888   my $self = shift;
1889
1890   $self->{$_} = { $self->$_() }
1891     foreach qw( radius_reply radius_check );
1892
1893 }
1894
1895 =item forget_snapshot
1896
1897 This methos instructs the object to forget any previously snapshotted
1898 RADIUS check and reply attributes.
1899
1900 =cut
1901
1902 sub forget_snapshot {
1903   my $self = shift;
1904
1905   delete $self->{$_}
1906     foreach qw( radius_reply radius_check );
1907
1908 }
1909
1910 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1911
1912 Returns the domain associated with this account.
1913
1914 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1915 history records.
1916
1917 =cut
1918
1919 sub domain {
1920   my $self = shift;
1921   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1922   my $svc_domain = $self->svc_domain(@_)
1923     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1924   $svc_domain->domain;
1925 }
1926
1927 =item cust_svc
1928
1929 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1930
1931 =cut
1932
1933 #inherited from svc_Common
1934
1935 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1936
1937 Returns an email address associated with the account.
1938
1939 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1940 history records.
1941
1942 =cut
1943
1944 sub email {
1945   my $self = shift;
1946   $self->username. '@'. $self->domain(@_);
1947 }
1948
1949 =item acct_snarf
1950
1951 Returns an array of FS::acct_snarf records associated with the account.
1952
1953 =cut
1954
1955 sub acct_snarf {
1956   my $self = shift;
1957   qsearch({
1958     'table'    => 'acct_snarf',
1959     'hashref'  => { 'svcnum' => $self->svcnum },
1960     #'order_by' => 'ORDER BY priority ASC',
1961   });
1962 }
1963
1964 =item cgp_rpop_hashref
1965
1966 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1967
1968 =cut
1969
1970 sub cgp_rpop_hashref {
1971   my $self = shift;
1972   { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1973 }
1974
1975 =item decrement_upbytes OCTETS
1976
1977 Decrements the I<upbytes> field of this record by the given amount.  If there
1978 is an error, returns the error, otherwise returns false.
1979
1980 =cut
1981
1982 sub decrement_upbytes {
1983   shift->_op_usage('-', 'upbytes', @_);
1984 }
1985
1986 =item increment_upbytes OCTETS
1987
1988 Increments the I<upbytes> field of this record by the given amount.  If there
1989 is an error, returns the error, otherwise returns false.
1990
1991 =cut
1992
1993 sub increment_upbytes {
1994   shift->_op_usage('+', 'upbytes', @_);
1995 }
1996
1997 =item decrement_downbytes OCTETS
1998
1999 Decrements the I<downbytes> field of this record by the given amount.  If there
2000 is an error, returns the error, otherwise returns false.
2001
2002 =cut
2003
2004 sub decrement_downbytes {
2005   shift->_op_usage('-', 'downbytes', @_);
2006 }
2007
2008 =item increment_downbytes OCTETS
2009
2010 Increments the I<downbytes> field of this record by the given amount.  If there
2011 is an error, returns the error, otherwise returns false.
2012
2013 =cut
2014
2015 sub increment_downbytes {
2016   shift->_op_usage('+', 'downbytes', @_);
2017 }
2018
2019 =item decrement_totalbytes OCTETS
2020
2021 Decrements the I<totalbytes> field of this record by the given amount.  If there
2022 is an error, returns the error, otherwise returns false.
2023
2024 =cut
2025
2026 sub decrement_totalbytes {
2027   shift->_op_usage('-', 'totalbytes', @_);
2028 }
2029
2030 =item increment_totalbytes OCTETS
2031
2032 Increments the I<totalbytes> field of this record by the given amount.  If there
2033 is an error, returns the error, otherwise returns false.
2034
2035 =cut
2036
2037 sub increment_totalbytes {
2038   shift->_op_usage('+', 'totalbytes', @_);
2039 }
2040
2041 =item decrement_seconds SECONDS
2042
2043 Decrements the I<seconds> field of this record by the given amount.  If there
2044 is an error, returns the error, otherwise returns false.
2045
2046 =cut
2047
2048 sub decrement_seconds {
2049   shift->_op_usage('-', 'seconds', @_);
2050 }
2051
2052 =item increment_seconds SECONDS
2053
2054 Increments the I<seconds> field of this record by the given amount.  If there
2055 is an error, returns the error, otherwise returns false.
2056
2057 =cut
2058
2059 sub increment_seconds {
2060   shift->_op_usage('+', 'seconds', @_);
2061 }
2062
2063
2064 my %op2action = (
2065   '-' => 'suspend',
2066   '+' => 'unsuspend',
2067 );
2068 my %op2condition = (
2069   '-' => sub { my($self, $column, $amount) = @_;
2070                $self->$column - $amount <= 0;
2071              },
2072   '+' => sub { my($self, $column, $amount) = @_;
2073                ($self->$column || 0) + $amount > 0;
2074              },
2075 );
2076 my %op2warncondition = (
2077   '-' => sub { my($self, $column, $amount) = @_;
2078                my $threshold = $column . '_threshold';
2079                $self->$column - $amount <= $self->$threshold + 0;
2080              },
2081   '+' => sub { my($self, $column, $amount) = @_;
2082                ($self->$column || 0) + $amount > 0;
2083              },
2084 );
2085
2086 sub _op_usage {
2087   my( $self, $op, $column, $amount ) = @_;
2088
2089   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2090        ' ('. $self->email. "): $op $amount\n"
2091     if $DEBUG;
2092
2093   return '' unless $amount;
2094
2095   local $SIG{HUP} = 'IGNORE';
2096   local $SIG{INT} = 'IGNORE';
2097   local $SIG{QUIT} = 'IGNORE';
2098   local $SIG{TERM} = 'IGNORE';
2099   local $SIG{TSTP} = 'IGNORE';
2100   local $SIG{PIPE} = 'IGNORE';
2101
2102   my $oldAutoCommit = $FS::UID::AutoCommit;
2103   local $FS::UID::AutoCommit = 0;
2104   my $dbh = dbh;
2105
2106   my $sql = "UPDATE svc_acct SET $column = ".
2107             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2108             " $op ? WHERE svcnum = ?";
2109   warn "$me $sql\n"
2110     if $DEBUG;
2111
2112   my $sth = $dbh->prepare( $sql )
2113     or die "Error preparing $sql: ". $dbh->errstr;
2114   my $rv = $sth->execute($amount, $self->svcnum);
2115   die "Error executing $sql: ". $sth->errstr
2116     unless defined($rv);
2117   die "Can't update $column for svcnum". $self->svcnum
2118     if $rv == 0;
2119
2120   #$self->snapshot; #not necessary, we retain the old values
2121   #create an object with the updated usage values
2122   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2123   #call exports
2124   my $error = $new->replace($self);
2125   if ( $error ) {
2126     $dbh->rollback if $oldAutoCommit;
2127     return "Error replacing: $error";
2128   }
2129
2130   #overlimit_action eq 'cancel' handling
2131   my $cust_pkg = $self->cust_svc->cust_pkg;
2132   if ( $cust_pkg
2133        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2134        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2135      )
2136   {
2137
2138     my $error = $cust_pkg->cancel; #XXX should have a reason
2139     if ( $error ) {
2140       $dbh->rollback if $oldAutoCommit;
2141       return "Error cancelling: $error";
2142     }
2143
2144     #nothing else is relevant if we're cancelling, so commit & return success
2145     warn "$me update successful; committing\n"
2146       if $DEBUG;
2147     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2148     return '';
2149
2150   }
2151
2152   my $action = $op2action{$op};
2153
2154   if ( &{$op2condition{$op}}($self, $column, $amount) &&
2155         ( $action eq 'suspend'   && !$self->overlimit
2156        || $action eq 'unsuspend' &&  $self->overlimit )
2157      ) {
2158
2159     my $error = $self->_op_overlimit($action);
2160     if ( $error ) {
2161       $dbh->rollback if $oldAutoCommit;
2162       return $error;
2163     }
2164
2165   }
2166
2167   if ( $conf->exists("svc_acct-usage_$action")
2168        && &{$op2condition{$op}}($self, $column, $amount)    ) {
2169     #my $error = $self->$action();
2170     my $error = $self->cust_svc->cust_pkg->$action();
2171     # $error ||= $self->overlimit($action);
2172     if ( $error ) {
2173       $dbh->rollback if $oldAutoCommit;
2174       return "Error ${action}ing: $error";
2175     }
2176   }
2177
2178   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2179     my $wqueue = new FS::queue {
2180       'svcnum' => $self->svcnum,
2181       'job'    => 'FS::svc_acct::reached_threshold',
2182     };
2183
2184     my $to = '';
2185     if ($op eq '-'){
2186       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2187     }
2188
2189     # x_threshold race
2190     my $error = $wqueue->insert(
2191       'svcnum' => $self->svcnum,
2192       'op'     => $op,
2193       'column' => $column,
2194       'to'     => $to,
2195     );
2196     if ( $error ) {
2197       $dbh->rollback if $oldAutoCommit;
2198       return "Error queuing threshold activity: $error";
2199     }
2200   }
2201
2202   warn "$me update successful; committing\n"
2203     if $DEBUG;
2204   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2205   '';
2206
2207 }
2208
2209 sub _op_overlimit {
2210   my( $self, $action ) = @_;
2211
2212   local $SIG{HUP} = 'IGNORE';
2213   local $SIG{INT} = 'IGNORE';
2214   local $SIG{QUIT} = 'IGNORE';
2215   local $SIG{TERM} = 'IGNORE';
2216   local $SIG{TSTP} = 'IGNORE';
2217   local $SIG{PIPE} = 'IGNORE';
2218
2219   my $oldAutoCommit = $FS::UID::AutoCommit;
2220   local $FS::UID::AutoCommit = 0;
2221   my $dbh = dbh;
2222
2223   my $cust_pkg = $self->cust_svc->cust_pkg;
2224
2225   my $conf_overlimit =
2226     $cust_pkg
2227       ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2228       : $conf->config('overlimit_groups');
2229
2230   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2231
2232     my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2233     next unless $groups;
2234
2235     my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2236
2237     my $other = new FS::svc_acct $self->hashref;
2238     $other->usergroup( $gref );
2239
2240     my($new,$old);
2241     if ($action eq 'suspend') {
2242       $new = $other;
2243       $old = $self;
2244     } else { # $action eq 'unsuspend'
2245       $new = $self;
2246       $old = $other;
2247     }
2248
2249     my $error = $part_export->export_replace($new, $old)
2250                 || $self->overlimit($action);
2251
2252     if ( $error ) {
2253       $dbh->rollback if $oldAutoCommit;
2254       return "Error replacing radius groups: $error";
2255     }
2256
2257   }
2258
2259   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2260   '';
2261
2262 }
2263
2264 sub set_usage {
2265   my( $self, $valueref, %options ) = @_;
2266
2267   warn "$me set_usage called for svcnum ". $self->svcnum.
2268        ' ('. $self->email. "): ".
2269        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2270     if $DEBUG;
2271
2272   local $SIG{HUP} = 'IGNORE';
2273   local $SIG{INT} = 'IGNORE';
2274   local $SIG{QUIT} = 'IGNORE';
2275   local $SIG{TERM} = 'IGNORE';
2276   local $SIG{TSTP} = 'IGNORE';
2277   local $SIG{PIPE} = 'IGNORE';
2278
2279   local $FS::svc_Common::noexport_hack = 1;
2280   my $oldAutoCommit = $FS::UID::AutoCommit;
2281   local $FS::UID::AutoCommit = 0;
2282   my $dbh = dbh;
2283
2284   my $reset = 0;
2285   my %handyhash = ();
2286   if ( $options{null} ) {
2287     %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2288                    qw( seconds upbytes downbytes totalbytes )
2289                  );
2290   }
2291   foreach my $field (keys %$valueref){
2292     $reset = 1 if $valueref->{$field};
2293     $self->setfield($field, $valueref->{$field});
2294     $self->setfield( $field.'_threshold',
2295                      int($self->getfield($field)
2296                          * ( $conf->exists('svc_acct-usage_threshold')
2297                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
2298                              : 0.20
2299                            )
2300                        )
2301                      );
2302     $handyhash{$field} = $self->getfield($field);
2303     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2304   }
2305   #my $error = $self->replace;   #NO! we avoid the call to ->check for
2306   #die $error if $error;         #services not explicity changed via the UI
2307
2308   my $sql = "UPDATE svc_acct SET " .
2309     join (',', map { "$_ =  ?" } (keys %handyhash) ).
2310     " WHERE svcnum = ". $self->svcnum;
2311
2312   warn "$me $sql\n"
2313     if $DEBUG;
2314
2315   if (scalar(keys %handyhash)) {
2316     my $sth = $dbh->prepare( $sql )
2317       or die "Error preparing $sql: ". $dbh->errstr;
2318     my $rv = $sth->execute(values %handyhash);
2319     die "Error executing $sql: ". $sth->errstr
2320       unless defined($rv);
2321     die "Can't update usage for svcnum ". $self->svcnum
2322       if $rv == 0;
2323   }
2324
2325   #$self->snapshot; #not necessary, we retain the old values
2326   #create an object with the updated usage values
2327   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2328   local($FS::Record::nowarn_identical) = 1;
2329   my $error = $new->replace($self); #call exports
2330   if ( $error ) {
2331     $dbh->rollback if $oldAutoCommit;
2332     return "Error replacing: $error";
2333   }
2334
2335   if ( $reset ) {
2336
2337     my $error = '';
2338
2339     $error = $self->_op_overlimit('unsuspend')
2340       if $self->overlimit;;
2341
2342     $error ||= $self->cust_svc->cust_pkg->unsuspend
2343       if $conf->exists("svc_acct-usage_unsuspend");
2344
2345     if ( $error ) {
2346       $dbh->rollback if $oldAutoCommit;
2347       return "Error unsuspending: $error";
2348     }
2349
2350   }
2351
2352   warn "$me update successful; committing\n"
2353     if $DEBUG;
2354   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2355   '';
2356
2357 }
2358
2359
2360 =item recharge HASHREF
2361
2362   Increments usage columns by the amount specified in HASHREF as
2363   column=>amount pairs.
2364
2365 =cut
2366
2367 sub recharge {
2368   my ($self, $vhash) = @_;
2369
2370   if ( $DEBUG ) {
2371     warn "[$me] recharge called on $self: ". Dumper($self).
2372          "\nwith vhash: ". Dumper($vhash);
2373   }
2374
2375   my $oldAutoCommit = $FS::UID::AutoCommit;
2376   local $FS::UID::AutoCommit = 0;
2377   my $dbh = dbh;
2378   my $error = '';
2379
2380   foreach my $column (keys %$vhash){
2381     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2382   }
2383
2384   if ( $error ) {
2385     $dbh->rollback if $oldAutoCommit;
2386   }else{
2387     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2388   }
2389   return $error;
2390 }
2391
2392 =item is_rechargeable
2393
2394 Returns true if this svc_account can be "recharged" and false otherwise.
2395
2396 =cut
2397
2398 sub is_rechargable {
2399   my $self = shift;
2400   $self->seconds ne ''
2401     || $self->upbytes ne ''
2402     || $self->downbytes ne ''
2403     || $self->totalbytes ne '';
2404 }
2405
2406 =item seconds_since TIMESTAMP
2407
2408 Returns the number of seconds this account has been online since TIMESTAMP,
2409 according to the session monitor (see L<FS::Session>).
2410
2411 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2412 L<Time::Local> and L<Date::Parse> for conversion functions.
2413
2414 =cut
2415
2416 #note: POD here, implementation in FS::cust_svc
2417 sub seconds_since {
2418   my $self = shift;
2419   $self->cust_svc->seconds_since(@_);
2420 }
2421
2422 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2423
2424 Returns the numbers of seconds this account has been online between
2425 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2426 external SQL radacct table, specified via sqlradius export.  Sessions which
2427 started in the specified range but are still open are counted from session
2428 start to the end of the range (unless they are over 1 day old, in which case
2429 they are presumed missing their stop record and not counted).  Also, sessions
2430 which end in the range but started earlier are counted from the start of the
2431 range to session end.  Finally, sessions which start before the range but end
2432 after are counted for the entire range.
2433
2434 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2435 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2436 functions.
2437
2438 =cut
2439
2440 #note: POD here, implementation in FS::cust_svc
2441 sub seconds_since_sqlradacct {
2442   my $self = shift;
2443   $self->cust_svc->seconds_since_sqlradacct(@_);
2444 }
2445
2446 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2447
2448 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2449 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2450 TIMESTAMP_END (exclusive).
2451
2452 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2453 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2454 functions.
2455
2456 =cut
2457
2458 #note: POD here, implementation in FS::cust_svc
2459 sub attribute_since_sqlradacct {
2460   my $self = shift;
2461   $self->cust_svc->attribute_since_sqlradacct(@_);
2462 }
2463
2464 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2465
2466 Returns an array of hash references of this customers login history for the
2467 given time range.  (document this better)
2468
2469 =cut
2470
2471 sub get_session_history {
2472   my $self = shift;
2473   $self->cust_svc->get_session_history(@_);
2474 }
2475
2476 =item last_login_text
2477
2478 Returns text describing the time of last login.
2479
2480 =cut
2481
2482 sub last_login_text {
2483   my $self = shift;
2484   $self->last_login ? ctime($self->last_login) : 'unknown';
2485 }
2486
2487 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2488
2489 =cut
2490
2491 sub get_cdrs {
2492   my($self, $start, $end, %opt ) = @_;
2493
2494   my $did = $self->username; #yup
2495
2496   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2497
2498   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2499
2500   #SELECT $for_update * FROM cdr
2501   #  WHERE calldate >= $start #need a conversion
2502   #    AND calldate <  $end   #ditto
2503   #    AND (    charged_party = "$did"
2504   #          OR charged_party = "$prefix$did" #if length($prefix);
2505   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2506   #               AND
2507   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2508   #             )
2509   #        )
2510   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2511
2512   my $charged_or_src;
2513   if ( length($prefix) ) {
2514     $charged_or_src =
2515       " AND (    charged_party = '$did'
2516               OR charged_party = '$prefix$did'
2517               OR ( ( charged_party IS NULL OR charged_party = '' )
2518                    AND
2519                    ( src = '$did' OR src = '$prefix$did' )
2520                  )
2521             )
2522       ";
2523   } else {
2524     $charged_or_src =
2525       " AND (    charged_party = '$did'
2526               OR ( ( charged_party IS NULL OR charged_party = '' )
2527                    AND
2528                    src = '$did'
2529                  )
2530             )
2531       ";
2532
2533   }
2534
2535   qsearch(
2536     'select'    => "$for_update *",
2537     'table'     => 'cdr',
2538     'hashref'   => {
2539                      #( freesidestatus IS NULL OR freesidestatus = '' )
2540                      'freesidestatus' => '',
2541                    },
2542     'extra_sql' => $charged_or_src,
2543
2544   );
2545
2546 }
2547
2548 =item radius_groups
2549
2550 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2551
2552 =cut
2553
2554 sub radius_groups {
2555   my $self = shift;
2556   if ( $self->usergroup ) {
2557     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2558       unless ref($self->usergroup) eq 'ARRAY';
2559     #when provisioning records, export callback runs in svc_Common.pm before
2560     #radius_usergroup records can be inserted...
2561     @{$self->usergroup};
2562   } else {
2563     map { $_->groupname }
2564       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2565   }
2566 }
2567
2568 =item clone_suspended
2569
2570 Constructor used by FS::part_export::_export_suspend fallback.  Document
2571 better.
2572
2573 =cut
2574
2575 sub clone_suspended {
2576   my $self = shift;
2577   my %hash = $self->hash;
2578   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2579   new FS::svc_acct \%hash;
2580 }
2581
2582 =item clone_kludge_unsuspend
2583
2584 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2585 better.
2586
2587 =cut
2588
2589 sub clone_kludge_unsuspend {
2590   my $self = shift;
2591   my %hash = $self->hash;
2592   $hash{_password} = '';
2593   new FS::svc_acct \%hash;
2594 }
2595
2596 =item check_password
2597
2598 Checks the supplied password against the (possibly encrypted) password in the
2599 database.  Returns true for a successful authentication, false for no match.
2600
2601 Currently supported encryptions are: classic DES crypt() and MD5
2602
2603 =cut
2604
2605 sub check_password {
2606   my($self, $check_password) = @_;
2607
2608   #remove old-style SUSPENDED kludge, they should be allowed to login to
2609   #self-service and pay up
2610   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2611
2612   if ( $self->_password_encoding eq 'ldap' ) {
2613
2614     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2615     return $auth->match($check_password);
2616
2617   } elsif ( $self->_password_encoding eq 'crypt' ) {
2618
2619     my $auth = from_crypt Authen::Passphrase $self->_password;
2620     return $auth->match($check_password);
2621
2622   } elsif ( $self->_password_encoding eq 'plain' ) {
2623
2624     return $check_password eq $password;
2625
2626   } else {
2627
2628     #XXX this could be replaced with Authen::Passphrase stuff
2629
2630     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2631       return 0;
2632     } elsif ( length($password) < 13 ) { #plaintext
2633       $check_password eq $password;
2634     } elsif ( length($password) == 13 ) { #traditional DES crypt
2635       crypt($check_password, $password) eq $password;
2636     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2637       unix_md5_crypt($check_password, $password) eq $password;
2638     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2639       warn "Can't check password: Blowfish encryption not yet supported, ".
2640            "svcnum ".  $self->svcnum. "\n";
2641       0;
2642     } else {
2643       warn "Can't check password: Unrecognized encryption for svcnum ".
2644            $self->svcnum. "\n";
2645       0;
2646     }
2647
2648   }
2649
2650 }
2651
2652 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2653
2654 Returns an encrypted password, either by passing through an encrypted password
2655 in the database or by encrypting a plaintext password from the database.
2656
2657 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2658 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2659 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2660 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2661 encryption type is only used if the password is not already encrypted in the
2662 database.
2663
2664 =cut
2665
2666 sub crypt_password {
2667   my $self = shift;
2668
2669   if ( $self->_password_encoding eq 'ldap' ) {
2670
2671     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2672       my $plain = $2;
2673
2674       #XXX this could be replaced with Authen::Passphrase stuff
2675
2676       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2677       if ( $encryption eq 'crypt' ) {
2678         return crypt(
2679           $self->_password,
2680           $saltset[int(rand(64))].$saltset[int(rand(64))]
2681         );
2682       } elsif ( $encryption eq 'md5' ) {
2683         return unix_md5_crypt( $self->_password );
2684       } elsif ( $encryption eq 'blowfish' ) {
2685         croak "unknown encryption method $encryption";
2686       } else {
2687         croak "unknown encryption method $encryption";
2688       }
2689
2690     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2691       return $1;
2692     }
2693
2694   } elsif ( $self->_password_encoding eq 'crypt' ) {
2695
2696     return $self->_password;
2697
2698   } elsif ( $self->_password_encoding eq 'plain' ) {
2699
2700     #XXX this could be replaced with Authen::Passphrase stuff
2701
2702     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2703     if ( $encryption eq 'crypt' ) {
2704       return crypt(
2705         $self->_password,
2706         $saltset[int(rand(64))].$saltset[int(rand(64))]
2707       );
2708     } elsif ( $encryption eq 'md5' ) {
2709       return unix_md5_crypt( $self->_password );
2710     } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2711       my $pass = sha1_base64( $self->_password );
2712       $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2713       return $pass;
2714     } elsif ( $encryption eq 'blowfish' ) {
2715       croak "unknown encryption method $encryption";
2716     } else {
2717       croak "unknown encryption method $encryption";
2718     }
2719
2720   } else {
2721
2722     if ( length($self->_password) == 13
2723          || $self->_password =~ /^\$(1|2a?)\$/
2724          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2725        )
2726     {
2727       $self->_password;
2728     } else {
2729
2730       #XXX this could be replaced with Authen::Passphrase stuff
2731
2732       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2733       if ( $encryption eq 'crypt' ) {
2734         return crypt(
2735           $self->_password,
2736           $saltset[int(rand(64))].$saltset[int(rand(64))]
2737         );
2738       } elsif ( $encryption eq 'md5' ) {
2739         return unix_md5_crypt( $self->_password );
2740       } elsif ( $encryption eq 'blowfish' ) {
2741         croak "unknown encryption method $encryption";
2742       } else {
2743         croak "unknown encryption method $encryption";
2744       }
2745
2746     }
2747
2748   }
2749
2750 }
2751
2752 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2753
2754 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2755 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2756 "{MD5}5426824942db4253f87a1009fd5d2d4".
2757
2758 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2759 to work the same as the B</crypt_password> method.
2760
2761 =cut
2762
2763 sub ldap_password {
2764   my $self = shift;
2765   #eventually should check a "password-encoding" field
2766
2767   if ( $self->_password_encoding eq 'ldap' ) {
2768
2769     return $self->_password;
2770
2771   } elsif ( $self->_password_encoding eq 'crypt' ) {
2772
2773     if ( length($self->_password) == 13 ) { #crypt
2774       return '{CRYPT}'. $self->_password;
2775     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2776       return '{MD5}'. $1;
2777     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2778     #  die "Blowfish encryption not supported in this context, svcnum ".
2779     #      $self->svcnum. "\n";
2780     } else {
2781       warn "encryption method not (yet?) supported in LDAP context";
2782       return '{CRYPT}*'; #unsupported, should not auth
2783     }
2784
2785   } elsif ( $self->_password_encoding eq 'plain' ) {
2786
2787     return '{PLAIN}'. $self->_password;
2788
2789     #return '{CLEARTEXT}'. $self->_password; #?
2790
2791   } else {
2792
2793     if ( length($self->_password) == 13 ) { #crypt
2794       return '{CRYPT}'. $self->_password;
2795     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2796       return '{MD5}'. $1;
2797     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2798       warn "Blowfish encryption not supported in this context, svcnum ".
2799           $self->svcnum. "\n";
2800       return '{CRYPT}*';
2801
2802     #are these two necessary anymore?
2803     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2804       return '{SSHA}'. $1;
2805     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2806       return '{NS-MTA-MD5}'. $1;
2807
2808     } else { #plaintext
2809       return '{PLAIN}'. $self->_password;
2810
2811       #return '{CLEARTEXT}'. $self->_password; #?
2812
2813       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2814       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2815       #if ( $encryption eq 'crypt' ) {
2816       #  return '{CRYPT}'. crypt(
2817       #    $self->_password,
2818       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2819       #  );
2820       #} elsif ( $encryption eq 'md5' ) {
2821       #  unix_md5_crypt( $self->_password );
2822       #} elsif ( $encryption eq 'blowfish' ) {
2823       #  croak "unknown encryption method $encryption";
2824       #} else {
2825       #  croak "unknown encryption method $encryption";
2826       #}
2827     }
2828
2829   }
2830
2831 }
2832
2833 =item domain_slash_username
2834
2835 Returns $domain/$username/
2836
2837 =cut
2838
2839 sub domain_slash_username {
2840   my $self = shift;
2841   $self->domain. '/'. $self->username. '/';
2842 }
2843
2844 =item virtual_maildir
2845
2846 Returns $domain/maildirs/$username/
2847
2848 =cut
2849
2850 sub virtual_maildir {
2851   my $self = shift;
2852   $self->domain. '/maildirs/'. $self->username. '/';
2853 }
2854
2855 =back
2856
2857 =head1 CLASS METHODS
2858
2859 =over 4
2860
2861 =item search HASHREF
2862
2863 Class method which returns a qsearch hash expression to search for parameters
2864 specified in HASHREF.  Valid parameters are
2865
2866 =over 4
2867
2868 =item domain
2869
2870 =item domsvc
2871
2872 =item unlinked
2873
2874 =item agentnum
2875
2876 =item pkgpart
2877
2878 Arrayref of pkgparts
2879
2880 =item pkgpart
2881
2882 =item where
2883
2884 Arrayref of additional WHERE clauses, will be ANDed together.
2885
2886 =item order_by
2887
2888 =item cust_fields
2889
2890 =back
2891
2892 =cut
2893
2894 sub search {
2895   my ($class, $params) = @_;
2896
2897   my @where = ();
2898
2899   # domain
2900   if ( $params->{'domain'} ) {
2901     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2902     #preserve previous behavior & bubble up an error if $svc_domain not found?
2903     push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2904   }
2905
2906   # domsvc
2907   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2908     push @where, "domsvc = $1";
2909   }
2910
2911   #unlinked
2912   push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2913
2914   #agentnum
2915   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2916     push @where, "agentnum = $1";
2917   }
2918
2919   #custnum
2920   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2921     push @where, "custnum = $1";
2922   }
2923
2924   #pkgpart
2925   if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2926     #XXX untaint or sql quote
2927     push @where,
2928       'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2929   }
2930
2931   # popnum
2932   if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2933     push @where, "popnum = $1";
2934   }
2935
2936   # svcpart
2937   if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2938     push @where, "svcpart = $1";
2939   }
2940
2941
2942   # here is the agent virtualization
2943   #if ($params->{CurrentUser}) {
2944   #  my $access_user =
2945   #    qsearchs('access_user', { username => $params->{CurrentUser} });
2946   #
2947   #  if ($access_user) {
2948   #    push @where, $access_user->agentnums_sql('table'=>'cust_main');
2949   #  }else{
2950   #    push @where, "1=0";
2951   #  }
2952   #} else {
2953     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2954                    'table'      => 'cust_main',
2955                    'null_right' => 'View/link unlinked services',
2956                  );
2957   #}
2958
2959   push @where, @{ $params->{'where'} } if $params->{'where'};
2960
2961   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2962
2963   my $addl_from = ' LEFT JOIN cust_svc  USING ( svcnum  ) '.
2964                   ' LEFT JOIN part_svc  USING ( svcpart ) '.
2965                   ' LEFT JOIN cust_pkg  USING ( pkgnum  ) '.
2966                   ' LEFT JOIN cust_main USING ( custnum ) ';
2967
2968   my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2969   #if ( keys %svc_acct ) {
2970   #  $count_query .= ' WHERE '.
2971   #                    join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2972   #                                      keys %svc_acct
2973   #                        );
2974   #}
2975
2976   my $sql_query = {
2977     'table'       => 'svc_acct',
2978     'hashref'     => {}, # \%svc_acct,
2979     'select'      => join(', ',
2980                        'svc_acct.*',
2981                        'part_svc.svc',
2982                        'cust_main.custnum',
2983                        FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2984                      ),
2985     'addl_from'   => $addl_from,
2986     'extra_sql'   => $extra_sql,
2987     'order_by'    => $params->{'order_by'},
2988     'count_query' => $count_query,
2989   };
2990
2991 }
2992
2993 =back
2994
2995 =head1 SUBROUTINES
2996
2997 =over 4
2998
2999 =item send_email
3000
3001 This is the FS::svc_acct job-queue-able version.  It still uses
3002 FS::Misc::send_email under-the-hood.
3003
3004 =cut
3005
3006 sub send_email {
3007   my %opt = @_;
3008
3009   eval "use FS::Misc qw(send_email)";
3010   die $@ if $@;
3011
3012   $opt{mimetype} ||= 'text/plain';
3013   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3014
3015   my $error = send_email(
3016     'from'         => $opt{from},
3017     'to'           => $opt{to},
3018     'subject'      => $opt{subject},
3019     'content-type' => $opt{mimetype},
3020     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
3021   );
3022   die $error if $error;
3023 }
3024
3025 =item check_and_rebuild_fuzzyfiles
3026
3027 =cut
3028
3029 sub check_and_rebuild_fuzzyfiles {
3030   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3031   -e "$dir/svc_acct.username"
3032     or &rebuild_fuzzyfiles;
3033 }
3034
3035 =item rebuild_fuzzyfiles
3036
3037 =cut
3038
3039 sub rebuild_fuzzyfiles {
3040
3041   use Fcntl qw(:flock);
3042
3043   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3044
3045   #username
3046
3047   open(USERNAMELOCK,">>$dir/svc_acct.username")
3048     or die "can't open $dir/svc_acct.username: $!";
3049   flock(USERNAMELOCK,LOCK_EX)
3050     or die "can't lock $dir/svc_acct.username: $!";
3051
3052   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
3053
3054   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
3055     or die "can't open $dir/svc_acct.username.tmp: $!";
3056   print USERNAMECACHE join("\n", @all_username), "\n";
3057   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
3058
3059   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
3060   close USERNAMELOCK;
3061
3062 }
3063
3064 =item all_username
3065
3066 =cut
3067
3068 sub all_username {
3069   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3070   open(USERNAMECACHE,"<$dir/svc_acct.username")
3071     or die "can't open $dir/svc_acct.username: $!";
3072   my @array = map { chomp; $_; } <USERNAMECACHE>;
3073   close USERNAMECACHE;
3074   \@array;
3075 }
3076
3077 =item append_fuzzyfiles USERNAME
3078
3079 =cut
3080
3081 sub append_fuzzyfiles {
3082   my $username = shift;
3083
3084   &check_and_rebuild_fuzzyfiles;
3085
3086   use Fcntl qw(:flock);
3087
3088   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3089
3090   open(USERNAME,">>$dir/svc_acct.username")
3091     or die "can't open $dir/svc_acct.username: $!";
3092   flock(USERNAME,LOCK_EX)
3093     or die "can't lock $dir/svc_acct.username: $!";
3094
3095   print USERNAME "$username\n";
3096
3097   flock(USERNAME,LOCK_UN)
3098     or die "can't unlock $dir/svc_acct.username: $!";
3099   close USERNAME;
3100
3101   1;
3102 }
3103
3104
3105
3106 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
3107
3108 =cut
3109
3110 sub radius_usergroup_selector {
3111   my $sel_groups = shift;
3112   my %sel_groups = map { $_=>1 } @$sel_groups;
3113
3114   my $selectname = shift || 'radius_usergroup';
3115
3116   my $dbh = dbh;
3117   my $sth = $dbh->prepare(
3118     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
3119   ) or die $dbh->errstr;
3120   $sth->execute() or die $sth->errstr;
3121   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
3122
3123   my $html = <<END;
3124     <SCRIPT>
3125     function ${selectname}_doadd(object) {
3126       var myvalue = object.${selectname}_add.value;
3127       var optionName = new Option(myvalue,myvalue,false,true);
3128       var length = object.$selectname.length;
3129       object.$selectname.options[length] = optionName;
3130       object.${selectname}_add.value = "";
3131     }
3132     </SCRIPT>
3133     <SELECT MULTIPLE NAME="$selectname">
3134 END
3135
3136   foreach my $group ( @all_groups ) {
3137     $html .= qq(<OPTION VALUE="$group");
3138     if ( $sel_groups{$group} ) {
3139       $html .= ' SELECTED';
3140       $sel_groups{$group} = 0;
3141     }
3142     $html .= ">$group</OPTION>\n";
3143   }
3144   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
3145     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
3146   };
3147   $html .= '</SELECT>';
3148
3149   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
3150            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
3151
3152   $html;
3153 }
3154
3155 =item reached_threshold
3156
3157 Performs some activities when svc_acct thresholds (such as number of seconds
3158 remaining) are reached.
3159
3160 =cut
3161
3162 sub reached_threshold {
3163   my %opt = @_;
3164
3165   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3166   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3167
3168   if ( $opt{'op'} eq '+' ){
3169     $svc_acct->setfield( $opt{'column'}.'_threshold',
3170                          int($svc_acct->getfield($opt{'column'})
3171                              * ( $conf->exists('svc_acct-usage_threshold')
3172                                  ? $conf->config('svc_acct-usage_threshold')/100
3173                                  : 0.80
3174                                )
3175                          )
3176                        );
3177     my $error = $svc_acct->replace;
3178     die $error if $error;
3179   }elsif ( $opt{'op'} eq '-' ){
3180
3181     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3182     return '' if ($threshold eq '' );
3183
3184     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3185     my $error = $svc_acct->replace;
3186     die $error if $error; # email next time, i guess
3187
3188     if ( $warning_template ) {
3189       eval "use FS::Misc qw(send_email)";
3190       die $@ if $@;
3191
3192       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
3193       my $cust_main = $cust_pkg->cust_main;
3194
3195       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3196                                $cust_main->invoicing_list,
3197                                ($opt{'to'} ? $opt{'to'} : ())
3198                    );
3199
3200       my $mimetype = $warning_mimetype;
3201       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3202
3203       my $body       =  $warning_template->fill_in( HASH => {
3204                         'custnum'   => $cust_main->custnum,
3205                         'username'  => $svc_acct->username,
3206                         'password'  => $svc_acct->_password,
3207                         'first'     => $cust_main->first,
3208                         'last'      => $cust_main->getfield('last'),
3209                         'pkg'       => $cust_pkg->part_pkg->pkg,
3210                         'column'    => $opt{'column'},
3211                         'amount'    => $opt{'column'} =~/bytes/
3212                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3213                                        : $svc_acct->getfield($opt{'column'}),
3214                         'threshold' => $opt{'column'} =~/bytes/
3215                                        ? FS::UI::bytecount::display_bytecount($threshold)
3216                                        : $threshold,
3217                       } );
3218
3219
3220       my $error = send_email(
3221         'from'         => $warning_from,
3222         'to'           => $to,
3223         'subject'      => $warning_subject,
3224         'content-type' => $mimetype,
3225         'body'         => [ map "$_\n", split("\n", $body) ],
3226       );
3227       die $error if $error;
3228     }
3229   }else{
3230     die "unknown op: " . $opt{'op'};
3231   }
3232 }
3233
3234 =back
3235
3236 =head1 BUGS
3237
3238 The $recref stuff in sub check should be cleaned up.
3239
3240 The suspend, unsuspend and cancel methods update the database, but not the
3241 current object.  This is probably a bug as it's unexpected and
3242 counterintuitive.
3243
3244 radius_usergroup_selector?  putting web ui components in here?  they should
3245 probably live somewhere else...
3246
3247 insertion of RADIUS group stuff in insert could be done with child_objects now
3248 (would probably clean up export of them too)
3249
3250 _op_usage and set_usage bypass the history... maybe they shouldn't
3251
3252 =head1 SEE ALSO
3253
3254 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3255 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3256 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3257 L<freeside-queued>), L<FS::svc_acct_pop>,
3258 schema.html from the base documentation.
3259
3260 =cut
3261
3262 1;