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   return "can't change username"
 997     if $old->username ne $new->username
 998     && $conf->exists('svc_acct-no_edit_username');
 999
1000   #change homdir when we change username
1001   $new->setfield('dir', '') if $old->username ne $new->username;
1002
1003   local $SIG{HUP} = 'IGNORE';
1004   local $SIG{INT} = 'IGNORE';
1005   local $SIG{QUIT} = 'IGNORE';
1006   local $SIG{TERM} = 'IGNORE';
1007   local $SIG{TSTP} = 'IGNORE';
1008   local $SIG{PIPE} = 'IGNORE';
1009
1010   my $oldAutoCommit = $FS::UID::AutoCommit;
1011   local $FS::UID::AutoCommit = 0;
1012   my $dbh = dbh;
1013
1014   # redundant, but so $new->usergroup gets set
1015   $error = $new->check;
1016   return $error if $error;
1017
1018   $old->usergroup( [ $old->radius_groups('NUMBERS') ] );
1019   if ( $DEBUG ) {
1020     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
1021     warn $new->email. " new groups: ". join(' ',@{$new->usergroup}). "\n";
1022   }
1023   if ( $new->usergroup ) {
1024     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
1025     my @newgroups = @{$new->usergroup};
1026     foreach my $oldgroup ( @{$old->usergroup} ) {
1027       if ( grep { $oldgroup eq $_ } @newgroups ) {
1028         @newgroups = grep { $oldgroup ne $_ } @newgroups;
1029         next;
1030       }
1031       my $radius_usergroup = qsearchs('radius_usergroup', {
1032         svcnum    => $old->svcnum,
1033         groupnum  => $oldgroup,
1034       } );
1035       my $error = $radius_usergroup->delete;
1036       if ( $error ) {
1037         $dbh->rollback if $oldAutoCommit;
1038         return "error deleting radius_usergroup $oldgroup: $error";
1039       }
1040     }
1041
1042     foreach my $newgroup ( @newgroups ) {
1043       my $radius_usergroup = new FS::radius_usergroup ( {
1044         svcnum    => $new->svcnum,
1045         groupnum => $newgroup,
1046       } );
1047       my $error = $radius_usergroup->insert;
1048       if ( $error ) {
1049         $dbh->rollback if $oldAutoCommit;
1050         return "error adding radius_usergroup $newgroup: $error";
1051       }
1052     }
1053
1054   }
1055
1056   $error = $new->SUPER::replace($old, @_);
1057   if ( $error ) {
1058     $dbh->rollback if $oldAutoCommit;
1059     return $error if $error;
1060   }
1061
1062   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1063     $error = $new->queue_fuzzyfiles_update;
1064     if ( $error ) {
1065       $dbh->rollback if $oldAutoCommit;
1066       return "updating fuzzy search cache: $error";
1067     }
1068   }
1069
1070   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1071   ''; #no error
1072 }
1073
1074 =item queue_fuzzyfiles_update
1075
1076 Used by insert & replace to update the fuzzy search cache
1077
1078 =cut
1079
1080 sub queue_fuzzyfiles_update {
1081   my $self = shift;
1082
1083   local $SIG{HUP} = 'IGNORE';
1084   local $SIG{INT} = 'IGNORE';
1085   local $SIG{QUIT} = 'IGNORE';
1086   local $SIG{TERM} = 'IGNORE';
1087   local $SIG{TSTP} = 'IGNORE';
1088   local $SIG{PIPE} = 'IGNORE';
1089
1090   my $oldAutoCommit = $FS::UID::AutoCommit;
1091   local $FS::UID::AutoCommit = 0;
1092   my $dbh = dbh;
1093
1094   my $queue = new FS::queue {
1095     'svcnum' => $self->svcnum,
1096     'job'    => 'FS::svc_acct::append_fuzzyfiles'
1097   };
1098   my $error = $queue->insert($self->username);
1099   if ( $error ) {
1100     $dbh->rollback if $oldAutoCommit;
1101     return "queueing job (transaction rolled back): $error";
1102   }
1103
1104   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1105   '';
1106
1107 }
1108
1109
1110 =item suspend
1111
1112 Suspends this account by calling export-specific suspend hooks.  If there is
1113 an error, returns the error, otherwise returns false.
1114
1115 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1116
1117 =cut
1118
1119 sub suspend {
1120   my $self = shift;
1121   return "can't suspend system account" if $self->_check_system;
1122   $self->SUPER::suspend(@_);
1123 }
1124
1125 =item unsuspend
1126
1127 Unsuspends this account by by calling export-specific suspend hooks.  If there
1128 is an error, returns the error, otherwise returns false.
1129
1130 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1131
1132 =cut
1133
1134 sub unsuspend {
1135   my $self = shift;
1136   my %hash = $self->hash;
1137   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1138     $hash{_password} = $1;
1139     my $new = new FS::svc_acct ( \%hash );
1140     my $error = $new->replace($self);
1141     return $error if $error;
1142   }
1143
1144   $self->SUPER::unsuspend(@_);
1145 }
1146
1147 =item cancel
1148
1149 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1150
1151 If the B<auto_unset_catchall> configuration option is set, this method will
1152 automatically remove any references to the canceled service in the catchall
1153 field of svc_domain.  This allows packages that contain both a svc_domain and
1154 its catchall svc_acct to be canceled in one step.
1155
1156 =cut
1157
1158 sub cancel {
1159   # Only one thing to do at this level
1160   my $self = shift;
1161   foreach my $svc_domain (
1162       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1163     if($conf->exists('auto_unset_catchall')) {
1164       my %hash = $svc_domain->hash;
1165       $hash{catchall} = '';
1166       my $new = new FS::svc_domain ( \%hash );
1167       my $error = $new->replace($svc_domain);
1168       return $error if $error;
1169     } else {
1170       return "cannot unprovision svc_acct #".$self->svcnum.
1171           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1172     }
1173   }
1174
1175   $self->SUPER::cancel(@_);
1176 }
1177
1178
1179 =item check
1180
1181 Checks all fields to make sure this is a valid service.  If there is an error,
1182 returns the error, otherwise returns false.  Called by the insert and replace
1183 methods.
1184
1185 Sets any fixed values; see L<FS::part_svc>.
1186
1187 =cut
1188
1189 sub check {
1190   my $self = shift;
1191
1192   my($recref) = $self->hashref;
1193
1194   my $x = $self->setfixed( $self->_fieldhandlers );
1195   return $x unless ref($x);
1196   my $part_svc = $x;
1197
1198   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1199     $self->usergroup(
1200       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1201   }
1202
1203   my $error = $self->ut_numbern('svcnum')
1204               #|| $self->ut_number('domsvc')
1205               || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1206               || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx',    'svcnum' )
1207               || $self->ut_textn('sec_phrase')
1208               || $self->ut_snumbern('seconds')
1209               || $self->ut_snumbern('upbytes')
1210               || $self->ut_snumbern('downbytes')
1211               || $self->ut_snumbern('totalbytes')
1212               || $self->ut_snumbern('seconds_threshold')
1213               || $self->ut_snumbern('upbytes_threshold')
1214               || $self->ut_snumbern('downbytes_threshold')
1215               || $self->ut_snumbern('totalbytes_threshold')
1216               || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1217               || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1218               || $self->ut_enum('password_recover',    [ '', 'Y' ])
1219               #cardfortress
1220               || $self->ut_anything('cf_privatekey')
1221               #communigate
1222               || $self->ut_textn('cgp_accessmodes')
1223               || $self->ut_alphan('cgp_type')
1224               || $self->ut_textn('cgp_aliases' ) #well
1225               # settings
1226               || $self->ut_alphasn('cgp_rulesallowed')
1227               || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1228               || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1229               || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1230               || $self->ut_snumbern('cgp_archiveafter')
1231               # preferences
1232               || $self->ut_alphasn('cgp_deletemode')
1233               || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1234               || $self->ut_alphan('cgp_language')
1235               || $self->ut_textn('cgp_timezone')
1236               || $self->ut_textn('cgp_skinname')
1237               || $self->ut_textn('cgp_prontoskinname')
1238               || $self->ut_alphan('cgp_sendmdnmode')
1239   ;
1240   return $error if $error;
1241
1242   my $cust_pkg;
1243   local $username_letter = $username_letter;
1244   if ($self->svcnum) {
1245     my $cust_svc = $self->cust_svc
1246       or return "no cust_svc record found for svcnum ". $self->svcnum;
1247     my $cust_pkg = $cust_svc->cust_pkg;
1248   }
1249   if ($self->pkgnum) {
1250     $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1251   }
1252   if ($cust_pkg) {
1253     $username_letter =
1254       $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1255   }
1256
1257   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1258
1259   $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#]{$usernamemin,$ulen})$/i
1260     or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1261   $recref->{username} = $1;
1262
1263   unless ( $username_uppercase ) {
1264     $recref->{username} =~ /[A-Z]/ and return gettext('illegal_username');
1265   }
1266   if ( $username_letterfirst ) {
1267     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1268   } elsif ( $username_letter ) {
1269     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1270   }
1271   if ( $username_noperiod ) {
1272     $recref->{username} =~ /\./ and return gettext('illegal_username');
1273   }
1274   if ( $username_nounderscore ) {
1275     $recref->{username} =~ /_/ and return gettext('illegal_username');
1276   }
1277   if ( $username_nodash ) {
1278     $recref->{username} =~ /\-/ and return gettext('illegal_username');
1279   }
1280   unless ( $username_ampersand ) {
1281     $recref->{username} =~ /\&/ and return gettext('illegal_username');
1282   }
1283   unless ( $username_percent ) {
1284     $recref->{username} =~ /\%/ and return gettext('illegal_username');
1285   }
1286   unless ( $username_colon ) {
1287     $recref->{username} =~ /\:/ and return gettext('illegal_username');
1288   }
1289   unless ( $username_slash ) {
1290     $recref->{username} =~ /\// and return gettext('illegal_username');
1291   }
1292   unless ( $username_equals ) {
1293     $recref->{username} =~ /\=/ and return gettext('illegal_username');
1294   }
1295   unless ( $username_pound ) {
1296     $recref->{username} =~ /\#/ and return gettext('illegal_username');
1297   }
1298
1299
1300   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1301   $recref->{popnum} = $1;
1302   return "Unknown popnum" unless
1303     ! $recref->{popnum} ||
1304     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1305
1306   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1307
1308     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1309     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1310
1311     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1312     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1313     #not all systems use gid=uid
1314     #you can set a fixed gid in part_svc
1315
1316     return "Only root can have uid 0"
1317       if $recref->{uid} == 0
1318          && $recref->{username} !~ /^(root|toor|smtp)$/;
1319
1320     unless ( $recref->{username} eq 'sync' ) {
1321       if ( grep $_ eq $recref->{shell}, @shells ) {
1322         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1323       } else {
1324         return "Illegal shell \`". $self->shell. "\'; ".
1325                "shells configuration value contains: @shells";
1326       }
1327     } else {
1328       $recref->{shell} = '/bin/sync';
1329     }
1330
1331   } else {
1332     $recref->{gid} ne '' ?
1333       return "Can't have gid without uid" : ( $recref->{gid}='' );
1334     #$recref->{dir} ne '' ?
1335     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1336     $recref->{shell} ne '' ?
1337       return "Can't have shell without uid" : ( $recref->{shell}='' );
1338   }
1339
1340   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1341
1342     $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1343       or return "Illegal directory: ". $recref->{dir};
1344     $recref->{dir} = $1;
1345     return "Illegal directory"
1346       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1347     return "Illegal directory"
1348       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1349     unless ( $recref->{dir} ) {
1350       $recref->{dir} = $dir_prefix . '/';
1351       if ( $dirhash > 0 ) {
1352         for my $h ( 1 .. $dirhash ) {
1353           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1354         }
1355       } elsif ( $dirhash < 0 ) {
1356         for my $h ( reverse $dirhash .. -1 ) {
1357           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1358         }
1359       }
1360       $recref->{dir} .= $recref->{username};
1361     ;
1362     }
1363
1364   }
1365
1366   #  $error = $self->ut_textn('finger');
1367   #  return $error if $error;
1368   if ( $self->getfield('finger') eq '' ) {
1369     my $cust_pkg = $self->svcnum
1370       ? $self->cust_svc->cust_pkg
1371       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1372     if ( $cust_pkg ) {
1373       my $cust_main = $cust_pkg->cust_main;
1374       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1375     }
1376   }
1377   $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]+)$/
1378       or return "Illegal finger: ". $self->getfield('finger');
1379   $self->setfield('finger', $1);
1380
1381   for (qw( quota file_quota file_maxsize )) {
1382     $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1383     $recref->{$_} = $1;
1384   }
1385   $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1386   $recref->{file_maxnum} = $1;
1387
1388   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1389     if ( $recref->{slipip} eq '' ) {
1390       $recref->{slipip} = '';
1391     } elsif ( $recref->{slipip} eq '0e0' ) {
1392       $recref->{slipip} = '0e0';
1393     } else {
1394       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1395         or return "Illegal slipip: ". $self->slipip;
1396       $recref->{slipip} = $1;
1397     }
1398
1399   }
1400
1401   #arbitrary RADIUS stuff; allow ut_textn for now
1402   foreach ( grep /^radius_/, fields('svc_acct') ) {
1403     $self->ut_textn($_);
1404   }
1405
1406   # First, if _password is blank, generate one and set default encoding.
1407   if ( ! $recref->{_password} ) {
1408     $error = $self->set_password('');
1409   }
1410   # But if there's a _password but no encoding, assume it's plaintext and
1411   # set it to default encoding.
1412   elsif ( ! $recref->{_password_encoding} ) {
1413     $error = $self->set_password($recref->{_password});
1414   }
1415   return $error if $error;
1416
1417   # Next, check _password to ensure compliance with the encoding.
1418   if ( $recref->{_password_encoding} eq 'ldap' ) {
1419
1420     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1421       $recref->{_password} = uc($1).$2;
1422     } else {
1423       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1424     }
1425
1426   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1427
1428     if ( $recref->{_password} =~
1429            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1430            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1431        ) {
1432
1433       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1434
1435     } else {
1436       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1437     }
1438
1439   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1440     # Password randomization is now in set_password.
1441     # Strip whitespace characters, check length requirements, etc.
1442     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1443       $recref->{_password} = $1;
1444     } else {
1445       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1446              FS::Msgcat::_gettext('illegal_password_characters').
1447              ": ". $recref->{_password};
1448     }
1449
1450     if ( $password_noampersand ) {
1451       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1452     }
1453     if ( $password_noexclamation ) {
1454       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1455     }
1456   }
1457   else {
1458     return "invalid password encoding ('".$recref->{_password_encoding}."'";
1459   }
1460   $self->SUPER::check;
1461
1462 }
1463
1464
1465 sub _password_encryption {
1466   my $self = shift;
1467   my $encoding = lc($self->_password_encoding);
1468   return if !$encoding;
1469   return 'plain' if $encoding eq 'plain';
1470   if($encoding eq 'crypt') {
1471     my $pass = $self->_password;
1472     $pass =~ s/^\*SUSPENDED\* //;
1473     $pass =~ s/^!!?//;
1474     return 'md5' if $pass =~ /^\$1\$/;
1475     #return 'blowfish' if $self->_password =~ /^\$2\$/;
1476     return 'des' if length($pass) == 13;
1477     return;
1478   }
1479   if($encoding eq 'ldap') {
1480     uc($self->_password) =~ /^\{([\w-]+)\}/;
1481     return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1482     return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1483     return 'md5' if $1 eq 'MD5';
1484     return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1485
1486     return;
1487   }
1488   return;
1489 }
1490
1491 sub get_cleartext_password {
1492   my $self = shift;
1493   if($self->_password_encryption eq 'plain') {
1494     if($self->_password_encoding eq 'ldap') {
1495       $self->_password =~ /\{\w+\}(.*)$/;
1496       return $1;
1497     }
1498     else {
1499       return $self->_password;
1500     }
1501   }
1502   return;
1503 }
1504
1505
1506 =item set_password
1507
1508 Set the cleartext password for the account.  If _password_encoding is set, the
1509 new password will be encoded according to the existing method (including
1510 encryption mode, if it can be determined).  Otherwise,
1511 config('default-password-encoding') is used.
1512
1513 If no password is supplied (or a zero-length password when minimum password length
1514 is >0), one will be generated randomly.
1515
1516 =cut
1517
1518 sub set_password {
1519   my( $self, $pass ) = ( shift, shift );
1520
1521   warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1522      if $DEBUG;
1523
1524   my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1525                 FS::Msgcat::_gettext('illegal_password_characters').
1526                 ": ". $pass;
1527
1528   my( $encoding, $encryption ) = ('', '');
1529
1530   if ( $self->_password_encoding ) {
1531     $encoding = $self->_password_encoding;
1532     # identify existing encryption method, try to use it.
1533     $encryption = $self->_password_encryption;
1534     if (!$encryption) {
1535       # use the system default
1536       undef $encoding;
1537     }
1538   }
1539
1540   if ( !$encoding ) {
1541     # set encoding to system default
1542     ($encoding, $encryption) =
1543       split(/-/, lc($conf->config('default-password-encoding')));
1544     $encoding ||= 'legacy';
1545     $self->_password_encoding($encoding);
1546   }
1547
1548   if ( $encoding eq 'legacy' ) {
1549
1550     # The legacy behavior from check():
1551     # If the password is blank, randomize it and set encoding to 'plain'.
1552     if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1553       $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1554       $self->_password_encoding('plain');
1555     } else {
1556       # Prefix + valid-length password
1557       if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1558         $pass = $1.$3;
1559         $self->_password_encoding('plain');
1560       # Prefix + crypt string
1561       } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1562         $pass = $1.$3;
1563         $self->_password_encoding('crypt');
1564       # Various disabled crypt passwords
1565       } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1566         $self->_password_encoding('crypt');
1567       } else {
1568         return $failure;
1569       }
1570     }
1571
1572     $self->_password($pass);
1573     return;
1574
1575   }
1576
1577   return $failure
1578     if $passwordmin && length($pass) < $passwordmin
1579     or $passwordmax && length($pass) > $passwordmax;
1580
1581   if ( $encoding eq 'crypt' ) {
1582     if ($encryption eq 'md5') {
1583       $pass = unix_md5_crypt($pass);
1584     } elsif ($encryption eq 'des') {
1585       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1586     }
1587
1588   } elsif ( $encoding eq 'ldap' ) {
1589     if ($encryption eq 'md5') {
1590       $pass = md5_base64($pass);
1591     } elsif ($encryption eq 'sha1') {
1592       $pass = sha1_base64($pass);
1593     } elsif ($encryption eq 'crypt') {
1594       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1595     }
1596     # else $encryption eq 'plain', do nothing
1597     $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1598       if $encryption eq 'md5' || $encryption eq 'sha1';
1599     $pass = '{'.uc($encryption).'}'.$pass;
1600   }
1601   # else encoding eq 'plain'
1602
1603   $self->_password($pass);
1604   return;
1605 }
1606
1607 =item _check_system
1608
1609 Internal function to check the username against the list of system usernames
1610 from the I<system_usernames> configuration value.  Returns true if the username
1611 is listed on the system username list.
1612
1613 =cut
1614
1615 sub _check_system {
1616   my $self = shift;
1617   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1618                $conf->config('system_usernames')
1619         );
1620 }
1621
1622 =item _check_duplicate
1623
1624 Internal method to check for duplicates usernames, username@domain pairs and
1625 uids.
1626
1627 If the I<global_unique-username> configuration value is set to B<username> or
1628 B<username@domain>, enforces global username or username@domain uniqueness.
1629
1630 In all cases, check for duplicate uids and usernames or username@domain pairs
1631 per export and with identical I<svcpart> values.
1632
1633 =cut
1634
1635 sub _check_duplicate {
1636   my $self = shift;
1637
1638   my $global_unique = $conf->config('global_unique-username') || 'none';
1639   return '' if $global_unique eq 'disabled';
1640
1641   $self->lock_table;
1642
1643   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1644   unless ( $part_svc ) {
1645     return 'unknown svcpart '. $self->svcpart;
1646   }
1647
1648   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1649                  qsearch( 'svc_acct', { 'username' => $self->username } );
1650   return gettext('username_in_use')
1651     if $global_unique eq 'username' && @dup_user;
1652
1653   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1654                        qsearch( 'svc_acct', { 'username' => $self->username,
1655                                               'domsvc'   => $self->domsvc } );
1656   return gettext('username_in_use')
1657     if $global_unique eq 'username@domain' && @dup_userdomain;
1658
1659   my @dup_uid;
1660   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1661        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1662     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1663                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1664   } else {
1665     @dup_uid = ();
1666   }
1667
1668   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1669     my $exports = FS::part_export::export_info('svc_acct');
1670     my %conflict_user_svcpart;
1671     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1672
1673     foreach my $part_export ( $part_svc->part_export ) {
1674
1675       #this will catch to the same exact export
1676       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1677
1678       #this will catch to exports w/same exporthost+type ???
1679       #my @other_part_export = qsearch('part_export', {
1680       #  'machine'    => $part_export->machine,
1681       #  'exporttype' => $part_export->exporttype,
1682       #} );
1683       #foreach my $other_part_export ( @other_part_export ) {
1684       #  push @svcparts, map { $_->svcpart }
1685       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1686       #}
1687
1688       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1689       #silly kludge to avoid uninitialized value errors
1690       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1691                      ? $exports->{$part_export->exporttype}{'nodomain'}
1692                      : '';
1693       if ( $nodomain =~ /^Y/i ) {
1694         $conflict_user_svcpart{$_} = $part_export->exportnum
1695           foreach @svcparts;
1696       } else {
1697         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1698           foreach @svcparts;
1699       }
1700     }
1701
1702     foreach my $dup_user ( @dup_user ) {
1703       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1704       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1705         return "duplicate username ". $self->username.
1706                ": conflicts with svcnum ". $dup_user->svcnum.
1707                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1708       }
1709     }
1710
1711     foreach my $dup_userdomain ( @dup_userdomain ) {
1712       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1713       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1714         return "duplicate username\@domain ". $self->email.
1715                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1716                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1717       }
1718     }
1719
1720     foreach my $dup_uid ( @dup_uid ) {
1721       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1722       if ( exists($conflict_user_svcpart{$dup_svcpart})
1723            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1724         return "duplicate uid ". $self->uid.
1725                ": conflicts with svcnum ". $dup_uid->svcnum.
1726                " via exportnum ".
1727                ( $conflict_user_svcpart{$dup_svcpart}
1728                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1729       }
1730     }
1731
1732   }
1733
1734   return '';
1735
1736 }
1737
1738 =item radius
1739
1740 Depriciated, use radius_reply instead.
1741
1742 =cut
1743
1744 sub radius {
1745   carp "FS::svc_acct::radius depriciated, use radius_reply";
1746   $_[0]->radius_reply;
1747 }
1748
1749 =item radius_reply
1750
1751 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1752 reply attributes of this record.
1753
1754 Note that this is now the preferred method for reading RADIUS attributes -
1755 accessing the columns directly is discouraged, as the column names are
1756 expected to change in the future.
1757
1758 =cut
1759
1760 sub radius_reply {
1761   my $self = shift;
1762
1763   return %{ $self->{'radius_reply'} }
1764     if exists $self->{'radius_reply'};
1765
1766   my %reply =
1767     map {
1768       /^(radius_(.*))$/;
1769       my($column, $attrib) = ($1, $2);
1770       #$attrib =~ s/_/\-/g;
1771       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1772     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1773
1774   if ( $self->slipip && $self->slipip ne '0e0' ) {
1775     $reply{$radius_ip} = $self->slipip;
1776   }
1777
1778   if ( $self->seconds !~ /^$/ ) {
1779     $reply{'Session-Timeout'} = $self->seconds;
1780   }
1781
1782   if ( $conf->exists('radius-chillispot-max') ) {
1783     #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1784
1785     #hmm.  just because sqlradius.pm says so?
1786     my %whatis = (
1787       'input'  => 'up',
1788       'output' => 'down',
1789       'total'  => 'total',
1790     );
1791
1792     foreach my $what (qw( input output total )) {
1793       my $is = $whatis{$what}.'bytes';
1794       if ( $self->$is() =~ /\d/ ) {
1795         my $big = new Math::BigInt $self->$is();
1796         $big = new Math::BigInt '0' if $big->is_neg();
1797         my $att = "Chillispot-Max-\u$what";
1798         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1799         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1800       }
1801     }
1802
1803   }
1804
1805   %reply;
1806 }
1807
1808 =item radius_check
1809
1810 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1811 check attributes of this record.
1812
1813 Note that this is now the preferred method for reading RADIUS attributes -
1814 accessing the columns directly is discouraged, as the column names are
1815 expected to change in the future.
1816
1817 =cut
1818
1819 sub radius_check {
1820   my $self = shift;
1821
1822   return %{ $self->{'radius_check'} }
1823     if exists $self->{'radius_check'};
1824
1825   my %check =
1826     map {
1827       /^(rc_(.*))$/;
1828       my($column, $attrib) = ($1, $2);
1829       #$attrib =~ s/_/\-/g;
1830       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1831     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1832
1833
1834   my($pw_attrib, $password) = $self->radius_password;
1835   $check{$pw_attrib} = $password;
1836
1837   my $cust_svc = $self->cust_svc;
1838   if ( $cust_svc ) {
1839     my $cust_pkg = $cust_svc->cust_pkg;
1840     if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1841       $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1842     }
1843   } else {
1844     warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1845          "; can't set Expiration\n"
1846       unless $cust_svc;
1847   }
1848
1849   %check;
1850
1851 }
1852
1853 =item radius_password
1854
1855 Returns a key/value pair containing the RADIUS attribute name and value
1856 for the password.
1857
1858 =cut
1859
1860 sub radius_password {
1861   my $self = shift;
1862
1863   my $pw_attrib;
1864   if ( $self->_password_encoding eq 'ldap' ) {
1865     $pw_attrib = 'Password-With-Header';
1866   } elsif ( $self->_password_encoding eq 'crypt' ) {
1867     $pw_attrib = 'Crypt-Password';
1868   } elsif ( $self->_password_encoding eq 'plain' ) {
1869     $pw_attrib = $radius_password;
1870   } else {
1871     $pw_attrib = length($self->_password) <= 12
1872                    ? $radius_password
1873                    : 'Crypt-Password';
1874   }
1875
1876   ($pw_attrib, $self->_password);
1877
1878 }
1879
1880 =item snapshot
1881
1882 This method instructs the object to "snapshot" or freeze RADIUS check and
1883 reply attributes to the current values.
1884
1885 =cut
1886
1887 #bah, my english is too broken this morning
1888 #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
1889 #the FS::cust_pkg's replace method to trigger the correct export updates when
1890 #package dates change)
1891
1892 sub snapshot {
1893   my $self = shift;
1894
1895   $self->{$_} = { $self->$_() }
1896     foreach qw( radius_reply radius_check );
1897
1898 }
1899
1900 =item forget_snapshot
1901
1902 This methos instructs the object to forget any previously snapshotted
1903 RADIUS check and reply attributes.
1904
1905 =cut
1906
1907 sub forget_snapshot {
1908   my $self = shift;
1909
1910   delete $self->{$_}
1911     foreach qw( radius_reply radius_check );
1912
1913 }
1914
1915 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1916
1917 Returns the domain associated with this account.
1918
1919 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1920 history records.
1921
1922 =cut
1923
1924 sub domain {
1925   my $self = shift;
1926   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1927   my $svc_domain = $self->svc_domain(@_)
1928     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1929   $svc_domain->domain;
1930 }
1931
1932 =item cust_svc
1933
1934 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1935
1936 =cut
1937
1938 #inherited from svc_Common
1939
1940 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1941
1942 Returns an email address associated with the account.
1943
1944 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1945 history records.
1946
1947 =cut
1948
1949 sub email {
1950   my $self = shift;
1951   $self->username. '@'. $self->domain(@_);
1952 }
1953
1954 =item acct_snarf
1955
1956 Returns an array of FS::acct_snarf records associated with the account.
1957
1958 =cut
1959
1960 sub acct_snarf {
1961   my $self = shift;
1962   qsearch({
1963     'table'    => 'acct_snarf',
1964     'hashref'  => { 'svcnum' => $self->svcnum },
1965     #'order_by' => 'ORDER BY priority ASC',
1966   });
1967 }
1968
1969 =item cgp_rpop_hashref
1970
1971 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1972
1973 =cut
1974
1975 sub cgp_rpop_hashref {
1976   my $self = shift;
1977   { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1978 }
1979
1980 =item decrement_upbytes OCTETS
1981
1982 Decrements the I<upbytes> field of this record by the given amount.  If there
1983 is an error, returns the error, otherwise returns false.
1984
1985 =cut
1986
1987 sub decrement_upbytes {
1988   shift->_op_usage('-', 'upbytes', @_);
1989 }
1990
1991 =item increment_upbytes OCTETS
1992
1993 Increments the I<upbytes> field of this record by the given amount.  If there
1994 is an error, returns the error, otherwise returns false.
1995
1996 =cut
1997
1998 sub increment_upbytes {
1999   shift->_op_usage('+', 'upbytes', @_);
2000 }
2001
2002 =item decrement_downbytes OCTETS
2003
2004 Decrements the I<downbytes> field of this record by the given amount.  If there
2005 is an error, returns the error, otherwise returns false.
2006
2007 =cut
2008
2009 sub decrement_downbytes {
2010   shift->_op_usage('-', 'downbytes', @_);
2011 }
2012
2013 =item increment_downbytes OCTETS
2014
2015 Increments the I<downbytes> field of this record by the given amount.  If there
2016 is an error, returns the error, otherwise returns false.
2017
2018 =cut
2019
2020 sub increment_downbytes {
2021   shift->_op_usage('+', 'downbytes', @_);
2022 }
2023
2024 =item decrement_totalbytes OCTETS
2025
2026 Decrements the I<totalbytes> field of this record by the given amount.  If there
2027 is an error, returns the error, otherwise returns false.
2028
2029 =cut
2030
2031 sub decrement_totalbytes {
2032   shift->_op_usage('-', 'totalbytes', @_);
2033 }
2034
2035 =item increment_totalbytes OCTETS
2036
2037 Increments the I<totalbytes> field of this record by the given amount.  If there
2038 is an error, returns the error, otherwise returns false.
2039
2040 =cut
2041
2042 sub increment_totalbytes {
2043   shift->_op_usage('+', 'totalbytes', @_);
2044 }
2045
2046 =item decrement_seconds SECONDS
2047
2048 Decrements the I<seconds> field of this record by the given amount.  If there
2049 is an error, returns the error, otherwise returns false.
2050
2051 =cut
2052
2053 sub decrement_seconds {
2054   shift->_op_usage('-', 'seconds', @_);
2055 }
2056
2057 =item increment_seconds SECONDS
2058
2059 Increments the I<seconds> field of this record by the given amount.  If there
2060 is an error, returns the error, otherwise returns false.
2061
2062 =cut
2063
2064 sub increment_seconds {
2065   shift->_op_usage('+', 'seconds', @_);
2066 }
2067
2068
2069 my %op2action = (
2070   '-' => 'suspend',
2071   '+' => 'unsuspend',
2072 );
2073 my %op2condition = (
2074   '-' => sub { my($self, $column, $amount) = @_;
2075                $self->$column - $amount <= 0;
2076              },
2077   '+' => sub { my($self, $column, $amount) = @_;
2078                ($self->$column || 0) + $amount > 0;
2079              },
2080 );
2081 my %op2warncondition = (
2082   '-' => sub { my($self, $column, $amount) = @_;
2083                my $threshold = $column . '_threshold';
2084                $self->$column - $amount <= $self->$threshold + 0;
2085              },
2086   '+' => sub { my($self, $column, $amount) = @_;
2087                ($self->$column || 0) + $amount > 0;
2088              },
2089 );
2090
2091 sub _op_usage {
2092   my( $self, $op, $column, $amount ) = @_;
2093
2094   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2095        ' ('. $self->email. "): $op $amount\n"
2096     if $DEBUG;
2097
2098   return '' unless $amount;
2099
2100   local $SIG{HUP} = 'IGNORE';
2101   local $SIG{INT} = 'IGNORE';
2102   local $SIG{QUIT} = 'IGNORE';
2103   local $SIG{TERM} = 'IGNORE';
2104   local $SIG{TSTP} = 'IGNORE';
2105   local $SIG{PIPE} = 'IGNORE';
2106
2107   my $oldAutoCommit = $FS::UID::AutoCommit;
2108   local $FS::UID::AutoCommit = 0;
2109   my $dbh = dbh;
2110
2111   my $sql = "UPDATE svc_acct SET $column = ".
2112             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2113             " $op ? WHERE svcnum = ?";
2114   warn "$me $sql\n"
2115     if $DEBUG;
2116
2117   my $sth = $dbh->prepare( $sql )
2118     or die "Error preparing $sql: ". $dbh->errstr;
2119   my $rv = $sth->execute($amount, $self->svcnum);
2120   die "Error executing $sql: ". $sth->errstr
2121     unless defined($rv);
2122   die "Can't update $column for svcnum". $self->svcnum
2123     if $rv == 0;
2124
2125   #$self->snapshot; #not necessary, we retain the old values
2126   #create an object with the updated usage values
2127   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2128   #call exports
2129   my $error = $new->replace($self);
2130   if ( $error ) {
2131     $dbh->rollback if $oldAutoCommit;
2132     return "Error replacing: $error";
2133   }
2134
2135   #overlimit_action eq 'cancel' handling
2136   my $cust_pkg = $self->cust_svc->cust_pkg;
2137   if ( $cust_pkg
2138        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2139        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2140      )
2141   {
2142
2143     my $error = $cust_pkg->cancel; #XXX should have a reason
2144     if ( $error ) {
2145       $dbh->rollback if $oldAutoCommit;
2146       return "Error cancelling: $error";
2147     }
2148
2149     #nothing else is relevant if we're cancelling, so commit & return success
2150     warn "$me update successful; committing\n"
2151       if $DEBUG;
2152     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2153     return '';
2154
2155   }
2156
2157   my $action = $op2action{$op};
2158
2159   if ( &{$op2condition{$op}}($self, $column, $amount) &&
2160         ( $action eq 'suspend'   && !$self->overlimit
2161        || $action eq 'unsuspend' &&  $self->overlimit )
2162      ) {
2163
2164     my $error = $self->_op_overlimit($action);
2165     if ( $error ) {
2166       $dbh->rollback if $oldAutoCommit;
2167       return $error;
2168     }
2169
2170   }
2171
2172   if ( $conf->exists("svc_acct-usage_$action")
2173        && &{$op2condition{$op}}($self, $column, $amount)    ) {
2174     #my $error = $self->$action();
2175     my $error = $self->cust_svc->cust_pkg->$action();
2176     # $error ||= $self->overlimit($action);
2177     if ( $error ) {
2178       $dbh->rollback if $oldAutoCommit;
2179       return "Error ${action}ing: $error";
2180     }
2181   }
2182
2183   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2184     my $wqueue = new FS::queue {
2185       'svcnum' => $self->svcnum,
2186       'job'    => 'FS::svc_acct::reached_threshold',
2187     };
2188
2189     my $to = '';
2190     if ($op eq '-'){
2191       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2192     }
2193
2194     # x_threshold race
2195     my $error = $wqueue->insert(
2196       'svcnum' => $self->svcnum,
2197       'op'     => $op,
2198       'column' => $column,
2199       'to'     => $to,
2200     );
2201     if ( $error ) {
2202       $dbh->rollback if $oldAutoCommit;
2203       return "Error queuing threshold activity: $error";
2204     }
2205   }
2206
2207   warn "$me update successful; committing\n"
2208     if $DEBUG;
2209   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2210   '';
2211
2212 }
2213
2214 sub _op_overlimit {
2215   my( $self, $action ) = @_;
2216
2217   local $SIG{HUP} = 'IGNORE';
2218   local $SIG{INT} = 'IGNORE';
2219   local $SIG{QUIT} = 'IGNORE';
2220   local $SIG{TERM} = 'IGNORE';
2221   local $SIG{TSTP} = 'IGNORE';
2222   local $SIG{PIPE} = 'IGNORE';
2223
2224   my $oldAutoCommit = $FS::UID::AutoCommit;
2225   local $FS::UID::AutoCommit = 0;
2226   my $dbh = dbh;
2227
2228   my $cust_pkg = $self->cust_svc->cust_pkg;
2229
2230   my $conf_overlimit =
2231     $cust_pkg
2232       ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2233       : $conf->config('overlimit_groups');
2234
2235   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2236
2237     my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2238     next unless $groups;
2239
2240     my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2241
2242     my $other = new FS::svc_acct $self->hashref;
2243     $other->usergroup( $gref );
2244
2245     my($new,$old);
2246     if ($action eq 'suspend') {
2247       $new = $other;
2248       $old = $self;
2249     } else { # $action eq 'unsuspend'
2250       $new = $self;
2251       $old = $other;
2252     }
2253
2254     my $error = $part_export->export_replace($new, $old)
2255                 || $self->overlimit($action);
2256
2257     if ( $error ) {
2258       $dbh->rollback if $oldAutoCommit;
2259       return "Error replacing radius groups: $error";
2260     }
2261
2262   }
2263
2264   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2265   '';
2266
2267 }
2268
2269 sub set_usage {
2270   my( $self, $valueref, %options ) = @_;
2271
2272   warn "$me set_usage called for svcnum ". $self->svcnum.
2273        ' ('. $self->email. "): ".
2274        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2275     if $DEBUG;
2276
2277   local $SIG{HUP} = 'IGNORE';
2278   local $SIG{INT} = 'IGNORE';
2279   local $SIG{QUIT} = 'IGNORE';
2280   local $SIG{TERM} = 'IGNORE';
2281   local $SIG{TSTP} = 'IGNORE';
2282   local $SIG{PIPE} = 'IGNORE';
2283
2284   local $FS::svc_Common::noexport_hack = 1;
2285   my $oldAutoCommit = $FS::UID::AutoCommit;
2286   local $FS::UID::AutoCommit = 0;
2287   my $dbh = dbh;
2288
2289   my $reset = 0;
2290   my %handyhash = ();
2291   if ( $options{null} ) {
2292     %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2293                    qw( seconds upbytes downbytes totalbytes )
2294                  );
2295   }
2296   foreach my $field (keys %$valueref){
2297     $reset = 1 if $valueref->{$field};
2298     $self->setfield($field, $valueref->{$field});
2299     $self->setfield( $field.'_threshold',
2300                      int($self->getfield($field)
2301                          * ( $conf->exists('svc_acct-usage_threshold')
2302                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
2303                              : 0.20
2304                            )
2305                        )
2306                      );
2307     $handyhash{$field} = $self->getfield($field);
2308     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2309   }
2310   #my $error = $self->replace;   #NO! we avoid the call to ->check for
2311   #die $error if $error;         #services not explicity changed via the UI
2312
2313   my $sql = "UPDATE svc_acct SET " .
2314     join (',', map { "$_ =  ?" } (keys %handyhash) ).
2315     " WHERE svcnum = ". $self->svcnum;
2316
2317   warn "$me $sql\n"
2318     if $DEBUG;
2319
2320   if (scalar(keys %handyhash)) {
2321     my $sth = $dbh->prepare( $sql )
2322       or die "Error preparing $sql: ". $dbh->errstr;
2323     my $rv = $sth->execute(values %handyhash);
2324     die "Error executing $sql: ". $sth->errstr
2325       unless defined($rv);
2326     die "Can't update usage for svcnum ". $self->svcnum
2327       if $rv == 0;
2328   }
2329
2330   #$self->snapshot; #not necessary, we retain the old values
2331   #create an object with the updated usage values
2332   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2333   local($FS::Record::nowarn_identical) = 1;
2334   my $error = $new->replace($self); #call exports
2335   if ( $error ) {
2336     $dbh->rollback if $oldAutoCommit;
2337     return "Error replacing: $error";
2338   }
2339
2340   if ( $reset ) {
2341
2342     my $error = '';
2343
2344     $error = $self->_op_overlimit('unsuspend')
2345       if $self->overlimit;;
2346
2347     $error ||= $self->cust_svc->cust_pkg->unsuspend
2348       if $conf->exists("svc_acct-usage_unsuspend");
2349
2350     if ( $error ) {
2351       $dbh->rollback if $oldAutoCommit;
2352       return "Error unsuspending: $error";
2353     }
2354
2355   }
2356
2357   warn "$me update successful; committing\n"
2358     if $DEBUG;
2359   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2360   '';
2361
2362 }
2363
2364
2365 =item recharge HASHREF
2366
2367   Increments usage columns by the amount specified in HASHREF as
2368   column=>amount pairs.
2369
2370 =cut
2371
2372 sub recharge {
2373   my ($self, $vhash) = @_;
2374
2375   if ( $DEBUG ) {
2376     warn "[$me] recharge called on $self: ". Dumper($self).
2377          "\nwith vhash: ". Dumper($vhash);
2378   }
2379
2380   my $oldAutoCommit = $FS::UID::AutoCommit;
2381   local $FS::UID::AutoCommit = 0;
2382   my $dbh = dbh;
2383   my $error = '';
2384
2385   foreach my $column (keys %$vhash){
2386     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2387   }
2388
2389   if ( $error ) {
2390     $dbh->rollback if $oldAutoCommit;
2391   }else{
2392     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2393   }
2394   return $error;
2395 }
2396
2397 =item is_rechargeable
2398
2399 Returns true if this svc_account can be "recharged" and false otherwise.
2400
2401 =cut
2402
2403 sub is_rechargable {
2404   my $self = shift;
2405   $self->seconds ne ''
2406     || $self->upbytes ne ''
2407     || $self->downbytes ne ''
2408     || $self->totalbytes ne '';
2409 }
2410
2411 =item seconds_since TIMESTAMP
2412
2413 Returns the number of seconds this account has been online since TIMESTAMP,
2414 according to the session monitor (see L<FS::Session>).
2415
2416 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2417 L<Time::Local> and L<Date::Parse> for conversion functions.
2418
2419 =cut
2420
2421 #note: POD here, implementation in FS::cust_svc
2422 sub seconds_since {
2423   my $self = shift;
2424   $self->cust_svc->seconds_since(@_);
2425 }
2426
2427 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2428
2429 Returns the numbers of seconds this account has been online between
2430 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2431 external SQL radacct table, specified via sqlradius export.  Sessions which
2432 started in the specified range but are still open are counted from session
2433 start to the end of the range (unless they are over 1 day old, in which case
2434 they are presumed missing their stop record and not counted).  Also, sessions
2435 which end in the range but started earlier are counted from the start of the
2436 range to session end.  Finally, sessions which start before the range but end
2437 after are counted for the entire range.
2438
2439 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2440 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2441 functions.
2442
2443 =cut
2444
2445 #note: POD here, implementation in FS::cust_svc
2446 sub seconds_since_sqlradacct {
2447   my $self = shift;
2448   $self->cust_svc->seconds_since_sqlradacct(@_);
2449 }
2450
2451 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2452
2453 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2454 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2455 TIMESTAMP_END (exclusive).
2456
2457 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2458 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2459 functions.
2460
2461 =cut
2462
2463 #note: POD here, implementation in FS::cust_svc
2464 sub attribute_since_sqlradacct {
2465   my $self = shift;
2466   $self->cust_svc->attribute_since_sqlradacct(@_);
2467 }
2468
2469 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2470
2471 Returns an array of hash references of this customers login history for the
2472 given time range.  (document this better)
2473
2474 =cut
2475
2476 sub get_session_history {
2477   my $self = shift;
2478   $self->cust_svc->get_session_history(@_);
2479 }
2480
2481 =item last_login_text
2482
2483 Returns text describing the time of last login.
2484
2485 =cut
2486
2487 sub last_login_text {
2488   my $self = shift;
2489   $self->last_login ? ctime($self->last_login) : 'unknown';
2490 }
2491
2492 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2493
2494 =cut
2495
2496 sub get_cdrs {
2497   my($self, $start, $end, %opt ) = @_;
2498
2499   my $did = $self->username; #yup
2500
2501   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2502
2503   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2504
2505   #SELECT $for_update * FROM cdr
2506   #  WHERE calldate >= $start #need a conversion
2507   #    AND calldate <  $end   #ditto
2508   #    AND (    charged_party = "$did"
2509   #          OR charged_party = "$prefix$did" #if length($prefix);
2510   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2511   #               AND
2512   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2513   #             )
2514   #        )
2515   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2516
2517   my $charged_or_src;
2518   if ( length($prefix) ) {
2519     $charged_or_src =
2520       " AND (    charged_party = '$did'
2521               OR charged_party = '$prefix$did'
2522               OR ( ( charged_party IS NULL OR charged_party = '' )
2523                    AND
2524                    ( src = '$did' OR src = '$prefix$did' )
2525                  )
2526             )
2527       ";
2528   } else {
2529     $charged_or_src =
2530       " AND (    charged_party = '$did'
2531               OR ( ( charged_party IS NULL OR charged_party = '' )
2532                    AND
2533                    src = '$did'
2534                  )
2535             )
2536       ";
2537
2538   }
2539
2540   qsearch(
2541     'select'    => "$for_update *",
2542     'table'     => 'cdr',
2543     'hashref'   => {
2544                      #( freesidestatus IS NULL OR freesidestatus = '' )
2545                      'freesidestatus' => '',
2546                    },
2547     'extra_sql' => $charged_or_src,
2548
2549   );
2550
2551 }
2552
2553 =item radius_groups
2554
2555 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2556
2557 =cut
2558
2559 sub radius_groups {
2560   my $self = shift;
2561   if ( $self->usergroup ) {
2562     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2563       unless ref($self->usergroup) eq 'ARRAY';
2564     #when provisioning records, export callback runs in svc_Common.pm before
2565     #radius_usergroup records can be inserted...
2566     @{$self->usergroup};
2567   } else {
2568      my $format = shift || '';
2569      my @groups = qsearch({ 'table'         => 'radius_usergroup',
2570                             'addl_from'     => 'left join radius_group using (groupnum)',
2571                             'select'        => 'radius_group.*',
2572                             'hashref'       => { 'svcnum' => $self->svcnum },
2573                         });
2574
2575      # this is to preserve various legacy behaviour / avoid re-writing other code
2576      return map { $_->groupnum } @groups if $format eq 'NUMBERS';
2577      return map { $_->description . " (" . $_->groupname . ")" } @groups
2578         if $format eq 'COMBINED';
2579      map { $_->groupname } @groups;
2580   }
2581 }
2582
2583 =item clone_suspended
2584
2585 Constructor used by FS::part_export::_export_suspend fallback.  Document
2586 better.
2587
2588 =cut
2589
2590 sub clone_suspended {
2591   my $self = shift;
2592   my %hash = $self->hash;
2593   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2594   new FS::svc_acct \%hash;
2595 }
2596
2597 =item clone_kludge_unsuspend
2598
2599 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2600 better.
2601
2602 =cut
2603
2604 sub clone_kludge_unsuspend {
2605   my $self = shift;
2606   my %hash = $self->hash;
2607   $hash{_password} = '';
2608   new FS::svc_acct \%hash;
2609 }
2610
2611 =item check_password
2612
2613 Checks the supplied password against the (possibly encrypted) password in the
2614 database.  Returns true for a successful authentication, false for no match.
2615
2616 Currently supported encryptions are: classic DES crypt() and MD5
2617
2618 =cut
2619
2620 sub check_password {
2621   my($self, $check_password) = @_;
2622
2623   #remove old-style SUSPENDED kludge, they should be allowed to login to
2624   #self-service and pay up
2625   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2626
2627   if ( $self->_password_encoding eq 'ldap' ) {
2628
2629     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2630     return $auth->match($check_password);
2631
2632   } elsif ( $self->_password_encoding eq 'crypt' ) {
2633
2634     my $auth = from_crypt Authen::Passphrase $self->_password;
2635     return $auth->match($check_password);
2636
2637   } elsif ( $self->_password_encoding eq 'plain' ) {
2638
2639     return $check_password eq $password;
2640
2641   } else {
2642
2643     #XXX this could be replaced with Authen::Passphrase stuff
2644
2645     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2646       return 0;
2647     } elsif ( length($password) < 13 ) { #plaintext
2648       $check_password eq $password;
2649     } elsif ( length($password) == 13 ) { #traditional DES crypt
2650       crypt($check_password, $password) eq $password;
2651     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2652       unix_md5_crypt($check_password, $password) eq $password;
2653     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2654       warn "Can't check password: Blowfish encryption not yet supported, ".
2655            "svcnum ".  $self->svcnum. "\n";
2656       0;
2657     } else {
2658       warn "Can't check password: Unrecognized encryption for svcnum ".
2659            $self->svcnum. "\n";
2660       0;
2661     }
2662
2663   }
2664
2665 }
2666
2667 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2668
2669 Returns an encrypted password, either by passing through an encrypted password
2670 in the database or by encrypting a plaintext password from the database.
2671
2672 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2673 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2674 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2675 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2676 encryption type is only used if the password is not already encrypted in the
2677 database.
2678
2679 =cut
2680
2681 sub crypt_password {
2682   my $self = shift;
2683
2684   if ( $self->_password_encoding eq 'ldap' ) {
2685
2686     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2687       my $plain = $2;
2688
2689       #XXX this could be replaced with Authen::Passphrase stuff
2690
2691       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2692       if ( $encryption eq 'crypt' ) {
2693         return crypt(
2694           $self->_password,
2695           $saltset[int(rand(64))].$saltset[int(rand(64))]
2696         );
2697       } elsif ( $encryption eq 'md5' ) {
2698         return unix_md5_crypt( $self->_password );
2699       } elsif ( $encryption eq 'blowfish' ) {
2700         croak "unknown encryption method $encryption";
2701       } else {
2702         croak "unknown encryption method $encryption";
2703       }
2704
2705     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2706       return $1;
2707     }
2708
2709   } elsif ( $self->_password_encoding eq 'crypt' ) {
2710
2711     return $self->_password;
2712
2713   } elsif ( $self->_password_encoding eq 'plain' ) {
2714
2715     #XXX this could be replaced with Authen::Passphrase stuff
2716
2717     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2718     if ( $encryption eq 'crypt' ) {
2719       return crypt(
2720         $self->_password,
2721         $saltset[int(rand(64))].$saltset[int(rand(64))]
2722       );
2723     } elsif ( $encryption eq 'md5' ) {
2724       return unix_md5_crypt( $self->_password );
2725     } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2726       my $pass = sha1_base64( $self->_password );
2727       $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2728       return $pass;
2729     } elsif ( $encryption eq 'blowfish' ) {
2730       croak "unknown encryption method $encryption";
2731     } else {
2732       croak "unknown encryption method $encryption";
2733     }
2734
2735   } else {
2736
2737     if ( length($self->_password) == 13
2738          || $self->_password =~ /^\$(1|2a?)\$/
2739          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2740        )
2741     {
2742       $self->_password;
2743     } else {
2744
2745       #XXX this could be replaced with Authen::Passphrase stuff
2746
2747       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2748       if ( $encryption eq 'crypt' ) {
2749         return crypt(
2750           $self->_password,
2751           $saltset[int(rand(64))].$saltset[int(rand(64))]
2752         );
2753       } elsif ( $encryption eq 'md5' ) {
2754         return unix_md5_crypt( $self->_password );
2755       } elsif ( $encryption eq 'blowfish' ) {
2756         croak "unknown encryption method $encryption";
2757       } else {
2758         croak "unknown encryption method $encryption";
2759       }
2760
2761     }
2762
2763   }
2764
2765 }
2766
2767 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2768
2769 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2770 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2771 "{MD5}5426824942db4253f87a1009fd5d2d4".
2772
2773 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2774 to work the same as the B</crypt_password> method.
2775
2776 =cut
2777
2778 sub ldap_password {
2779   my $self = shift;
2780   #eventually should check a "password-encoding" field
2781
2782   if ( $self->_password_encoding eq 'ldap' ) {
2783
2784     return $self->_password;
2785
2786   } elsif ( $self->_password_encoding eq 'crypt' ) {
2787
2788     if ( length($self->_password) == 13 ) { #crypt
2789       return '{CRYPT}'. $self->_password;
2790     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2791       return '{MD5}'. $1;
2792     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2793     #  die "Blowfish encryption not supported in this context, svcnum ".
2794     #      $self->svcnum. "\n";
2795     } else {
2796       warn "encryption method not (yet?) supported in LDAP context";
2797       return '{CRYPT}*'; #unsupported, should not auth
2798     }
2799
2800   } elsif ( $self->_password_encoding eq 'plain' ) {
2801
2802     return '{PLAIN}'. $self->_password;
2803
2804     #return '{CLEARTEXT}'. $self->_password; #?
2805
2806   } else {
2807
2808     if ( length($self->_password) == 13 ) { #crypt
2809       return '{CRYPT}'. $self->_password;
2810     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2811       return '{MD5}'. $1;
2812     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2813       warn "Blowfish encryption not supported in this context, svcnum ".
2814           $self->svcnum. "\n";
2815       return '{CRYPT}*';
2816
2817     #are these two necessary anymore?
2818     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2819       return '{SSHA}'. $1;
2820     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2821       return '{NS-MTA-MD5}'. $1;
2822
2823     } else { #plaintext
2824       return '{PLAIN}'. $self->_password;
2825
2826       #return '{CLEARTEXT}'. $self->_password; #?
2827
2828       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2829       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2830       #if ( $encryption eq 'crypt' ) {
2831       #  return '{CRYPT}'. crypt(
2832       #    $self->_password,
2833       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2834       #  );
2835       #} elsif ( $encryption eq 'md5' ) {
2836       #  unix_md5_crypt( $self->_password );
2837       #} elsif ( $encryption eq 'blowfish' ) {
2838       #  croak "unknown encryption method $encryption";
2839       #} else {
2840       #  croak "unknown encryption method $encryption";
2841       #}
2842     }
2843
2844   }
2845
2846 }
2847
2848 =item domain_slash_username
2849
2850 Returns $domain/$username/
2851
2852 =cut
2853
2854 sub domain_slash_username {
2855   my $self = shift;
2856   $self->domain. '/'. $self->username. '/';
2857 }
2858
2859 =item virtual_maildir
2860
2861 Returns $domain/maildirs/$username/
2862
2863 =cut
2864
2865 sub virtual_maildir {
2866   my $self = shift;
2867   $self->domain. '/maildirs/'. $self->username. '/';
2868 }
2869
2870 =back
2871
2872 =head1 CLASS METHODS
2873
2874 =over 4
2875
2876 =item search HASHREF
2877
2878 Class method which returns a qsearch hash expression to search for parameters
2879 specified in HASHREF.  Valid parameters are
2880
2881 =over 4
2882
2883 =item domain
2884
2885 =item domsvc
2886
2887 =item unlinked
2888
2889 =item agentnum
2890
2891 =item pkgpart
2892
2893 Arrayref of pkgparts
2894
2895 =item pkgpart
2896
2897 =item where
2898
2899 Arrayref of additional WHERE clauses, will be ANDed together.
2900
2901 =item order_by
2902
2903 =item cust_fields
2904
2905 =back
2906
2907 =cut
2908
2909 sub search {
2910   my ($class, $params) = @_;
2911
2912   my @where = ();
2913
2914   # domain
2915   if ( $params->{'domain'} ) {
2916     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2917     #preserve previous behavior & bubble up an error if $svc_domain not found?
2918     push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2919   }
2920
2921   # domsvc
2922   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2923     push @where, "domsvc = $1";
2924   }
2925
2926   #unlinked
2927   push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2928
2929   #agentnum
2930   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2931     push @where, "agentnum = $1";
2932   }
2933
2934   #custnum
2935   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2936     push @where, "custnum = $1";
2937   }
2938
2939   #pkgpart
2940   if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2941     #XXX untaint or sql quote
2942     push @where,
2943       'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2944   }
2945
2946   # popnum
2947   if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2948     push @where, "popnum = $1";
2949   }
2950
2951   # svcpart
2952   if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2953     push @where, "svcpart = $1";
2954   }
2955
2956
2957   # here is the agent virtualization
2958   #if ($params->{CurrentUser}) {
2959   #  my $access_user =
2960   #    qsearchs('access_user', { username => $params->{CurrentUser} });
2961   #
2962   #  if ($access_user) {
2963   #    push @where, $access_user->agentnums_sql('table'=>'cust_main');
2964   #  }else{
2965   #    push @where, "1=0";
2966   #  }
2967   #} else {
2968     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2969                    'table'      => 'cust_main',
2970                    'null_right' => 'View/link unlinked services',
2971                  );
2972   #}
2973
2974   push @where, @{ $params->{'where'} } if $params->{'where'};
2975
2976   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2977
2978   my $addl_from = ' LEFT JOIN cust_svc  USING ( svcnum  ) '.
2979                   ' LEFT JOIN part_svc  USING ( svcpart ) '.
2980                   ' LEFT JOIN cust_pkg  USING ( pkgnum  ) '.
2981                   ' LEFT JOIN cust_main USING ( custnum ) ';
2982
2983   my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2984   #if ( keys %svc_acct ) {
2985   #  $count_query .= ' WHERE '.
2986   #                    join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2987   #                                      keys %svc_acct
2988   #                        );
2989   #}
2990
2991   my $sql_query = {
2992     'table'       => 'svc_acct',
2993     'hashref'     => {}, # \%svc_acct,
2994     'select'      => join(', ',
2995                        'svc_acct.*',
2996                        'part_svc.svc',
2997                        'cust_main.custnum',
2998                        FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2999                      ),
3000     'addl_from'   => $addl_from,
3001     'extra_sql'   => $extra_sql,
3002     'order_by'    => $params->{'order_by'},
3003     'count_query' => $count_query,
3004   };
3005
3006 }
3007
3008 =back
3009
3010 =head1 SUBROUTINES
3011
3012 =over 4
3013
3014 =item send_email
3015
3016 This is the FS::svc_acct job-queue-able version.  It still uses
3017 FS::Misc::send_email under-the-hood.
3018
3019 =cut
3020
3021 sub send_email {
3022   my %opt = @_;
3023
3024   eval "use FS::Misc qw(send_email)";
3025   die $@ if $@;
3026
3027   $opt{mimetype} ||= 'text/plain';
3028   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3029
3030   my $error = send_email(
3031     'from'         => $opt{from},
3032     'to'           => $opt{to},
3033     'subject'      => $opt{subject},
3034     'content-type' => $opt{mimetype},
3035     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
3036   );
3037   die $error if $error;
3038 }
3039
3040 =item check_and_rebuild_fuzzyfiles
3041
3042 =cut
3043
3044 sub check_and_rebuild_fuzzyfiles {
3045   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3046   -e "$dir/svc_acct.username"
3047     or &rebuild_fuzzyfiles;
3048 }
3049
3050 =item rebuild_fuzzyfiles
3051
3052 =cut
3053
3054 sub rebuild_fuzzyfiles {
3055
3056   use Fcntl qw(:flock);
3057
3058   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3059
3060   #username
3061
3062   open(USERNAMELOCK,">>$dir/svc_acct.username")
3063     or die "can't open $dir/svc_acct.username: $!";
3064   flock(USERNAMELOCK,LOCK_EX)
3065     or die "can't lock $dir/svc_acct.username: $!";
3066
3067   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
3068
3069   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
3070     or die "can't open $dir/svc_acct.username.tmp: $!";
3071   print USERNAMECACHE join("\n", @all_username), "\n";
3072   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
3073
3074   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
3075   close USERNAMELOCK;
3076
3077 }
3078
3079 =item all_username
3080
3081 =cut
3082
3083 sub all_username {
3084   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3085   open(USERNAMECACHE,"<$dir/svc_acct.username")
3086     or die "can't open $dir/svc_acct.username: $!";
3087   my @array = map { chomp; $_; } <USERNAMECACHE>;
3088   close USERNAMECACHE;
3089   \@array;
3090 }
3091
3092 =item append_fuzzyfiles USERNAME
3093
3094 =cut
3095
3096 sub append_fuzzyfiles {
3097   my $username = shift;
3098
3099   &check_and_rebuild_fuzzyfiles;
3100
3101   use Fcntl qw(:flock);
3102
3103   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3104
3105   open(USERNAME,">>$dir/svc_acct.username")
3106     or die "can't open $dir/svc_acct.username: $!";
3107   flock(USERNAME,LOCK_EX)
3108     or die "can't lock $dir/svc_acct.username: $!";
3109
3110   print USERNAME "$username\n";
3111
3112   flock(USERNAME,LOCK_UN)
3113     or die "can't unlock $dir/svc_acct.username: $!";
3114   close USERNAME;
3115
3116   1;
3117 }
3118
3119
3120 =item reached_threshold
3121
3122 Performs some activities when svc_acct thresholds (such as number of seconds
3123 remaining) are reached.
3124
3125 =cut
3126
3127 sub reached_threshold {
3128   my %opt = @_;
3129
3130   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3131   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3132
3133   if ( $opt{'op'} eq '+' ){
3134     $svc_acct->setfield( $opt{'column'}.'_threshold',
3135                          int($svc_acct->getfield($opt{'column'})
3136                              * ( $conf->exists('svc_acct-usage_threshold')
3137                                  ? $conf->config('svc_acct-usage_threshold')/100
3138                                  : 0.80
3139                                )
3140                          )
3141                        );
3142     my $error = $svc_acct->replace;
3143     die $error if $error;
3144   }elsif ( $opt{'op'} eq '-' ){
3145
3146     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3147     return '' if ($threshold eq '' );
3148
3149     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3150     my $error = $svc_acct->replace;
3151     die $error if $error; # email next time, i guess
3152
3153     if ( $warning_template ) {
3154       eval "use FS::Misc qw(send_email)";
3155       die $@ if $@;
3156
3157       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
3158       my $cust_main = $cust_pkg->cust_main;
3159
3160       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3161                                $cust_main->invoicing_list,
3162                                ($opt{'to'} ? $opt{'to'} : ())
3163                    );
3164
3165       my $mimetype = $warning_mimetype;
3166       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3167
3168       my $body       =  $warning_template->fill_in( HASH => {
3169                         'custnum'   => $cust_main->custnum,
3170                         'username'  => $svc_acct->username,
3171                         'password'  => $svc_acct->_password,
3172                         'first'     => $cust_main->first,
3173                         'last'      => $cust_main->getfield('last'),
3174                         'pkg'       => $cust_pkg->part_pkg->pkg,
3175                         'column'    => $opt{'column'},
3176                         'amount'    => $opt{'column'} =~/bytes/
3177                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3178                                        : $svc_acct->getfield($opt{'column'}),
3179                         'threshold' => $opt{'column'} =~/bytes/
3180                                        ? FS::UI::bytecount::display_bytecount($threshold)
3181                                        : $threshold,
3182                       } );
3183
3184
3185       my $error = send_email(
3186         'from'         => $warning_from,
3187         'to'           => $to,
3188         'subject'      => $warning_subject,
3189         'content-type' => $mimetype,
3190         'body'         => [ map "$_\n", split("\n", $body) ],
3191       );
3192       die $error if $error;
3193     }
3194   }else{
3195     die "unknown op: " . $opt{'op'};
3196   }
3197 }
3198
3199 =back
3200
3201 =head1 BUGS
3202
3203 The $recref stuff in sub check should be cleaned up.
3204
3205 The suspend, unsuspend and cancel methods update the database, but not the
3206 current object.  This is probably a bug as it's unexpected and
3207 counterintuitive.
3208
3209 insertion of RADIUS group stuff in insert could be done with child_objects now
3210 (would probably clean up export of them too)
3211
3212 _op_usage and set_usage bypass the history... maybe they shouldn't
3213
3214 =head1 SEE ALSO
3215
3216 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3217 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3218 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3219 L<freeside-queued>), L<FS::svc_acct_pop>,
3220 schema.html from the base documentation.
3221
3222 =cut
3223
3224 1;