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