* Add ability to have a NO_UPDATE field in SQL tables, which field will
[interchange.git] / lib / Vend / UserDB.pm
1 # Vend::UserDB - Interchange user database functions
2 #
3 # Copyright (C) 2002-2015 Interchange Development Group
4 # Copyright (C) 1996-2002 Red Hat, Inc.
5 #
6 # This program is free software; you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 2 of the License, or
9 # (at your option) any later version.
10 #
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
15
16 package Vend::UserDB;
17
18 $VERSION = '2.67';
19
20 use vars qw!
21         $VERSION
22         @S_FIELDS @B_FIELDS @P_FIELDS @I_FIELDS
23         %S_to_B %B_to_S
24         $USERNAME_GOOD_CHARS
25         $Has_Bcrypt
26 !;
27
28 use Vend::Data;
29 use Vend::Util;
30 use Vend::Safe;
31 use strict;
32 no warnings qw(uninitialized numeric);
33
34 {
35     local $@;
36     eval {
37         require Digest::Bcrypt;
38         require Crypt::Random;
39     };
40     unless ($@) {
41         $Has_Bcrypt = 1;
42     }
43 }
44
45 use constant BCOST => 13;
46
47 # Map between bcrypt identifier letter and "pre-digested" encryption type
48 my %cipher_map = qw/
49     s   sha1
50     m   md5
51     n   md5_salted
52     c   default
53 /;
54
55 my $ready = new Vend::Safe;
56
57 # The object encryption methods take three arguments: object, password, and
58 # mystery meat. If called in the context of new_account(), the mystery meat
59 # is the salt (which is not always used). If called in the context of
60 # login(), then the mystery meat is the entire password field from the
61 # database (with salt, if applicable).
62 my %enc_subs = (
63     default => \&enc_default,
64     md5 => \&enc_md5,
65     md5_salted => \&enc_md5_salted,
66     sha1 => \&enc_sha1,
67     bcrypt => \&enc_bcrypt,
68 );
69
70 sub enc_default {
71     my $obj = shift;
72     my ($pwd, $salt) = @_;
73     return crypt($pwd, $salt);
74 }
75
76 sub enc_md5 {
77     my $obj = shift;
78     return Digest::MD5::md5_hex(shift);
79 }
80
81 # This particular md5_salted encryption stores the salt with the password
82 # in colon-separated format: /.+:(..)/. It is compatible with Zen Cart.
83 # Detecting context based on the length of the mystery meat is a little
84 # hokey; it would be more ideal to specify or detect the context 
85 # explicitly in/from the object itself (or as a named/separate parameter).
86 sub enc_md5_salted {
87     my ($obj, $password, $mystery_meat) = @_;
88
89     my $encrypted;
90     my $return_salt;
91     my $mystery_meat_length = length $mystery_meat;
92     if ($mystery_meat_length == 35) {
93         # Extract only the salt; we don't need the database password here.
94         my (undef, $db_salt) = split(':', $mystery_meat);
95         $encrypted = Digest::MD5::md5_hex($db_salt . $password);
96         $return_salt = $db_salt;
97     }
98     else {
99         if ($mystery_meat_length != 2) {
100             # Assume the mystery meat is a salt and soldier on anyway.
101             ::logError("Unrecognized salt for md5_salted encryption.");
102         }
103         $return_salt = $mystery_meat;
104         $encrypted = Digest::MD5::md5_hex($return_salt . $password);
105     }
106
107     return "$encrypted:$return_salt";
108 }
109
110 sub enc_sha1 {
111     my $obj = shift;
112     unless ($Vend::Util::SHA1) {
113         $obj->log_either('SHA passwords unavailable. Is Digest::SHA installed?');
114         return;
115     }
116     return Vend::Util::sha1_hex(shift);
117 }
118
119 sub enc_bcrypt {
120     my $obj = shift;
121     unless ($Has_Bcrypt) {
122         $obj->log_either('Bcrypt passwords unavailable. Are Digest::Bcrypt and Crypt::Random installed?');
123         return;
124     }
125     my ($password, $salt) = @_;
126     my $store = bmarshal($salt);
127     my $opt = $obj->{OPTIONS} || {};
128
129     my $bcrypt = Digest::Bcrypt->new;
130
131     my $salt =
132         $store->{salt}
133         ||
134         Crypt::Random::makerandom_octet(
135             Length   => 16, # bcrypt requirement
136             Strength =>  0, # /dev/urandom instead of /dev/random
137         )
138     ;
139     my $cost = bcost($opt, $store);
140
141     $bcrypt->cost($cost);
142     $bcrypt->salt($salt);
143     $bcrypt->add($obj->brpad($password, $opt, $store->{cipher}));
144
145     return bserialize($bcrypt, $store->{cipher});
146 }
147
148 sub bcost {
149     my $opt = shift;
150     my $store = shift || {};
151     return $store->{cost} || $opt->{cost} || BCOST;
152 }
153
154 sub brpad {
155     my $obj = shift;
156     my ($data, $opt, $cipher) = @_;
157
158     # If passwords are already stored SHA1, MD5, or crypt(),
159     # and there is no desire to allow promote to organically
160     # update them, the existing encrypted passwords can be
161     # bcrypted wholesale and future submission by users will
162     # "pre-digest" to the original encrypted structure
163     # for comparison against the bcrypt hashes.
164     #
165     # This is indicated by the structure of the cipher:
166     # * $2c$XX$ - original crypt() password with XX salt
167     # * $2m$ - plain MD5 digest on password
168     # * $2n$XX$ - salted MD5 digest on password
169     # * $2s$ - plain SHA1 digest on password
170
171     $data = $obj->pre_digest($data, $cipher);
172
173     # Increase difficulty to brute force passwords by right padding out
174     # to at least 72 character length. Most effective with "pepper" set
175     # in catalog config.
176
177     while (length ($data) < 72) {
178         my $md5 = Digest::MD5->new;
179         $md5->add($opt->{bcrypt_pepper})
180             if $opt->{bcrypt_pepper};
181         $data .= $md5->add($data)->b64digest;
182     }
183     return $data;
184 }
185
186 sub bserialize {
187     my $bcrypt = shift;
188     my $cipher = shift || '$2y$';
189
190     my $encoded_salt = substr (MIME::Base64::encode_base64($bcrypt->salt,''),0,-2);
191
192     return $cipher .
193         join (
194             '$',
195             sprintf ('%02d', $bcrypt->cost),
196             $encoded_salt . $bcrypt->b64digest,
197         )
198     ;
199 }
200
201 sub bmarshal {
202     local $_ = shift;
203
204     my $cipher = '';
205     s/^(\$2(?:[yms]|[nc]\$..)\$)//
206         and $cipher = $1;
207
208     return {} unless $cipher;
209
210     my ($cost, $combined) = grep { /\S/ } split /\$/;
211     my ($encoded_salt, $hash) = $combined =~ /^(.{22})(.*)$/;
212
213     return {} if
214         $cost < 1
215         ||
216         $cost > 31
217         ||
218         $encoded_salt =~ m{[^a-z0-9+/]}i
219         ||
220         ($hash || '-') =~ m{[^a-z0-9+/]}i
221     ;
222
223     return {
224         cipher => $cipher,
225         salt => MIME::Base64::decode_base64("$encoded_salt=="),
226         cost => $cost,
227         hash => $hash,
228     };
229 }
230
231 sub pre_digest {
232     my $obj = shift;
233     my $data = shift;
234     my $cipher = shift || '';
235     my ($id, $salt) = grep { /\S/ } split /\$/, $cipher;
236
237     # Starts with "2" or not bcrypt
238     $id =~ s/^2//
239         or return $data;
240
241     # Must have routine key defined in %cipher_map
242     my $key = $cipher_map{$id}
243         or return $data;
244
245     return $enc_subs{$key}->($obj, $data, $salt);
246 }
247
248 sub construct_bcrypt {
249     my $opt = shift;
250
251     my $bstruct =
252         __PACKAGE__
253             -> new(profile => $opt->{profile})
254             -> do_crypt($opt->{password})
255     ;
256
257     die sprintf (
258         q{Encryption type for profile '%s' must be bcrypt},
259         $opt->{profile} || 'default'
260     )
261         unless substr ($bstruct, 0, 4) eq '$2y$';
262
263     return $bstruct unless my $type = $opt->{type};
264
265     my %type_map = (crypt => 'c', reverse %cipher_map);
266     my $cipher = $type_map{ $type }
267         or die "$type is an unrecognized crypt type";
268
269     my $salt =
270         $cipher eq 'n' ? substr ($opt->{password}, -2) :
271         $cipher eq 'c' ? substr ($opt->{password}, 0, 2)
272                        : ''
273     ;
274     $salt &&= '$' . $salt;
275
276     $bstruct =~ s/y/$cipher$salt/;
277
278     return $bstruct;
279 }
280
281 # Maps the length of the encrypted data to the algorithm that
282 # produces it, or the identifier of the format from modular
283 # crypt format (MCF) in the case of bcrypt.
284 my %enc_id = qw/
285     13      default
286     32      md5
287     35      md5_salted
288     40      sha1
289     $2      bcrypt
290 /;
291
292 sub determine_cipher {
293     my $hash = shift;
294     my ($cipher) = $hash =~ /^(\$\d+)/;
295     return $cipher || length ($hash);
296 }
297
298 =head1 NAME
299
300 UserDB.pm -- Interchange User Database Functions
301
302 =head1 SYNOPSIS
303
304 userdb $function, %options
305
306 =head1 DESCRIPTION
307
308 The Interchange user database saves information for users, including shipping,
309 billing, and preference information.  It allows the user to return to a
310 previous session without the requirement for a "cookie" or other persistent
311 session information.
312
313 It is object-oriented and called via the [userdb] usertag, which calls the
314 userdb subroutine.
315
316 It restores and manipulates the form values normally stored in the user session
317 values -- the ones set in forms and read through the C<[value variable]> tags.
318 A special function allows saving of shopping cart contents.
319
320 The preference, billing, and shipping information is keyed so that different
321 sets of information may be saved, providing and "address_book" function that
322 can save more than one shipping and/or billing address. The set to restore
323 is selected by the form values C<s_nickname>, C<b_nickname>, and C<p_nickname>.
324
325 =cut
326
327 =head1 METHODS
328
329 User login:
330
331     $obj->login();        # Form values are
332                           # mv_username, mv_password
333
334 Create account:
335
336     $obj->new_account();  # Form values are
337                           # mv_username, mv_password, mv_verify
338
339 Change password:
340
341     $obj->change_pass();  # Form values are
342                           # mv_username, mv_password_old, mv_password, mv_verify(new)
343
344 Get, set user information:
345
346     $obj->get_values();
347     $obj->set_values();
348     $obj->clear_values();
349
350 Save, restore filed user information:
351
352     $obj->get_shipping();
353     $obj->set_shipping();
354
355     $obj->get_billing();
356     $obj->set_billing();
357
358     $obj->get_preferences();
359     $obj->set_preferences();
360
361     $obj->get_cart();
362     $obj->set_cart();
363
364 =head2 Shipping Address Book
365
366 The shipping address book saves information relevant to shipping the
367 order. In its simplest form, this can be the only address book needed.
368 By default these form values are included:
369
370         s_nickname
371         name
372         address
373         city
374         state
375         zip
376         country
377         phone_day
378         mv_shipmode
379
380 The values are saved with the $obj->set_shipping() method and restored 
381 with $obj->get_shipping. A list of the keys available is kept in the
382 form value C<address_book>, suitable for iteration in an HTML select
383 box or in a set of links.
384
385 =cut
386
387 @S_FIELDS = ( 
388 qw!
389         s_nickname
390         company
391         name
392         fname
393         lname
394         address
395         address1
396         address2
397         address3
398         city
399         state
400         zip
401         country 
402         phone_day
403         mv_shipmode
404   !
405 );
406
407 =head2 Accounts Book
408
409 The accounts book saves information relevant to billing the
410 order. By default these form values are included:
411
412         b_nickname
413         b_name
414         b_address
415         b_city
416         b_state
417         b_zip
418         b_country
419         b_phone
420         mv_credit_card_type
421         mv_credit_card_exp_month
422         mv_credit_card_exp_year
423         mv_credit_card_reference
424
425 The values are saved with the $obj->set_billing() method and restored 
426 with $obj->get_billing. A list of the keys available is kept in the
427 form value C<accounts>, suitable for iteration in an HTML select
428 box or in a set of links.
429
430 =cut
431
432 @B_FIELDS = ( 
433 qw!
434         b_nickname
435         b_name
436         b_fname
437         b_lname
438         b_address
439         b_address1
440         b_address2
441         b_address3
442         b_city
443         b_state
444         b_zip
445         b_country       
446         b_phone
447         purchase_order
448         mv_credit_card_type
449         mv_credit_card_exp_month
450         mv_credit_card_exp_year
451         mv_credit_card_reference
452         !
453 );
454
455 =head2 Preferences
456
457 Preferences are miscellaneous session information. They include
458 by default the fields C<email>, C<fax>, C<phone_night>,
459 and C<fax_order>. The field C<p_nickname> acts as a key to select
460 the preference set.
461
462 =head2 Locations
463
464 There are several database locations that have special purposes. These
465 fields are not saved as user values.
466
467 =over
468
469 =item USERNAME                          default: username
470
471 The username or key field of the database table.
472
473 =item BILLING                           default: accounts
474
475 Billing address hash field.
476
477 =item SHIPPING                          default: address_book
478
479 Shipping address hash field.
480
481 =item PREFERENCES                       default: preferences
482
483 Miscellaneous information hash field.
484
485 =item FEEDBACK                          default: feedback
486
487 Customer feedback hash field.
488
489 =item PRICING                           default: price_level
490
491 Customer pricing level marker.
492
493 =item CARTS                                     default: carts
494
495 Saved carts hash field.
496
497 =item PASSWORD                          default: password
498
499 Customer password info. If C<crypt> is set, may be encrypted.
500
501 =item LAST                                      default: mod_time
502
503 Last login time
504
505 =item EXPIRATION                        default: expiration
506
507 Expiration of account.
508
509 =item OUTBOARD_KEY              default: (none)
510
511 Key information for linking to another table of address or other info.
512
513 =item GROUPS                            default: groups
514
515 Groups they should be logged into.
516
517 =item SUPER                                     default: super
518
519 Whether they are a superuser (admin).
520
521 =item ACL                                       default: acl
522
523 =item FILE_ACL                          default: file_acl
524
525 =item DB_ACL                            default: db_acl
526
527 Location of access control information.
528
529 =item CREATED_DATE_ISO          default: (none)
530
531 =item CREATED_DATE_UNIX         default: (none)
532
533 =item UPDATED_DATE_ISO          default: (none)
534
535 =item UPDATED_DATE_UNIX         default: (none)
536
537 Date fields.
538
539 =item MERGED_USER                       default: (none)
540
541 The user id of another account this was merged into. If present, and data (should
542 be a valid user id) is present in the field, the user will be logged as that username.
543
544 =back
545
546 =cut
547
548 # user name and password restrictions
549 $USERNAME_GOOD_CHARS = '[-A-Za-z0-9_@.]';
550
551 @P_FIELDS = qw ( p_nickname email fax email_copy phone_night mail_list fax_order );
552
553 %S_to_B = ( 
554 qw!
555 s_nickname      b_nickname
556 name            b_name
557 address         b_address
558 city            b_city
559 state           b_state
560 zip                     b_zip
561 country         b_country
562 phone_day       b_phone
563 !
564 );
565
566 @B_to_S{values %S_to_B} = keys %S_to_B;
567
568 sub new {
569
570         my ($class, %options) = @_;
571
572         my $loc;
573         if(     $Vend::Cfg->{UserDB} ) {
574                 if( $options{profile} ) {
575                         $loc =  $Vend::Cfg->{UserDB_repository}{$options{profile}};
576                 }
577                 else {
578                         $options{profile} = 'default';
579                         $loc =  $Vend::Cfg->{UserDB};
580                 }
581                 $loc = {} unless $loc;
582                 my ($k, $v);
583                 while ( ($k,$v) = each %$loc) {
584                         $options{$k} = $v unless defined $options{$k};
585                 }
586         }
587
588         if($options{billing}) {
589                 $options{billing} =~ s/[,\s]+$//;
590                 $options{billing} =~ s/^[,\s]+//;
591                 @B_FIELDS = split /[\s,]+/, $options{billing};
592         }
593         if($options{shipping}) {
594                 $options{shipping} =~ s/[,\s]+$//;
595                 $options{shipping} =~ s/^[,\s]+//;
596                 @S_FIELDS = split /[\s,]+/, $options{shipping};
597         }
598         if($options{preferences}) {
599                 $options{preferences} =~ s/[,\s]+$//;
600                 $options{preferences} =~ s/^[,\s]+//;
601                 @P_FIELDS = split /[\s,]+/, $options{preferences};
602         }
603         if($options{ignore}) {
604                 $options{ignore} =~ s/[,\s]+$//;
605                 $options{ignore} =~ s/^[,\s]+//;
606                 @I_FIELDS = split /[\s,]+/, $options{ignore};
607         }
608         my $self = {
609                         USERNAME        => $options{username}   ||
610                                                    $Vend::username              ||
611                                                    $CGI::values{mv_username} ||
612                                                    '',
613                         OLDPASS         => $options{oldpass}    || $CGI::values{mv_password_old} || '',
614                         PASSWORD        => $options{password}   || $CGI::values{mv_password} || '',
615                         VERIFY          => $options{verify}             || $CGI::values{mv_verify}       || '',
616                         NICKNAME        => $options{nickname}   || '',
617                         PROFILE         => $options{profile}    || '',
618                         LAST            => '',
619                         USERMINLEN      => $options{userminlen} || 2,
620                         PASSMINLEN      => $options{passminlen} || 4,
621                         VALIDCHARS      => $options{validchars} ? ('[' . $options{validchars} . ']') : $USERNAME_GOOD_CHARS,
622                         CRYPT           => defined $options{'crypt'}
623                                                         ? $options{'crypt'}
624                                                         : ! $::Variable->{MV_NO_CRYPT},
625                         CGI                     =>      ( defined $options{cgi} ? is_yes($options{cgi}) : 1),
626                         PRESENT         =>      { },
627                         DB_ID           =>      $options{database} || 'userdb',
628                         OPTIONS         =>      \%options,
629                         OUTBOARD        =>  $options{outboard}  || '',
630                         LOCATION        =>      {
631                                                 USERNAME        => $options{user_field} || 'username',
632                                                 BILLING         => $options{bill_field} || 'accounts',
633                                                 SHIPPING        => $options{addr_field} || 'address_book',
634                                                 PREFERENCES     => $options{pref_field} || 'preferences',
635                                                 FEEDBACK        => $options{feedback_field}   || 'feedback',
636                                                 PRICING         => $options{pricing_field} || 'price_level',
637                                                 ORDERS          => $options{ord_field}  || 'orders',
638                                                 CARTS           => $options{cart_field} || 'carts',
639                                                 PASSWORD        => $options{pass_field} || 'password',
640                                                 LAST            => $options{time_field} || 'mod_time',
641                                                 EXPIRATION      => $options{expire_field} || 'expiration',
642                                                 OUTBOARD_KEY=> $options{outboard_key_col},
643                                                 GROUPS          => $options{groups_field}|| 'groups',
644                                                 MERGED_USER => $options{merged_user},
645                                                 SUPER           => $options{super_field}|| 'super',
646                                                 ACL                     => $options{acl}                || 'acl',
647                                                 FILE_ACL        => $options{file_acl}   || 'file_acl',
648                                                 DB_ACL          => $options{db_acl}             || 'db_acl',
649                                                 CREATED_DATE_ISO                => $options{created_date_iso},
650                                                 CREATED_DATE_UNIX               => $options{created_date_epoch},
651                                                 UPDATED_DATE_ISO                => $options{updated_date_iso},
652                                                 UPDATED_DATE_UNIX               => $options{updated_date_epoch},
653                                                         },
654                         STATUS          =>              0,
655                         ERROR           =>              '',
656                         MESSAGE         =>              '',
657                 };
658         bless $self;
659
660         return $self if $options{no_open};
661
662         set_db($self) or die errmsg("user database %s does not exist.", $self->{DB_ID}) . "\n";
663
664         return $Vend::user_object = $self;
665 }
666
667 sub create_db {
668         my(%options) = @_;
669         my $user = new Vend::UserDB no_open => 1, %options;
670
671         my(@out);
672         push @out, $user->{LOCATION}{USERNAME};
673         push @out, $user->{LOCATION}{PASSWORD};
674         push @out, $user->{LOCATION}{LAST};
675         push @out, @S_FIELDS, @B_FIELDS, @P_FIELDS;
676         push @out, $user->{LOCATION}{ORDERS};
677         push @out, $user->{LOCATION}{SHIPPING};
678         push @out, $user->{LOCATION}{BILLING};
679         push @out, $user->{LOCATION}{PREFERENCES};
680
681         my $csv = 0;
682         my $delimiter = $options{delimiter} || "\t";
683         if($delimiter =~ /csv|comma/i) {
684                 $csv = 1;
685                 $delimiter = '","';
686         }
687         my $separator = $options{separator} || "\n";
688
689         print '"' if $csv;
690         print join $delimiter, @out;
691         print '"' if $csv;
692         print $separator;
693         if ($options{verbose}) {
694                 my $msg;
695                 $msg = "Delimiter=";
696                 if(length $delimiter == 1) {
697                         $msg .= sprintf '\0%o', ord($delimiter);
698                 }
699                 else {
700                         $msg .= $delimiter;
701                 }
702                 $msg .= " ";
703                 $msg .= "Separator=";
704                 if(length $separator == 1) {
705                         $msg .= sprintf '\0%o', ord($separator);
706                 }
707                 else {
708                         $msg .= $separator;
709                 }
710                 $msg .= "\nNicknames: ";
711                 $msg .= "SHIPPING=$S_FIELDS[0] ";
712                 $msg .= "BILLING=$B_FIELDS[0] ";
713                 $msg .= "PREFERENCES=$P_FIELDS[0] ";
714                 $msg .= "\nFields:\n";
715                 $msg .= join "\n", @out;
716                 $msg .= "\n\n";
717                 my $type;
718                 my $ext = '.txt';
719                 SWITCH: {
720                         $type = 4, $ext = '.csv', last SWITCH if $csv;
721                         $type = 6, last SWITCH if $delimiter eq "\t";
722                         $type = 5, last SWITCH if $delimiter eq "|";
723                         $type = 3, last SWITCH
724                                 if $delimiter eq "\n%%\n" && $separator eq "\n%%%\n";
725                         $type = 2, last SWITCH
726                                 if $delimiter eq "\n" && $separator eq "\n\n";
727                         $type = '?';
728                 }
729
730                 my $id = $user->{DB_ID};
731                 $msg .= "Database line in catalog.cfg should be:\n\n";
732                 $msg .= "Database $id $id.txt $type";
733                 warn "$msg\n";
734         }
735         1;
736 }
737
738 sub log_either {
739         my $self = shift;
740         my $msg = shift;
741
742         if(! $self->{OPTIONS}{logfile}) {
743                 return logError($msg);
744         }
745         $self->log($msg,@_);
746         return;
747 }
748
749 sub log {
750         my $self = shift;
751         my $time = $self->{OPTIONS}{unix_time} ?  time() :
752                                 POSIX::strftime("%Y%m%d%H%M%S", localtime());
753         my $msg = shift;
754         logData( ($self->{OPTIONS}{logfile} || $Vend::Cfg->{LogFile}),
755                                                 $time,
756                                                 $self->{USERNAME},
757                                                 $CGI::remote_host || $CGI::remote_addr,
758                                                 $msg,
759                                                 );
760         return;
761 }
762
763 sub check_acl {
764         my ($self,%options) = @_;
765
766         if(! defined $self->{PRESENT}{$self->{LOCATION}{ACL}}) {
767                 $self->{ERROR} = errmsg('No ACL field present.');
768                 return undef;
769         }
770
771         if(not $options{location}) {
772                 $self->{ERROR} = errmsg('No location to check.');
773                 return undef;
774         }
775
776         my $acl = $self->{DB}->field($self->{USERNAME}, $self->{LOCATION}{ACL});
777         $acl =~ /(\s|^)$options{location}(\s|$)/;
778 }
779
780
781 sub set_acl {
782         my ($self,%options) = @_;
783
784         if(!$self->{PRESENT}{$self->{LOCATION}{ACL}}) {
785                 $self->{ERROR} = errmsg('No ACL field present.');
786                 return undef;
787         }
788
789         if(!$options{location}) {
790                 $self->{ERROR} = errmsg('No location to set.');
791                 return undef;
792         }
793
794         my $acl = $self->{DB}->field($self->{USERNAME}, $self->{LOCATION}{ACL});
795         if($options{'delete'}) {
796                 $acl =~ s/(\s|^)$options{location}(\s|$)/$1$2/;
797         }
798         else {
799                 $acl =~ s/(\s|^)$options{location}(\s|$)/$1$2/;
800                 $acl .= " $options{location}";
801         }
802         $acl =~ s/\s+/ /g;
803         $self->{DB}->set_field( $self->{USERNAME}, $self->{LOCATION}{ACL}, $acl);
804         return $acl if $options{show};
805         return;
806 }
807
808 sub _check_acl {
809         my ($self, $loc, %options) = @_;
810         return undef unless $options{location};
811         $options{mode} = 'r' if ! defined $options{mode};
812         my $acl = $self->{DB}->field( $self->{USERNAME}, $loc);
813         my $f = $ready->reval($acl);
814         return undef unless exists $f->{$options{location}};
815         return 1 if ! $options{mode};
816         if($options{mode} =~ /^\s*expire\b/i) {
817                 my $cmp = $f->{$options{location}};
818                 return $cmp < time() ? '' : 1;
819         }
820         return 1 if $f->{$options{location}} =~ /$options{mode}/i;
821         return '';
822 }
823
824 sub _set_acl {
825         my ($self, $loc, %options) = @_;
826         return undef unless $self->{OPTIONS}{location};
827         if($options{mode} =~ /^\s*expires?\s+(.*)/i) {
828                 $options{mode} = adjust_time($1);
829         }
830         my $acl = $self->{DB}->field( $self->{USERNAME}, $loc );
831         my $f = $ready->reval($acl) || {};
832         if($options{'delete'}) {
833                 delete $f->{$options{location}};
834         }
835         else {
836                 $f->{$options{location}} = $options{mode} || 'rw';
837         }
838         my $return = $self->{DB}->set_field( $self->{USERNAME}, $loc, uneval_it($f) );
839         return $return if $options{show};
840         return;
841 }
842
843 sub set_file_acl {
844         my $self = shift;
845         return $self->_set_acl($self->{LOCATION}{FILE_ACL}, @_);
846 }
847
848 sub set_db_acl {
849         my $self = shift;
850         return $self->_set_acl($self->{LOCATION}{DB_ACL}, @_);
851 }
852
853 sub check_file_acl {
854         my $self = shift;
855         return $self->_check_acl($self->{LOCATION}{FILE_ACL}, @_);
856 }
857
858 sub check_db_acl {
859         my $self = shift;
860         return $self->_check_acl($self->{LOCATION}{DB_ACL}, @_);
861 }
862
863 sub set_db {
864         my($self, $database) = @_;
865
866         $database = $self->{DB_ID}              unless $database;
867
868         $Vend::WriteDatabase{$database} = 1;
869
870         my $db = database_exists_ref($database);
871         return undef unless defined $db;
872
873         $db = $db->ref();
874         my @fields = $db->columns();
875         my %ignore;
876
877         my @final;
878
879         for(@I_FIELDS) {
880                 $ignore{$_} = 1;
881         }
882
883         if($self->{OPTIONS}{username_email}) {
884                 $ignore{$self->{OPTIONS}{username_email_field} || 'email'} = 1;
885         }
886
887         for(values %{$self->{LOCATION}}) {
888                 $ignore{$_} = 1;
889         }
890
891         if($self->{OPTIONS}{force_lower}) {
892                 @fields = map { lc $_ } @fields;
893         }
894
895         for(@fields) {
896                 if($ignore{$_}) {
897                         $self->{PRESENT}->{$_} = 1;
898                         next;
899                 }
900                 push @final, $_;
901         }
902
903         $self->{DB_FIELDS} = \@final;
904         $self->{DB} = $db;
905 }
906
907 # Sets location map, returns old value
908 sub map_field {
909         my ($self, $location, $field) = @_;
910         if(! defined $field) {
911                 return $self->{LOCATION}->{$location};
912         }
913         else {
914                 my $old = $self->{LOCATION}->{$field};
915                 $self->{LOCATION}->{$location} = $field;
916                 return $old;
917         }
918 }
919
920 sub clear_values {
921         my($self, @fields) = @_;
922
923         @fields = @{ $self->{DB_FIELDS} } unless @fields;
924
925         my %constant;
926         my %scratch;
927         my %session_hash;
928
929         if($self->{OPTIONS}->{constant}) {
930                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{constant} ;
931                 for(@s) {
932                         my ($k, $v) = split /=/, $_;
933                         $v ||= $k;
934                         $constant{$k} = $v;
935                 }
936         }
937
938         if($self->{OPTIONS}->{scratch}) {
939                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{scratch} ;
940                 for(@s) {
941                         my ($k, $v) = split /=/, $_;
942                         $v ||= $k;
943                         $scratch{$k} = $v;
944                 }
945         }
946
947         if($self->{OPTIONS}->{session_hash}) {
948                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{session_hash} ;
949                 for(@s) {
950                         my ($k, $v) = split /=/, $_;
951                         $v ||= $k;
952                         $session_hash{$k} = $v;
953                 }
954         }
955
956         for(@fields) {
957                 if(my $s = $scratch{$_}) {
958                         if (exists $Vend::Cfg->{ScratchDefault}->{$s}) {
959                                 $::Scratch->{$s} = $Vend::Cfg->{ScratchDefault}->{$s};
960                         }
961                         else {
962                                 delete $::Scratch->{$s};
963                         }
964                 }
965                 elsif($constant{$_}) {
966                         delete $Vend::Session->{constant}{$constant{$_}};
967                 }
968                 elsif($session_hash{$_}) {
969                         delete $Vend::Session->{$session_hash{$_}};
970                 }
971                 else {
972                         if (exists $Vend::Cfg->{ValuesDefault}->{$_}) {
973                                 $::Values->{$_} = $Vend::Cfg->{ValuesDefault}->{$_};
974                         }
975                         else{
976                                 delete $::Values->{$_};
977                         }
978                         delete $CGI::values{$_};
979                 }
980         }
981
982         1;
983 }
984
985 sub get_values {
986         my($self, $valref, $scratchref) = @_;
987
988         $valref = $::Values unless ref($valref);
989         $scratchref = $::Scratch unless ref($scratchref);
990         my $constref = $Vend::Session->{constant} ||= {};
991
992         my @fields = @{ $self->{DB_FIELDS} };
993
994         if($self->{OPTIONS}{username_email}) {
995                 push @fields, $self->{OPTIONS}{username_email_field} || 'email';
996         }
997
998         my $db = $self->{DB}
999                 or die errmsg("No user database found.");
1000
1001         unless ( $db->record_exists($self->{USERNAME}) ) {
1002                 $self->{ERROR} = errmsg("username %s does not exist.", $self->{USERNAME});
1003                 return undef;
1004         }
1005
1006         my %ignore;
1007         my %scratch;
1008         my %constant;
1009         my %session_hash;
1010
1011         for(values %{$self->{LOCATION}}) {
1012                 $ignore{$_} = 1;
1013         }
1014
1015         my %outboard;
1016         if($self->{OUTBOARD}) {
1017                 %outboard = split /[\s=,]+/, $self->{OUTBOARD};
1018                 push @fields, keys %outboard;
1019         }
1020
1021         if($self->{OPTIONS}->{constant}) {
1022                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{constant} ;
1023                 for(@s) {
1024                         my ($k, $v) = split /=/, $_;
1025                         $v ||= $k;
1026                         $constant{$k} = $v;
1027                 }
1028 #::logDebug("constant ones: " . join " ", @s);
1029         }
1030
1031         if($self->{OPTIONS}->{session_hash}) {
1032                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{session_hash} ;
1033                 for(@s) {
1034                         my ($k, $v) = split /=/, $_;
1035                         $v ||= $k;
1036                         $session_hash{$k} = $v;
1037                 }
1038 #::logDebug("session_hash ones: " . join " ", @s);
1039         }
1040
1041         if($self->{OPTIONS}->{scratch}) {
1042                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{scratch} ;
1043                 for(@s) {
1044                         my ($k, $v) = split /=/, $_;
1045                         $v ||= $k;
1046                         $scratch{$k} = $v;
1047                 }
1048 #::logDebug("scratch ones: " . join " ", @s);
1049         }
1050
1051         my @needed;
1052         my $row = $db->row_hash($self->{USERNAME});
1053         my $outkey = $self->{LOCATION}->{OUTBOARD_KEY}
1054                                  ? $row->{$self->{LOCATION}->{OUTBOARD_KEY}}
1055                                  : $self->{USERNAME};
1056
1057         if(my $ef = $self->{OPTIONS}->{extra_fields}) {
1058                 my @s = grep /\w/, split /[\s,]+/, $ef;
1059                 my $field = $self->{LOCATION}{PREFERENCES};
1060                 my $loc   = $self->{OPTIONS}{extra_selector} || 'default';
1061                 my $hash = get_option_hash($row->{$field});
1062                 if($hash and $hash = $hash->{$loc} and ref($hash) eq 'HASH') {
1063                         for(@s) {
1064                                 if($scratch{$_} ) {
1065                                         $::Scratch->{$_} = $hash->{$_};
1066                                 }
1067                                 else {
1068                                         $::Values->{$_} = $hash->{$_};
1069                                 }
1070                         }
1071                 }
1072         }
1073
1074         for(@fields) {
1075                 if($ignore{$_}) {
1076                         $self->{PRESENT}->{$_} = 1;
1077                         next;
1078                 }
1079                 my $val;
1080                 if ($outboard{$_}) {
1081                         my ($t, $c, $k) = split /:+/, $outboard{$_};
1082                         $val = ::tag_data($t, ($c || $_), $outkey, { foreign => $k });
1083                 }
1084                 else {
1085                         $val = $row->{$_};
1086                 }
1087
1088                 my $k;
1089                 if($k = $scratch{$_}) {
1090                         $scratchref->{$k} = $val;
1091                         next;
1092                 }
1093                 elsif($k = $constant{$_}) {
1094                         $constref->{$k} = $val;
1095                         next;
1096                 }
1097                 elsif($k = $session_hash{$_}) {
1098                         $Vend::Session->{$k} = string_to_ref($val) || {};
1099                         next;
1100                 }
1101                 $valref->{$_} = $val;
1102
1103         }
1104
1105         my $area;
1106         foreach $area (qw!SHIPPING BILLING PREFERENCES CARTS!) {
1107                 my $f = $self->{LOCATION}->{$area};
1108                 if ($self->{PRESENT}->{$f}) {
1109                         my $s = $self->get_hash($area);
1110                         die errmsg("Bad structure in %s: %s", $f, $@) if $@;
1111                         $::Values->{$f} = join "\n", sort keys %$s;
1112                 }
1113         }
1114         
1115         1;
1116 }
1117
1118 sub set_values {
1119         my($self, $valref, $scratchref) = @_;
1120
1121         $valref = $::Values unless ref($valref);
1122         $scratchref = $::Scratch unless ref($scratchref);
1123
1124         my $user = $self->{USERNAME};
1125
1126         my @fields = @{$self->{DB_FIELDS}};
1127
1128         my $db = $self->{DB};
1129
1130         unless ( $db->record_exists($self->{USERNAME}) ) {
1131                 $self->{ERROR} = errmsg("username %s does not exist.", $self->{USERNAME});
1132                 return undef;
1133         }
1134         my %scratch;
1135         my %constant;
1136         my %session_hash;
1137     my %read_only;
1138
1139         if ($self->{OPTIONS}{read_only}) {
1140                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{read_only} ;
1141                 $read_only{$_} = 1 for @s;
1142         }
1143
1144         if($self->{OPTIONS}->{scratch}) {
1145                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{scratch} ;
1146                 for(@s) {
1147                         my ($k, $v) = split /=/, $_;
1148                         $v ||= $k;
1149                         $scratch{$k} = $v;
1150                 }
1151         }
1152
1153         if($self->{OPTIONS}->{constant}) {
1154                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{constant} ;
1155                 for(@s) {
1156                         my ($k, $v) = split /=/, $_;
1157                         $v ||= $k;
1158                         $constant{$k} = $v;
1159                 }
1160         }
1161
1162         if($self->{OPTIONS}->{session_hash}) {
1163                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{session_hash} ;
1164                 for(@s) {
1165                         my ($k, $v) = split /=/, $_;
1166                         $v ||= $k;
1167                         $session_hash{$k} = $v;
1168                 }
1169         }
1170
1171         my $val;
1172         my %outboard;
1173         if($self->{OUTBOARD}) {
1174                 %outboard = split /[\s=,]+/, $self->{OUTBOARD};
1175                 push @fields, keys %outboard;
1176         }
1177
1178         my @bfields;
1179         my @bvals;
1180
1181   eval {
1182
1183         my @extra;
1184
1185         if(my $ef = $self->{OPTIONS}->{extra_fields}) {
1186                 my $row = $db->row_hash($user);
1187                 my @s = grep /\w/, split /[\s,]+/, $ef;
1188                 my $field = $self->{LOCATION}{PREFERENCES};
1189                 my $loc   = $self->{OPTIONS}{extra_selector} || 'default';
1190                 my $hash = get_option_hash( $row->{$field} ) || {};
1191
1192                 my $subhash = $hash->{$loc} ||= {};
1193                 for(@s) {
1194                         $subhash->{$_} = $scratch{$_} ? $scratchref->{$_} : $valref->{$_};
1195                 }
1196
1197                 push @extra, $field;
1198                 push @extra, uneval_it($hash);
1199         }
1200
1201         for( @fields ) {
1202 #::logDebug("set_values saving $_ as $valref->{$_}\n");
1203                 my $val;
1204                 my $k;
1205         if ($read_only{$_}) {
1206             # Pull from get_values only; never write through set_values
1207             next;
1208         }
1209                 if ($k = $scratch{$_}) {
1210                         $val = $scratchref->{$k}
1211                                 if defined $scratchref->{$k};   
1212                 }
1213                 elsif ($constant{$_}) {
1214                         # we never store constants
1215                         next;
1216                 }
1217                 elsif ($k = $session_hash{$_}) {
1218                         $val = uneval_it($Vend::Session->{$k});
1219                 }
1220                 else {
1221                         $val = $valref->{$_}
1222                                 if defined $valref->{$_};       
1223                 }
1224
1225                 next if ! defined $val;
1226
1227                 if($outboard{$_}) {
1228                         my ($t, $c, $k) = split /:+/, $outboard{$_};
1229                         ::tag_data($t, ($c || $_), $self->{USERNAME}, { value => $val, foreign => $k });
1230                 }
1231                 elsif ($db->test_column($_)) {
1232                         push @bfields, $_;
1233                         push @bvals, $val;
1234                 }
1235                 else {
1236                         ::logDebug( errmsg(
1237                                                         "cannot set unknown userdb field %s to: %s",
1238                                                         $_,
1239                                                         $val,
1240                                                 )
1241                                         );
1242                 }
1243         }
1244
1245         my $dfield;
1246         my $dstring;
1247         if($dfield = $self->{OPTIONS}{updated_date_iso}) {
1248                 if($self->{OPTIONS}{updated_date_gmtime}) {
1249                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%SZ', gmtime());
1250                 }
1251                 elsif($self->{OPTIONS}{updated_date_showzone}) {
1252                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S %z', localtime());
1253                 }
1254                 else {
1255                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime());
1256                 }
1257         }
1258         elsif($dfield = $self->{OPTIONS}{updated_date_epoch}) {
1259                 $dstring = time;
1260         }
1261
1262         if($dfield and $dstring) {
1263                 if($db->test_column($dfield)) {
1264                         push @bfields, $dfield;
1265                         push @bvals, $dstring;
1266                 }
1267                 else {
1268                         my $msg = errmsg("updated field %s doesn't exist", $dfield);
1269                         Vend::Tags->warnings($msg);
1270                 }
1271         }
1272         
1273         while(@extra) {
1274                 push @bfields, shift @extra;
1275                 push @bvals, shift @extra;
1276         }
1277
1278 #::logDebug("bfields=" . ::uneval(\@bfields));
1279 #::logDebug("bvals=" . ::uneval(\@bvals));
1280         if(@bfields) {
1281                 $db->set_slice($user, \@bfields, \@bvals);
1282         }
1283   };
1284
1285         if($@) {
1286           my $msg = errmsg("error saving values in userdb: %s", $@);
1287           $self->{ERROR} = $msg;
1288           logError($msg);
1289           return undef;
1290         }
1291
1292 # Changes made to support Accounting Interface.
1293
1294         if(my $l = $Vend::Cfg->{Accounting}) {
1295                 my %hashvar;
1296                 my $indexvar = 0;
1297                 while ($indexvar <= (scalar @bfields)) {
1298                         $hashvar{ $bfields[$indexvar] } = $bvals[$indexvar];
1299                         $indexvar++;
1300                 };
1301                 my $obj;
1302                 my $class = $l->{Class};
1303                 eval {
1304                         $obj = $class->new;
1305                 };
1306
1307                 if($@) {
1308                         die errmsg(
1309                                 "Failed to save customer data with accounting system %s: %s",
1310                                 $class,
1311                                 $@,
1312                                 );
1313                 }
1314                 my $returnval = $obj->save_customer_data($user, \%hashvar);
1315         }
1316
1317         return 1;
1318 }
1319
1320 sub set_billing {
1321         my $self = shift;
1322         my $ref = $self->set_hash('BILLING', @B_FIELDS );
1323         return $ref;
1324 }
1325
1326 sub set_shipping {
1327         my $self = shift;
1328         my $ref = $self->set_hash('SHIPPING', @S_FIELDS );
1329         return $ref;
1330 }
1331
1332 sub set_preferences {
1333         my $self = shift;
1334         my $ref = $self->set_hash('PREFERENCES', @P_FIELDS );
1335         return $ref;
1336 }
1337
1338 sub get_shipping {
1339         my $self = shift;
1340         my $ref = $self->get_hash('SHIPPING', @S_FIELDS );
1341         return $ref;
1342 }
1343
1344 sub get_billing {
1345         my $self = shift;
1346         my $ref = $self->get_hash('BILLING', @B_FIELDS );
1347         return $ref;
1348 }
1349
1350 sub get_preferences {
1351         my $self = shift;
1352         my $ref = $self->get_hash('PREFERENCES', @P_FIELDS );
1353         return $ref;
1354 }
1355
1356 sub get_shipping_names {
1357         my $self = shift;
1358         my $ref = $self->get_hash('SHIPPING');
1359         return undef unless ref $ref;
1360         $::Values->{$self->{LOCATION}{SHIPPING}} = join "\n", sort keys %$ref;
1361         return $::Values->{$self->{LOCATION}{SHIPPING}} if $self->{OPTIONS}{show};
1362         return '';
1363 }
1364
1365 sub get_shipping_hashref {
1366         my $self = shift;
1367         my $ref = $self->get_hash('SHIPPING');
1368         return $ref if ref($ref) eq 'HASH';
1369         return undef;
1370 }
1371
1372 sub get_billing_names {
1373         my $self = shift;
1374         my $ref = $self->get_hash('BILLING');
1375         return undef unless ref $ref;
1376         $::Values->{$self->{LOCATION}{BILLING}} = join "\n", sort keys %$ref;
1377         return $::Values->{$self->{LOCATION}{BILLING}} if $self->{OPTIONS}{show};
1378         return '';
1379 }
1380
1381 sub get_billing_hashref {
1382         my $self = shift;
1383         my $ref = $self->get_hash('BILLING');
1384         return $ref if ref($ref) eq 'HASH';
1385         return undef;
1386 }
1387
1388 sub get_preferences_names {
1389         my $self = shift;
1390         my $ref = $self->get_hash('PREFERENCES');
1391         return undef unless ref $ref;
1392         $::Values->{$self->{LOCATION}{PREFERENCES}} = join "\n", sort keys %$ref;
1393         return $::Values->{$self->{LOCATION}{PREFERENCES}} if $self->{OPTIONS}{show};
1394         return '';
1395 }
1396
1397 sub get_cart_names {
1398         my $self = shift;
1399         my $ref = $self->get_hash('CARTS');
1400         return undef unless ref $ref;
1401         $::Values->{$self->{LOCATION}{CARTS}} = join "\n", sort keys %$ref;
1402         return $::Values->{$self->{LOCATION}{CARTS}} if $self->{OPTIONS}{show};
1403         return '';
1404 }
1405
1406 sub delete_billing {
1407         my $self = shift;
1408         $self->delete_nickname('BILLING', @B_FIELDS );
1409         return '';
1410 }
1411
1412 sub delete_cart {
1413         my $self = shift;
1414         $self->delete_nickname('CARTS', $self->{NICKNAME});
1415         return '';
1416 }
1417
1418 sub delete_shipping {
1419         my $self = shift;
1420         $self->delete_nickname('SHIPPING', @S_FIELDS );
1421         return '';
1422 }
1423
1424 sub delete_preferences {
1425         my $self = shift;
1426         $self->delete_nickname('PREFERENCES', @P_FIELDS );
1427         return '';
1428 }
1429
1430 sub delete_nickname {
1431         my($self, $name, @fields) = @_;
1432
1433         die errmsg("no fields?") unless @fields;
1434         die errmsg("no name?") unless $name;
1435
1436         $self->get_hash($name) unless ref $self->{$name};
1437
1438         my $nick_field = shift @fields;
1439         my $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1440
1441         delete $self->{$name}{$nick};
1442
1443         my $field_name = $self->{LOCATION}->{$name};
1444         unless($self->{PRESENT}->{$field_name}) {
1445                 $self->{ERROR} = errmsg('%s field not present to set %s', $field_name, $name);
1446                 return undef;
1447         }
1448
1449         my $s = uneval_it($self->{$name});
1450
1451         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
1452
1453         return ($s, $self->{$name});
1454 }
1455
1456 sub set_hash {
1457         my($self, $name, @fields) = @_;
1458
1459         die errmsg("no fields?") unless @fields;
1460         die errmsg("no name?") unless $name;
1461
1462         $self->get_hash($name) unless ref $self->{$name};
1463
1464         my $nick_field = shift @fields;
1465         my $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1466         $nick =~ s/^[\0\s]+//;
1467         $nick =~ s/[\0\s]+.*//;
1468         $::Values->{$nick_field} = $nick;
1469         $CGI::values{$nick_field} = $nick if $self->{CGI};
1470
1471         die errmsg("no nickname?") unless $nick;
1472
1473         $self->{$name}{$nick} = {} unless $self->{OPTIONS}{keep}
1474                                                            and    defined $self->{$name}{$nick};
1475
1476         for(@fields) {
1477                 $self->{$name}{$nick}{$_} = $::Values->{$_}
1478                         if defined $::Values->{$_};
1479         }
1480
1481         my $field_name = $self->{LOCATION}->{$name};
1482         unless($self->{PRESENT}->{$field_name}) {
1483                 $self->{ERROR} = errmsg('%s field not present to set %s', $field_name, $name);
1484                 return undef;
1485         }
1486
1487         my $s = uneval_it($self->{$name});
1488
1489         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
1490
1491         return ($s, $self->{$name});
1492 }
1493
1494 sub get_hash {
1495         my($self, $name, @fields) = @_;
1496
1497         my $field_name = $self->{LOCATION}->{$name};
1498         my ($nick, $s);
1499
1500         eval {
1501                 die errmsg("no name?")                                  unless $name;
1502                 die errmsg("%s field not present to get %s", $field_name, $name) . "\n"
1503                                                                                 unless $self->{PRESENT}->{$field_name};
1504
1505                 $s = $self->{DB}->field( $self->{USERNAME}, $field_name);
1506
1507                 if($s) {
1508                         $self->{$name} = string_to_ref($s);
1509                         die errmsg("Bad structure in %s: %s", $field_name, $@) if $@;
1510                 }
1511                 else {
1512                         $self->{$name} = {};
1513                 }
1514
1515                 die errmsg("eval failed?") . "\n"               unless ref $self->{$name};
1516         };
1517
1518         if($@) {
1519                 $self->{ERROR} = $@;
1520                 return undef;
1521         }
1522
1523         return $self->{$name} unless @fields;
1524
1525         eval {
1526                 my $nick_field = shift @fields;
1527                 $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1528                 $nick =~ s/^[\0\s]+//;
1529                 $nick =~ s/[\0\s]+.*//;
1530                 $::Values->{$nick_field} = $nick;
1531                 $CGI::values{$nick_field} = $nick if $self->{CGI};
1532                 die errmsg("no nickname?") unless $nick;
1533         };
1534
1535         if($@) {
1536                 $self->{ERROR} = $@;
1537                 return undef;
1538         }
1539
1540         $self->{$name}->{$nick} = {} unless defined $self->{$name}{$nick};
1541
1542         for(@fields) {
1543                 delete $::Values->{$_};
1544                 $::Values->{$_} = $self->{$name}{$nick}{$_}
1545                         if defined  $self->{$name}{$nick}{$_};
1546                 next unless $self->{CGI};
1547                 $CGI::values{$_} = $::Values->{$_};
1548         }
1549         ::update_user() if $self->{CGI};
1550         return $self->{$name}{$nick};
1551 }
1552
1553 =over 4
1554
1555 =item enclair_db
1556
1557 Using set_enclair() allows logging of enclair password to separate
1558 database table. Designed to allow administration personnel to look
1559 at passwords, without allowing access to web-connected systems. Or
1560 perhaps more properly, to check prior MD5-encrypted password values 
1561 for repeat passwords.
1562
1563 Designed to log to an insert-only handle on a table, with a database
1564 structure such as:
1565
1566   create table enclair (
1567     username varchar(32),
1568      password varchar(32),
1569      update_date timestamp
1570     )
1571
1572 Then a program on a secure behind-firewall no-select write-only
1573 database can access the table, logged via request and username.
1574
1575 Configured:
1576
1577         UserDB   default  enclair_db   some_table
1578
1579 You can set the following, which have the defaults shown in the
1580 setting. You can also insert %M, which is the MD5 of the password, or
1581 %D which is a datetime localtime value in the form YYYYmmddHHMMSS.
1582
1583         #UserDB   default  enclair_key_field   username
1584         #UserDB   default  enclair_field       password
1585         #UserDB   default  enclair_query_template "INSERT INTO %t (%U,%P) values (%u,%p)"
1586
1587 String substitutions:
1588
1589         %u  value of username
1590         %p  value of password
1591         %U  field of username
1592         %P  field of password
1593         %t  enclair table name
1594         %D  datetime value of form YYYYmmddHHMMSS
1595         %M  MD5 hashed value of password
1596
1597 =back
1598
1599 =cut
1600
1601 sub set_enclair {
1602         my $self = shift;
1603         if( my $tab = $self->{OPTIONS}{enclair_db} ) {
1604                 eval {
1605                         my $dbh = dbref($tab)->dbh();
1606                         my $field = $self->{OPTIONS}{enclair_field} || 'password';
1607                         my $key   = $self->{OPTIONS}{enclair_key_field} || 'username';
1608                         my $datetime = POSIX::strftime('%Y%m%d%H%M%S', localtime());
1609                         my $md5 = generate_key($self->{PASSWORD});
1610                         my $q = $self->{OPTIONS}{enclair_query_template} || "INSERT INTO %t (%U,%P) values (%u,%p)";
1611                         $q =~ s/\%M/$dbh->quote($md5)/eg;
1612                         $q =~ s/\%D/$dbh->quote($datetime)/eg;
1613                         $q =~ s/\%t/$tab/g;
1614                         $q =~ s/\%U/$key/g;
1615                         $q =~ s/\%P/$field/g;
1616                         $q =~ s/\%u/$dbh->quote($self->{USERNAME})/eg;
1617                         $q =~ s/\%p/$dbh->quote($self->{PASSWORD})/eg;
1618                         $dbh->do($q);
1619                 };
1620                 if($@) {
1621                         $self->log_either("Failed to set enclair password for $self->{USERNAME}: $@");
1622                 }
1623         }
1624 }
1625
1626
1627 sub login {
1628         my $self;
1629
1630         $self = shift
1631                 if ref $_[0];
1632
1633         my(%options) = @_;
1634         my ($user_data, $pw);
1635
1636         # Show this generic error message on login page to avoid
1637         # helping would-be intruders
1638         my $stock_error = errmsg("Invalid user name or password.");
1639         
1640         eval {
1641                 unless($self) {
1642                         $self = new Vend::UserDB %options;
1643                 }
1644
1645                 if($Vend::Cfg->{CookieLogin}) {
1646                         $self->{USERNAME} = Vend::Util::read_cookie('MV_USERNAME')
1647                                 if ! $self->{USERNAME};
1648                         $self->{PASSWORD} = Vend::Util::read_cookie('MV_PASSWORD')
1649                                 if ! $self->{PASSWORD};
1650                 }
1651
1652                 if ($self->{VALIDCHARS} !~ / /) {
1653                         # If space isn't a valid character in usernames,
1654                         # be nice and strip leading and trailing whitespace.
1655                         $self->{USERNAME} =~ s/^\s+//;
1656                         $self->{USERNAME} =~ s/\s+$//;
1657                 }
1658
1659                 if ($self->{OPTIONS}{ignore_case}) {
1660                         $self->{PASSWORD} = lc $self->{PASSWORD};
1661                         $self->{USERNAME} = lc $self->{USERNAME};
1662                 }
1663
1664                 # We specifically check for login attempts with group names to see if
1665                 # anyone is trying to exploit a former vulnerability in the demo catalog.
1666                 if ($self->{USERNAME} =~ /^:/) {
1667                         $self->log_either(errmsg("Denied attempted login with group name '%s'",
1668                                 $self->{USERNAME}));
1669                         die $stock_error, "\n";
1670                 }
1671
1672                 # Username must be long enough
1673                 if (length($self->{USERNAME}) < $self->{USERMINLEN}) {
1674                         $self->log_either(errmsg("Denied attempted login for user name '%s'; must have at least %s characters",
1675                                 $self->{USERNAME}, $self->{USERMINLEN}));
1676                         die $stock_error, "\n";
1677                 }
1678
1679                 # Username must contain only valid characters
1680                 if ($self->{USERNAME} !~ m{^$self->{VALIDCHARS}+$}) {
1681                         $self->log_either(errmsg("Denied attempted login for user name '%s' with illegal characters",
1682                                 $self->{USERNAME}));
1683                         die $stock_error, "\n";
1684                 }
1685
1686                 # Fail if password is too short
1687                 if (length($self->{PASSWORD}) < $self->{PASSMINLEN}) {
1688                         $self->log_either(errmsg("Denied attempted login with user name '%s' and password less than %s characters",
1689                                 $self->{USERNAME}, $self->{PASSMINLEN}));
1690                         die $stock_error, "\n";
1691                 }
1692
1693                 my $udb = $self->{DB};
1694                 my $foreign = $self->{OPTIONS}{indirect_login};
1695
1696                 if($foreign) {
1697                         my $uname = ($self->{PASSED_USERNAME} ||= $self->{USERNAME});
1698                         my $ufield = $self->{LOCATION}{USERNAME};
1699                         $uname = $udb->quote($uname);
1700                         my $q = "select $ufield from $self->{DB_ID} where $foreign = $uname";
1701 #::logDebug("indirect login query: $q");
1702                         my $ary = $udb->query($q)
1703                                 or do {
1704                                         my $msg = errmsg( "Database access error for query: %s", $q);
1705                                         die "$msg\n";
1706                                 };
1707                         @$ary == 1
1708                                 or do {
1709                                         $self->log_either(errmsg(
1710                                                 @$ary ? "Denied attempted login with ambiguous (indirect from %s) user name %s" : "Denied attempted login with nonexistent (indirect from %s) user name %s",
1711                                                 $foreign,
1712                                                 $uname,
1713                                                 $self->{USERNAME},
1714                                         ));
1715                                         die $stock_error, "\n";
1716                                 };
1717                         $self->{USERNAME} = $ary->[0][0];
1718                 }
1719
1720                 # If not superuser, an entry must exist in access database
1721                 unless ($Vend::superuser) {
1722                         unless ($udb->record_exists($self->{USERNAME})) {
1723                                 $self->log_either(errmsg("Denied attempted login with nonexistent user name '%s'",
1724                                         $self->{USERNAME}));
1725                                 die $stock_error, "\n";
1726                         }
1727                         unless ($user_data = $udb->row_hash($self->{USERNAME})) {
1728                                 $self->log_either(errmsg("Login denied after failed fetch of user data for user '%s'",
1729                                         $self->{USERNAME}));
1730                                 die $stock_error, "\n";
1731                         }
1732                         my $db_pass = $user_data->{ $self->{LOCATION}{PASSWORD} };
1733                         unless ($db_pass) {
1734                                 $self->log_either(errmsg("Refusing to use blank password from '%s' database for user '%s'", $self->{DB_ID}, $self->{USERNAME}));
1735                                 die $stock_error, "\n";
1736                         }
1737                         $pw = $self->{PASSWORD};
1738
1739                         if ( $self->{CRYPT} && $self->{OPTIONS}{promote} ) {
1740                                 my ($cur_method) = grep { $self->{OPTIONS}{ $_ } } keys %enc_subs;
1741                                 $cur_method ||= 'default';
1742
1743                                 my $stored_by = $enc_id{ determine_cipher($db_pass) };
1744                                 my $from_sub = $self->{OPTIONS}{from_plain} ? sub {$_[1]} : $enc_subs{$stored_by};
1745
1746                                 if (
1747                                         $cur_method ne $stored_by
1748                                         ||
1749                                         $cur_method eq 'bcrypt'
1750                                         &&
1751                                         bcost($self->{OPTIONS}) != bcost($self->{OPTIONS}, bmarshal($db_pass))
1752                                         and
1753                                         $db_pass eq $from_sub->($self, $pw, $db_pass)
1754                                 ) {
1755
1756                                         my $newpass = $enc_subs{$cur_method}->($self, $pw, Vend::Util::random_string(2));
1757                                         my $db_newpass = eval {
1758                                                 $self->{DB}->set_field(
1759                                                         $self->{USERNAME},
1760                                                         $self->{LOCATION}{PASSWORD},
1761                                                         $newpass,
1762                                                 );
1763                                         };
1764
1765                                         if ($db_newpass ne $newpass) {
1766                                                 # Usually, an error in the update will cause $db_newpass to be set to a
1767                                                 # useful error string. The usefulness is dependent on DB store itself, though.
1768                                                 my $err_msg = qq{Could not update database "%s" field "%s" with promoted password due to error:\n}
1769                                                         . "%s\n"
1770                                                         . qq{Check that field "%s" is at least %s characters wide.\n};
1771                                                 $err_msg = ::errmsg(
1772                                                         $err_msg,
1773                                                         $self->{DB_ID},
1774                                                         $self->{LOCATION}{PASSWORD},
1775                                                         $DBI::errstr,
1776                                                         $self->{LOCATION}{PASSWORD},
1777                                                         length($newpass),
1778                                                 );
1779                                                 ::logError($err_msg);
1780                                                 die $err_msg;
1781                                         } 
1782                                         $db_pass = $newpass;
1783                                 }
1784                         }
1785
1786                         if ($self->{CRYPT}) {
1787                                 $self->{PASSWORD} = $self->do_crypt($pw, $db_pass);
1788                         }
1789                         else {
1790                                 $db_pass = lc $db_pass if $self->{OPTIONS}{ignore_case};
1791                         }
1792 #::logDebug(errmsg("crypt: %s", $self->{CRYPT}));
1793 #::logDebug(errmsg("ignore_case: %s", $self->{OPTIONS}{ignore_case}));
1794 #::logDebug(errmsg("given password: %s", $self->{PASSWORD}));
1795 #::logDebug(errmsg("stored password: %s", $db_pass));
1796                         unless ($self->{PASSWORD} eq $db_pass) {
1797                                 $self->log_either(errmsg("Denied attempted login by user '%s' with incorrect password",
1798                                         $self->{USERNAME}));
1799                                 die $stock_error, "\n";
1800                         }
1801                         $self->log_either(errmsg("Successful login by user '%s'", $self->{USERNAME}));
1802                 }
1803
1804                 if($self->{PRESENT}->{ $self->{LOCATION}{EXPIRATION} } ) {
1805                         my $now = time();
1806                         my $cmp = $now;
1807                         $cmp = POSIX::strftime("%Y%m%d%H%M", localtime($now))
1808                                 unless $self->{OPTIONS}->{unix_time};
1809                         my $exp = $udb->field(
1810                                                 $self->{USERNAME},
1811                                                 $self->{LOCATION}{EXPIRATION},
1812                                                 );
1813                         die errmsg("Expiration date not set.") . "\n"
1814                                 if ! $exp and $self->{EMPTY_EXPIRE_FATAL};
1815                         if($exp and $exp < $cmp) {
1816                                 die errmsg("Expired %s.", $exp) . "\n";
1817                         }
1818                 }
1819
1820                 if($self->{PRESENT}->{ $self->{LOCATION}{MERGED_USER} } ) {
1821                         my $old = $self->{USERNAME};
1822                         my $new = $udb->field(
1823                                                 $self->{USERNAME},
1824                                                 $self->{LOCATION}{MERGED_USER},
1825                                                 );
1826                         if($new) {
1827                                 $self->{USERNAME} = $new;
1828                                 my $msg = errmsg('%s logged in as user %s, merged.', $old, $new);
1829                                 Vend::Tags->warnings($msg);
1830                                 $self->log_either($msg);
1831                         }
1832                 }
1833
1834                 if($self->{PRESENT}->{ $self->{LOCATION}{GROUPS} } ) {
1835                         $Vend::groups
1836                         = $Vend::Session->{groups}
1837                         = $udb->field(
1838                                                 $self->{USERNAME},
1839                                                 $self->{LOCATION}{GROUPS},
1840                                                 );
1841                 }
1842
1843                 username_cookies($self->{PASSED_USERNAME} || $self->{USERNAME}, $pw, $self->{OPTIONS}{secure_cookies}) 
1844                         if $Vend::Cfg->{CookieLogin};
1845
1846                 if ($self->{LOCATION}{LAST} ne 'none') {
1847                         my $now = time();
1848                         my $login_time;
1849                         unless($self->{OPTIONS}{null_time}) {
1850                                 $login_time = $self->{OPTIONS}{iso_time}
1851                                                 ? POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime($now))
1852                                                 : $now;
1853                         }
1854                         eval {
1855                                 $udb->set_field( $self->{USERNAME},
1856                                                                         $self->{LOCATION}{LAST},
1857                                                                         $login_time
1858                                                                         );
1859                         };
1860                         if ($@) {
1861                                 my $msg = errmsg("Failed to record timestamp in UserDB: %s", $@);
1862                                 logError($msg);
1863                                 die $msg, "\n";
1864                         }
1865                 }
1866                 $self->log('login') if $options{'log'};
1867                 
1868                 $self->get_values() unless $self->{OPTIONS}{no_get};
1869         };
1870
1871         scrub();
1872
1873         if($@) {
1874                 if(defined $self) {
1875                         $self->{ERROR} = $@;
1876                 }
1877                 else {
1878                         logError( "Vend::UserDB error: %s\n", $@ );
1879                 }
1880                 return undef;
1881         }
1882
1883         PRICING: {
1884                 my $pprof;
1885                 last PRICING
1886                         unless  $self->{LOCATION}{PRICING}
1887                         and             $pprof = $user_data->{ $self->{LOCATION}{PRICING} };
1888
1889                 Vend::Interpolate::tag_profile(
1890                                                                 $pprof,
1891                                                                 { tag => $self->{OPTIONS}{profile} },
1892                                                                 );
1893         }
1894
1895         $Vend::login_table = $Vend::Session->{login_table} = $self->{DB_ID};
1896         $Vend::username = $Vend::Session->{username} = $self->{USERNAME};
1897         $Vend::Session->{logged_in} = 1;
1898
1899         if (my $macros = $self->{OPTIONS}{postlogin_action}) {
1900                 eval {
1901                         Vend::Dispatch::run_macro $macros;
1902                 };
1903                 if ($@) {
1904                         logError("UserDB postlogin_action execution error: %s\n", $@);
1905                 }
1906         }
1907
1908         1;
1909 }
1910
1911 sub scrub {
1912         for(qw/ mv_password mv_verify mv_password_old /) {
1913                 delete $CGI::values{$_};
1914                 delete $::Values->{$_};
1915         }
1916 }
1917
1918 sub logout {
1919         my $self = shift or return undef;
1920         scrub();
1921
1922         my $opt = $self->{OPTIONS};
1923
1924         if( is_yes($opt->{clear}) ) {
1925                 $self->clear_values();
1926         }
1927
1928         Vend::Interpolate::tag_profile("", { restore => 1 });
1929         no strict 'refs';
1930
1931         my @dels = qw/
1932                                         groups
1933                                         admin
1934                                         superuser
1935                                         login_table
1936                                         username
1937                                         logged_in
1938                                 /;
1939
1940         for(@dels) {
1941                 delete $Vend::Session->{$_};
1942                 undef ${"Vend::$_"};
1943         }
1944
1945         delete $CGI::values{mv_username};
1946         delete $::Values->{mv_username};
1947         $self->log('logout') if $opt->{log};
1948         $self->{MESSAGE} = errmsg('Logged out.');
1949         if ($opt->{clear_cookie}) {
1950                 my @cookies = split /[\s,\0]+/, $opt->{clear_cookie};
1951                 my $exp = 10;
1952                 for(@cookies) {
1953                         Vend::Util::set_cookie($_, '', $exp);
1954                 }
1955         }
1956         if ($opt->{clear_session}) {
1957                 Vend::Session::init_session();
1958         }
1959         return 1;
1960 }
1961
1962 sub change_pass {
1963
1964         my ($self, $original_self);
1965
1966         $self = shift
1967                 if ref $_[0];
1968
1969         my(%options) = @_;
1970         
1971         if ($self->{OPTIONS}{ignore_case}) {
1972            $self->{USERNAME} = lc $self->{USERNAME};
1973            $self->{OLDPASS} = lc $self->{OLDPASS};
1974            $self->{PASSWORD} = lc $self->{PASSWORD};
1975            $self->{VERIFY} = lc $self->{VERIFY};
1976         }
1977
1978         eval {
1979                 # Create copies so that ignore_case doesn't lc the originals.
1980                 my $vend_username = $Vend::username;
1981                 my $cgi_mv_username = $CGI::values{mv_username};
1982                 if ($self->{OPTIONS}{ignore_case}) {
1983                         $vend_username = lc $vend_username;
1984                         $cgi_mv_username = lc $cgi_mv_username
1985                                 if defined $cgi_mv_username;
1986                 }
1987
1988                 # Database operations still use the mixed-case original.
1989                 my $super = $Vend::superuser || (
1990                         $Vend::admin and
1991                         $self->{DB}->field($Vend::username, $self->{LOCATION}{SUPER})
1992                 );
1993
1994                 if ($self->{USERNAME} ne $vend_username or
1995                         defined $cgi_mv_username and
1996                         $self->{USERNAME} ne $cgi_mv_username
1997                 ) {
1998                         if ($super) {
1999                                 if ($cgi_mv_username and
2000                                         $cgi_mv_username ne $self->{USERNAME}) {
2001                                         $original_self = $self;
2002                                         $options{username} = $cgi_mv_username;
2003                                         undef $self;
2004                                 }
2005                         } else {
2006                                 errmsg("Unprivileged user '%s' attempted to change password of user '%s'",
2007                                         $vend_username, $self->{USERNAME}) if $options{log};
2008                                 die errmsg("You are not allowed to change another user's password.");
2009                         }
2010                 }
2011
2012                 unless($self) {
2013                         $self = new Vend::UserDB %options;
2014                 }
2015
2016                 die errmsg("Bad object.") unless defined $self;
2017
2018                 die errmsg("'%s' not a user.", $self->{USERNAME}) . "\n"
2019                         unless $self->{DB}->record_exists($self->{USERNAME});
2020
2021                 unless ($super and $self->{USERNAME} ne $Vend::username) {
2022                         my $db_pass = $self->{DB}->field($self->{USERNAME}, $self->{LOCATION}{PASSWORD});
2023                         if ($self->{CRYPT}) {
2024                                 $self->{OLDPASS} = $self->do_crypt($self->{OLDPASS}, $db_pass);
2025                         }
2026                         die errmsg("Must have old password.") . "\n"
2027                                 if $self->{OLDPASS} ne $db_pass;
2028                 }
2029
2030                 die errmsg("Must enter at least %s characters for password.",
2031                         $self->{PASSMINLEN}) . "\n"
2032                         if length($self->{PASSWORD}) < $self->{PASSMINLEN}; 
2033                 die errmsg("Password and check value don't match.") . "\n"
2034                         unless $self->{PASSWORD} eq $self->{VERIFY};
2035
2036                 $self->{OPTIONS}{enclair_db} and $self->set_enclair();
2037
2038                 if ( $self->{CRYPT} ) {
2039                         $self->{PASSWORD} = $self->do_crypt(
2040                                 $self->{PASSWORD},
2041                                 Vend::Util::random_string(2),
2042                         );
2043                 }
2044                 
2045                 my $pass = $self->{DB}->set_field(
2046                                                 $self->{USERNAME},
2047                                                 $self->{LOCATION}{PASSWORD},
2048                                                 $self->{PASSWORD}
2049                                                 );
2050                 die errmsg("Database access error.") . "\n" unless defined $pass;
2051                 $self->log(errmsg('change password')) if $options{'log'};
2052         };
2053
2054         scrub();
2055
2056         $self = $original_self if $original_self;
2057
2058         if($@) {
2059                 if(defined $self) {
2060                         $self->{ERROR} = $@;
2061                         $self->log(errmsg('change password failed')) if $options{'log'};
2062                 }
2063                 else {
2064                         logError( "Vend::UserDB error: %s", $@ );
2065                 }
2066                 return undef;
2067         }
2068         
2069         1;
2070 }
2071
2072 sub assign_username {
2073         my $self = shift;
2074         my $file = shift || $self->{OPTIONS}{counter};
2075         my $start = $self->{OPTIONS}{username} || 'U00000';
2076         $file = './etc/username.counter' if ! $file;
2077
2078         my $o = { start => $start, sql => $self->{OPTIONS}{sql_counter} };
2079
2080         my $custno;
2081
2082         if(my $l = $Vend::Cfg->{Accounting}) {
2083
2084                 my $class = $l->{Class};
2085
2086                 my $assign = defined $l->{assign_username} ? $l->{assign_username} : 1;
2087
2088                 if($assign) {
2089 #::logDebug("Accounting class is $class");
2090                 my $obj;
2091                 eval {
2092                                 $obj = $class->new;
2093                 };
2094 #::logDebug("Accounting object is $obj");
2095
2096                 if($@) {
2097                         die errmsg(
2098                                 "Failed to assign new customer number with accounting system %s",
2099                                 $class,
2100                                 );
2101                 }
2102                 $custno = $obj->assign_customer_number();
2103                 }
2104 #::logDebug("assigned new customer number $custno");
2105         }
2106
2107         return $custno || Vend::Interpolate::tag_counter($file, $o);
2108 }
2109
2110 sub new_account {
2111
2112         my $self;
2113
2114         $self = shift
2115                 if ref $_[0];
2116
2117         my(%options) = @_;
2118         
2119         eval {
2120                 unless($self) {
2121                         $self = new Vend::UserDB %options;
2122                 }
2123
2124                 delete $Vend::Session->{auto_created_user};
2125
2126                 die errmsg("Bad object.") . "\n" unless defined $self;
2127
2128                 die errmsg("Already logged in. Log out first.") . "\n"
2129                         if $Vend::Session->{logged_in} and ! $options{no_login};
2130                 die errmsg("Sorry, reserved user name.") . "\n"
2131                         if $self->{OPTIONS}{username_mask} 
2132                                 and $self->{USERNAME} =~ m!$self->{OPTIONS}{username_mask}!;
2133                 die errmsg("Sorry, user name must be an email address.") . "\n"
2134                         if $self->{OPTIONS}{username_email} 
2135                                 and $self->{USERNAME} !~ m!^[[:alnum:]]([.]?([[:alnum:]._-]+)*)?@([[:alnum:]\-_]+\.)+[a-zA-Z]{2,4}$!;
2136                 die errmsg("Must enter at least %s characters for password.",
2137                         $self->{PASSMINLEN}) . "\n"
2138                         if length($self->{PASSWORD}) < $self->{PASSMINLEN};
2139                 die errmsg("Password and check value don't match.") . "\n"
2140                         unless $self->{PASSWORD} eq $self->{VERIFY};
2141
2142                 if ($self->{OPTIONS}{ignore_case}) {
2143                         $self->{PASSWORD} = lc $self->{PASSWORD};
2144                         $self->{USERNAME} = lc $self->{USERNAME};
2145                 }
2146
2147                 my $pw = $self->{PASSWORD};
2148                 if($self->{CRYPT}) {
2149                         eval {
2150                                 $pw = $self->do_crypt($pw, Vend::Util::random_string(2));
2151                         };
2152                 }
2153         
2154                 my $udb = $self->{DB};
2155
2156                 if($self->{OPTIONS}{assign_username}) {
2157                         $self->{PASSED_USERNAME} = $self->{USERNAME};
2158                         $self->{USERNAME} = $self->assign_username();
2159                         $self->{USERNAME} = lc $self->{USERNAME}
2160                                 if $self->{OPTIONS}{ignore_case};
2161                 }
2162                 # plain error message without user-supplied username
2163                 # to avoid XSS exploit (RT #306)
2164                 die errmsg("Username contains illegal characters.") . "\n"
2165                         if $self->{USERNAME} !~ m{^$self->{VALIDCHARS}+$};
2166                 die errmsg("Must have at least %s characters in username.",
2167                         $self->{USERMINLEN}) . "\n"
2168                         if length($self->{USERNAME}) < $self->{USERMINLEN};
2169
2170                 if($self->{OPTIONS}{captcha}) {
2171                         my $status = Vend::Tags->captcha( { function => 'check' });
2172                         die errmsg("Must input captcha code correctly.") . "\n"
2173                                 unless $status;
2174                 }
2175
2176                 # Here we put the username in a non-primary key field, checking
2177                 # for existence
2178                 my $foreign = $self->{OPTIONS}{indirect_login};
2179                 if ($foreign) {
2180                         my $uname = ($self->{PASSED_USERNAME} ||= $self->{USERNAME});
2181                         $uname = $udb->quote($uname);
2182                         my $q = "select $foreign from $self->{DB_ID} where $foreign = $uname";
2183                         my $ary = $udb->query($q)
2184                                 or do {
2185                                         my $msg = errmsg( "Database access error for query: %s", $q);
2186                                         die "$msg\n";
2187                                 };
2188                         @$ary == 0
2189                                 or do {
2190                                         my $msg = errmsg( "Username already exists (indirect).");
2191                                         die "$msg\n";
2192                                 };
2193                 }
2194
2195                 if ($udb->record_exists($self->{USERNAME})) {
2196                         die errmsg("Username already exists.") . "\n";
2197                 }
2198
2199                 if($foreign) {
2200                          $udb->set_field(
2201                                                 $self->{USERNAME},
2202                                                 $foreign,
2203                                                 $self->{PASSED_USERNAME},
2204                                                 )
2205                                 or die errmsg("Database access error.");
2206                 }
2207
2208                 $self->{OPTIONS}{enclair_db} and $self->set_enclair();
2209
2210                 my $pass = $udb->set_field(
2211                                                 $self->{USERNAME},
2212                                                 $self->{LOCATION}{PASSWORD},
2213                                                 $pw,
2214                                                 );
2215
2216                 die errmsg("Database access error.") . "\n" unless defined $pass;
2217
2218                 if($self->{OPTIONS}{username_email}) {
2219                         my $field_name = $self->{OPTIONS}{username_email_field} || 'email';
2220                         $::Values->{$field_name} ||= $self->{USERNAME};
2221                         $udb->set_field(
2222                                                 $self->{USERNAME},
2223                                                 $field_name,
2224                                                 $self->{USERNAME},
2225                                                 )
2226                                  or die errmsg("Database access error: %s", $udb->errstr) . "\n";
2227                 }
2228
2229                 my $dfield;
2230                 my $dstring;
2231                 if($dfield = $self->{OPTIONS}{created_date_iso}) {
2232                         if($self->{OPTIONS}{created_date_gmtime}) {
2233                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%SZ', gmtime());
2234                         }
2235                         elsif($self->{OPTIONS}{created_date_showzone}) {
2236                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S %z', localtime());
2237                         }
2238                         else {
2239                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime());
2240                         }
2241                 }
2242                 elsif($dfield = $self->{OPTIONS}{created_date_epoch}) {
2243                         $dstring = time;
2244                 }
2245
2246                 if($dfield and $dstring) {
2247                         $udb->set_field(
2248                                                 $self->{USERNAME},
2249                                                 $dfield,
2250                                                 $dstring,
2251                                                 )
2252                                 or do { 
2253                                         my $msg = errmsg('Failed to set new account creation date: %s', $udb->errstr);
2254                                         Vend::Tags->warnings($msg);
2255                                 };
2256                 }
2257
2258                 if($options{no_login}) {
2259                         $Vend::Session->{auto_created_user} = $self->{USERNAME};
2260                 }
2261                 else {
2262                         $self->set_values() unless $self->{OPTIONS}{no_set};
2263                         $self->{USERNAME} = $foreign if $foreign;
2264                         username_cookies($self->{USERNAME}, $pw, $self->{OPTIONS}{secure_cookies}) 
2265                                 if $Vend::Cfg->{CookieLogin};
2266
2267                         $self->log('new account') if $options{'log'};
2268                         $self->login()
2269                                 or die errmsg(
2270                                                         "Cannot log in after new account creation: %s",
2271                                                         $self->{ERROR},
2272                                                 );
2273                 }
2274         };
2275
2276         scrub();
2277
2278         if($@) {
2279                 if(defined $self) {
2280                         $self->{ERROR} = $@;
2281                 }
2282                 else {
2283                         logError( "Vend::UserDB error: %s\n", $@ );
2284                 }
2285                 return undef;
2286         }
2287         
2288         1;
2289 }
2290
2291 sub username_cookies {
2292                 my ($user, $pw, $secure) = @_;
2293                 return unless
2294                          $CGI::values{mv_cookie_password}               or
2295                          $CGI::values{mv_cookie_username}               or
2296                          Vend::Util::read_cookie('MV_PASSWORD') or
2297                          Vend::Util::read_cookie('MV_USERNAME');
2298                 $::Instance->{Cookies} = [] unless defined $::Instance->{Cookies};
2299                 my $exp = time() + $Vend::Cfg->{SaveExpire};
2300                 $secure ||= $CGI::secure;
2301                 push @{$::Instance->{Cookies}},
2302                         ['MV_USERNAME', $user, $exp];
2303                 return unless
2304                         $CGI::values{mv_cookie_password}                or
2305                         Vend::Util::read_cookie('MV_PASSWORD');
2306                 push @{$::Instance->{Cookies}},
2307                         ['MV_PASSWORD', $pw, $exp, undef, undef, $secure];
2308                 return;
2309 }
2310
2311 sub get_cart {
2312         my($self, %options) = @_;
2313
2314         my $from = $self->{NICKNAME};
2315         my $to;
2316
2317         my $opt = $self->{OPTIONS};
2318
2319         if ($opt->{target}) {
2320                 $to = ($::Carts->{$opt->{target}} ||= []);
2321         }
2322         else {
2323                 $to = $Vend::Items;
2324         }
2325
2326 #::logDebug ("to=$to nick=$opt->{target} from=$from cart=" . ::uneval_it($from));
2327
2328         my $field_name = $self->{LOCATION}->{CARTS};
2329         my $cart = [];
2330
2331         eval {
2332                 die errmsg("no from cart name?")                                unless $from;
2333                 die errmsg("%s field not present to get %s", $field_name, $from) . "\n"
2334                                                                                 unless $self->{PRESENT}->{$field_name};
2335
2336                 my $s = $self->{DB}->field( $self->{USERNAME}, $field_name);
2337
2338                 die errmsg("no saved carts.") . "\n" unless $s;
2339
2340                 my @carts = split /\0/, $from;
2341                 my $d = string_to_ref($s);
2342 #::logDebug ("saved carts=" . ::uneval_it($d));
2343
2344                 die errmsg("eval failed?")                              unless ref $d;
2345
2346                 for(@carts) {
2347                         die errmsg("source cart '%s' does not exist.", $from) . "\n" unless ref $d->{$_};
2348                         push @$cart, @{$d->{$_}};
2349                 }
2350
2351         };
2352
2353         if($@) {
2354                 $self->{ERROR} = $@;
2355                 return undef;
2356         }
2357 #::logDebug ("to=$to nick=$opt->{target} from=$from cart=" . ::uneval_it($cart));
2358
2359         if($opt->{merge}) {
2360                 $to = [] unless ref $to;
2361                 my %used;
2362                 my %alias;
2363                 my $max;
2364
2365                 for(@$to) {
2366                         my $master;
2367                         next unless $master = $_->{mv_mi};
2368                         $used{$master} = 1;
2369                         $max = $master if $master > $max;
2370                 }
2371
2372                 $max++;
2373
2374                 my $rename;
2375                 my $alias = 100;
2376                 for(@$cart) {
2377                         my $master;
2378                         next unless $master = $_->{mv_mi};
2379                         next unless $used{$master};
2380
2381                         if(! $_->{mv_si}) {
2382                                 $alias{$master} = $max++;
2383                                 $_->{mv_mi} = $alias{$master};
2384                         }
2385                         else {
2386                                 $_->{mv_mi} = $alias{$master};
2387                         }
2388                 }
2389
2390                 push(@$to,@$cart);
2391
2392         }
2393         else {
2394                 @$to = @$cart;
2395         }
2396 }
2397
2398 sub set_cart {
2399         my($self, %options) = @_;
2400
2401         my $from;
2402         my $to   = $self->{NICKNAME};
2403
2404         my $opt = $self->{OPTIONS};
2405
2406         if ($opt->{source}) {
2407                 $from = $::Carts->{$opt->{source}} || [];
2408         }
2409         else {
2410                 $from = $Vend::Items;
2411         }
2412
2413         my $field_name = $self->{LOCATION}->{CARTS};
2414         my ($cart,$s,$d);
2415
2416         eval {
2417                 die errmsg("no to cart name?") . "\n"                                   unless $to;
2418                 die errmsg('%s field not present to set %s', $field_name, $from) . "\n"
2419                                                                                 unless $self->{PRESENT}->{$field_name};
2420
2421                 $d = string_to_ref( $self->{DB}->field( $self->{USERNAME}, $field_name) );
2422
2423                 $d = {} unless $d;
2424
2425                 die errmsg("eval failed?")                              unless ref $d;
2426
2427                 if($opt->{merge}) {
2428                         $d->{$to} = [] unless ref $d->{$to};
2429                         push(@{$d->{$to}}, @{$from});
2430                 }
2431                 else {
2432                 }
2433
2434                 $d->{$to} = $from;
2435
2436                 $s = uneval $d;
2437
2438         };
2439
2440         if($@) {
2441                 $self->{ERROR} = $@;
2442                 return undef;
2443         }
2444
2445         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
2446
2447 }
2448
2449 sub userdb {
2450         my $function = shift;
2451         my $opt = shift;
2452
2453         my %options;
2454
2455         if(ref $opt) {
2456                 %options = %$opt;
2457         }
2458         else {
2459                 %options = ($opt, @_);
2460         }
2461
2462         my $status = 1;
2463         my $user;
2464
2465         my $module = $Vend::Cfg->{UserControl} ? 'Vend::UserControl' : 'Vend::UserDB';
2466
2467         if($function eq 'login') {
2468                 $Vend::Session->{logged_in} = 0;
2469                 delete $Vend::Session->{username};
2470                 delete $Vend::Session->{groups};
2471                 undef $Vend::username;
2472                 undef $Vend::groups;
2473                 undef $Vend::admin;
2474                 $user = $module->new(%options);
2475                 unless (defined $user) {
2476                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2477                         return undef;
2478                 }
2479                 if ($status = $user->login(%options) ) {
2480                         if( $Vend::ReadOnlyCfg->{AdminUserDB}{$user->{PROFILE}} ) {
2481                                 $Vend::admin = 1;
2482                         }
2483                         ::update_user();
2484                 }
2485         }
2486         elsif($function eq 'new_account') {
2487                 $user = $module->new(%options);
2488                 unless (defined $user) {
2489                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2490                         return undef;
2491                 }
2492                 $status = $user->new_account(%options);
2493                 if($status and ! $options{no_login}) {
2494                         $Vend::Session->{logged_in} = 1;
2495                         $Vend::Session->{username} = $user->{USERNAME};
2496                 }
2497         }
2498         elsif($function eq 'logout') {
2499                 $user = $module->new(%options)
2500                         or do {
2501                                 $Vend::Session->{failure} = errmsg("Unable to create user object.");
2502                                 return undef;
2503                         };
2504                 $user->logout();
2505         }
2506         elsif (! $Vend::Session->{logged_in}) {
2507                 $Vend::Session->{failure} = errmsg("Not logged in.");
2508                 return undef;
2509         }
2510         elsif($function eq 'save') {
2511                 $user = $module->new(%options);
2512                 unless (defined $user) {
2513                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2514                         return undef;
2515                 }
2516                 $status = $user->set_values();
2517         }
2518         elsif($function eq 'load') {
2519                 $user = $module->new(%options);
2520                 unless (defined $user) {
2521                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2522                         return undef;
2523                 }
2524                 $status = $user->get_values();
2525         }
2526         else {
2527                 $user = $module->new(%options);
2528                 unless (defined $user) {
2529                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2530                         return undef;
2531                 }
2532                 eval {
2533                         $status = $user->$function(%options);
2534                 };
2535                 $user->{ERROR} = $@ if $@;
2536         }
2537         
2538         if(defined $status) {
2539                 delete $Vend::Session->{failure};
2540                 $Vend::Session->{success} = $user->{MESSAGE};
2541                 if($options{show_message}) {
2542                         $status = $user->{MESSAGE};
2543                 }
2544         }
2545         else {
2546                 $Vend::Session->{failure} = $user->{ERROR};
2547                 if($options{show_message}) {
2548                         $status = $user->{ERROR};
2549                 }
2550         }
2551         return $status unless $options{hide};
2552         return;
2553 }
2554
2555 sub do_crypt {
2556         my ($self, $password, $salt) = @_;
2557         my $sub = $self->{ENCSUB};
2558         unless ($sub) {
2559                 for (grep { $self->{OPTIONS}{$_} } keys %enc_subs) {
2560                         $sub = $enc_subs{$_};
2561                         last;
2562                 }
2563                 $self->{ENCSUB} = $sub ||= $enc_subs{default};
2564         }
2565         return $sub->($self, $password, $salt);
2566 }
2567
2568 1;