FS/FS/svc_acct.pm

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