FS/FS/svc_acct.pm

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