FS/FS/svc_acct.pm

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