FS/FS/svc_acct.pm

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