FS/FS/svc_acct.pm

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