FS/FS/svc_acct.pm

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