FS/FS/svc_acct.pm

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