FS/FS/svc_acct.pm

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