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