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