Revert "Correct logic of DisplayErrors"
[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     $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         my $same;
989         if($valref and $valref eq $scratchref) {
990                 $same = 1;
991         }
992
993         if(ref($valref) eq 'HASH') {
994                 ## do nothing
995         }
996         elsif($valref and ! ref($valref) ) {
997                 my @things = split /:+/, $valref;
998                 $valref = $Vend::Session;
999                 for(@things) {
1000                         my $clear = s/\*+$//;
1001                         if($clear) {
1002                                 $valref = $valref->{$_} = {};
1003                         }
1004                         else {
1005                                 $valref = $valref->{$_} ||= {};
1006                         }
1007                 }
1008         }
1009         else {
1010                 $valref = $::Values;
1011         }
1012
1013         if($same) {
1014                 $scratchref = $valref;
1015         }
1016         elsif(ref($scratchref) eq 'HASH') {
1017                 ## do nothing
1018         }
1019         elsif($scratchref and ! ref($scratchref) ) {
1020                 my @things = split /:+/, $scratchref;
1021                 $scratchref = $Vend::Session;
1022                 for(@things) {
1023                         my $clear = s/\*+$//;
1024                         if($clear) {
1025                                 $scratchref = $scratchref->{$_} = {};
1026                         }
1027                         else {
1028                                 $scratchref = $scratchref->{$_} ||= {};
1029                         }
1030                 }
1031         }
1032         else {
1033                 $scratchref = $::Scratch;
1034         }
1035         
1036         my $constref = $Vend::Session->{constant} ||= {};
1037
1038         my @fields = @{ $self->{DB_FIELDS} };
1039
1040         if($self->{OPTIONS}{username_email}) {
1041                 push @fields, $self->{OPTIONS}{username_email_field} || 'email';
1042         }
1043
1044         my $db = $self->{DB}
1045                 or die errmsg("No user database found.");
1046
1047         unless ( $db->record_exists($self->{USERNAME}) ) {
1048                 $self->{ERROR} = errmsg("username %s does not exist.", $self->{USERNAME});
1049                 return undef;
1050         }
1051
1052         my %ignore;
1053         my %scratch;
1054         my %constant;
1055         my %session_hash;
1056
1057         for(values %{$self->{LOCATION}}) {
1058                 $ignore{$_} = 1;
1059         }
1060
1061         my %outboard;
1062         if($self->{OUTBOARD}) {
1063                 %outboard = split /[\s=,]+/, $self->{OUTBOARD};
1064                 push @fields, keys %outboard;
1065         }
1066
1067         if($self->{OPTIONS}->{constant}) {
1068                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{constant} ;
1069                 for(@s) {
1070                         my ($k, $v) = split /=/, $_;
1071                         $v ||= $k;
1072                         $constant{$k} = $v;
1073                 }
1074 #::logDebug("constant ones: " . join " ", @s);
1075         }
1076
1077         if($self->{OPTIONS}->{session_hash}) {
1078                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{session_hash} ;
1079                 for(@s) {
1080                         my ($k, $v) = split /=/, $_;
1081                         $v ||= $k;
1082                         $session_hash{$k} = $v;
1083                 }
1084 #::logDebug("session_hash ones: " . join " ", @s);
1085         }
1086
1087         if($self->{OPTIONS}->{scratch}) {
1088                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{scratch} ;
1089                 for(@s) {
1090                         my ($k, $v) = split /=/, $_;
1091                         $v ||= $k;
1092                         $scratch{$k} = $v;
1093                 }
1094                 #
1095                 ## $self->{ADMIN} comes when promote_admin option is set to a field,
1096                 ## and that field is set in both scratch and the database.
1097                 ## For instance:
1098                 #   
1099                 #   UserDb  default  scratch        "dealer promote_admin"
1100                 #   UserDb  default  promote_admin  promote_admin
1101                 #
1102                 #  If the "promote_admin" field is present in the database and
1103                 #  set to a true value, user will be made $Vend::admin. Cannot be
1104                 #  superuser.
1105                 #
1106                 #  This allows use of potential AllowGlobalAdmin and NoStrictAdmin
1107                 #  features.
1108                 #
1109                 my $pafield;
1110                 if($pafield = $self->{OPTIONS}{promote_admin} and $scratch{$pafield}) {
1111                         $self->{ADMIN} = 1;
1112                 }
1113 #::logDebug("scratch ones: " . join " ", @s);
1114         }
1115
1116         my @needed;
1117         my $row = $db->row_hash($self->{USERNAME});
1118         my $outkey = $self->{LOCATION}->{OUTBOARD_KEY}
1119                                  ? $row->{$self->{LOCATION}->{OUTBOARD_KEY}}
1120                                  : $self->{USERNAME};
1121
1122         if(my $ef = $self->{OPTIONS}->{extra_fields}) {
1123                 my @s = grep /\w/, split /[\s,]+/, $ef;
1124                 my $field = $self->{LOCATION}{PREFERENCES};
1125                 my $loc   = $self->{OPTIONS}{extra_selector} || 'default';
1126                 my $hash = get_option_hash($row->{$field});
1127                 if($hash and $hash = $hash->{$loc} and ref($hash) eq 'HASH') {
1128                         for(@s) {
1129                                 if($scratch{$_} ) {
1130                                         $::Scratch->{$_} = $hash->{$_};
1131                                 }
1132                                 else {
1133                                         $::Values->{$_} = $hash->{$_};
1134                                 }
1135                         }
1136                 }
1137         }
1138
1139         for(@fields) {
1140                 if($ignore{$_}) {
1141                         $self->{PRESENT}->{$_} = 1;
1142                         next;
1143                 }
1144                 my $val;
1145                 if ($outboard{$_}) {
1146                         my ($t, $c, $k) = split /:+/, $outboard{$_};
1147                         $val = ::tag_data($t, ($c || $_), $outkey, { foreign => $k });
1148                 }
1149                 else {
1150                         $val = $row->{$_};
1151                 }
1152
1153                 my $k;
1154                 if($k = $scratch{$_}) {
1155                         $scratchref->{$k} = $val;
1156                         next;
1157                 }
1158                 elsif($k = $constant{$_}) {
1159                         $constref->{$k} = $val;
1160                         next;
1161                 }
1162                 elsif($k = $session_hash{$_}) {
1163                         $Vend::Session->{$k} = string_to_ref($val) || {};
1164                         next;
1165                 }
1166                 $valref->{$_} = $val;
1167
1168         }
1169
1170         my $area;
1171         foreach $area (qw!SHIPPING BILLING PREFERENCES CARTS!) {
1172                 my $f = $self->{LOCATION}->{$area};
1173                 if ($self->{PRESENT}->{$f}) {
1174                         my $s = $self->get_hash($area);
1175                         die errmsg("Bad structure in %s: %s", $f, $@) if $@;
1176                         $::Values->{$f} = join "\n", sort keys %$s;
1177                 }
1178         }
1179         
1180         1;
1181 }
1182
1183 sub set_values {
1184         my($self, $valref, $scratchref) = @_;
1185
1186         $valref = $::Values unless ref($valref);
1187         $scratchref = $::Scratch unless ref($scratchref);
1188
1189         my $user = $self->{USERNAME};
1190
1191         my @fields = @{$self->{DB_FIELDS}};
1192
1193         my $db = $self->{DB};
1194
1195         unless ( $db->record_exists($self->{USERNAME}) ) {
1196                 $self->{ERROR} = errmsg("username %s does not exist.", $self->{USERNAME});
1197                 return undef;
1198         }
1199         my %scratch;
1200         my %constant;
1201         my %session_hash;
1202     my %read_only;
1203
1204         if ($self->{OPTIONS}{read_only}) {
1205                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{read_only} ;
1206                 $read_only{$_} = 1 for @s;
1207         }
1208
1209         if($self->{OPTIONS}->{scratch}) {
1210                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{scratch} ;
1211                 for(@s) {
1212                         my ($k, $v) = split /=/, $_;
1213                         $v ||= $k;
1214                         $scratch{$k} = $v;
1215                 }
1216         }
1217
1218         if($self->{OPTIONS}->{constant}) {
1219                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{constant} ;
1220                 for(@s) {
1221                         my ($k, $v) = split /=/, $_;
1222                         $v ||= $k;
1223                         $constant{$k} = $v;
1224                 }
1225         }
1226
1227         if($self->{OPTIONS}->{session_hash}) {
1228                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{session_hash} ;
1229                 for(@s) {
1230                         my ($k, $v) = split /=/, $_;
1231                         $v ||= $k;
1232                         $session_hash{$k} = $v;
1233                 }
1234         }
1235
1236         my $val;
1237         my %outboard;
1238         if($self->{OUTBOARD}) {
1239                 %outboard = split /[\s=,]+/, $self->{OUTBOARD};
1240                 push @fields, keys %outboard;
1241         }
1242
1243         my @bfields;
1244         my @bvals;
1245
1246   eval {
1247
1248         my @extra;
1249
1250         if(my $ef = $self->{OPTIONS}->{extra_fields}) {
1251                 my $row = $db->row_hash($user);
1252                 my @s = grep /\w/, split /[\s,]+/, $ef;
1253                 my $field = $self->{LOCATION}{PREFERENCES};
1254                 my $loc   = $self->{OPTIONS}{extra_selector} || 'default';
1255                 my $hash = get_option_hash( $row->{$field} ) || {};
1256
1257                 my $subhash = $hash->{$loc} ||= {};
1258                 for(@s) {
1259                         $subhash->{$_} = $scratch{$_} ? $scratchref->{$_} : $valref->{$_};
1260                 }
1261
1262                 push @extra, $field;
1263                 push @extra, uneval_it($hash);
1264         }
1265
1266         for( @fields ) {
1267 #::logDebug("set_values saving $_ as $valref->{$_}\n");
1268                 my $val;
1269                 my $k;
1270         if ($read_only{$_}) {
1271             # Pull from get_values only; never write through set_values
1272             next;
1273         }
1274                 if ($k = $scratch{$_}) {
1275                         $val = $scratchref->{$k}
1276                                 if defined $scratchref->{$k};   
1277                 }
1278                 elsif ($constant{$_}) {
1279                         # we never store constants
1280                         next;
1281                 }
1282                 elsif ($k = $session_hash{$_}) {
1283                         $val = uneval_it($Vend::Session->{$k});
1284                 }
1285                 else {
1286                         $val = $valref->{$_}
1287                                 if defined $valref->{$_};       
1288                 }
1289
1290                 next if ! defined $val;
1291
1292                 if($outboard{$_}) {
1293                         my ($t, $c, $k) = split /:+/, $outboard{$_};
1294                         ::tag_data($t, ($c || $_), $self->{USERNAME}, { value => $val, foreign => $k });
1295                 }
1296                 elsif ($db->test_column($_)) {
1297                         push @bfields, $_;
1298                         push @bvals, $val;
1299                 }
1300                 else {
1301                         ::logDebug( errmsg(
1302                                                         "cannot set unknown userdb field %s to: %s",
1303                                                         $_,
1304                                                         $val,
1305                                                 )
1306                                         );
1307                 }
1308         }
1309
1310         my $dfield;
1311         my $dstring;
1312         if($dfield = $self->{OPTIONS}{updated_date_iso}) {
1313                 if($self->{OPTIONS}{updated_date_gmtime}) {
1314                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%SZ', gmtime());
1315                 }
1316                 elsif($self->{OPTIONS}{updated_date_showzone}) {
1317                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S %z', localtime());
1318                 }
1319                 else {
1320                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime());
1321                 }
1322         }
1323         elsif($dfield = $self->{OPTIONS}{updated_date_epoch}) {
1324                 $dstring = time;
1325         }
1326
1327         if($dfield and $dstring) {
1328                 if($db->test_column($dfield)) {
1329                         push @bfields, $dfield;
1330                         push @bvals, $dstring;
1331                 }
1332                 else {
1333                         my $msg = errmsg("updated field %s doesn't exist", $dfield);
1334                         Vend::Tags->warnings($msg);
1335                 }
1336         }
1337         
1338         while(@extra) {
1339                 push @bfields, shift @extra;
1340                 push @bvals, shift @extra;
1341         }
1342
1343 #::logDebug("bfields=" . ::uneval(\@bfields));
1344 #::logDebug("bvals=" . ::uneval(\@bvals));
1345         if(@bfields) {
1346                 $db->set_slice($user, \@bfields, \@bvals);
1347         }
1348   };
1349
1350         if($@) {
1351           my $msg = errmsg("error saving values in userdb: %s", $@);
1352           $self->{ERROR} = $msg;
1353           logError($msg);
1354           return undef;
1355         }
1356
1357 # Changes made to support Accounting Interface.
1358
1359         if(my $l = $Vend::Cfg->{Accounting}) {
1360                 my %hashvar;
1361                 my $indexvar = 0;
1362                 while ($indexvar <= (scalar @bfields)) {
1363                         $hashvar{ $bfields[$indexvar] } = $bvals[$indexvar];
1364                         $indexvar++;
1365                 };
1366                 my $obj;
1367                 my $class = $l->{Class};
1368                 eval {
1369                         $obj = $class->new;
1370                 };
1371
1372                 if($@) {
1373                         die errmsg(
1374                                 "Failed to save customer data with accounting system %s: %s",
1375                                 $class,
1376                                 $@,
1377                                 );
1378                 }
1379                 my $returnval = $obj->save_customer_data($user, \%hashvar);
1380         }
1381
1382         return 1;
1383 }
1384
1385 sub set_billing {
1386         my $self = shift;
1387         my $ref = $self->set_hash('BILLING', @B_FIELDS );
1388         return $ref;
1389 }
1390
1391 sub set_shipping {
1392         my $self = shift;
1393         my $ref = $self->set_hash('SHIPPING', @S_FIELDS );
1394         return $ref;
1395 }
1396
1397 sub set_preferences {
1398         my $self = shift;
1399         my $ref = $self->set_hash('PREFERENCES', @P_FIELDS );
1400         return $ref;
1401 }
1402
1403 sub get_shipping {
1404         my $self = shift;
1405         my $ref = $self->get_hash('SHIPPING', @S_FIELDS );
1406         return $ref;
1407 }
1408
1409 sub get_billing {
1410         my $self = shift;
1411         my $ref = $self->get_hash('BILLING', @B_FIELDS );
1412         return $ref;
1413 }
1414
1415 sub get_preferences {
1416         my $self = shift;
1417         my $ref = $self->get_hash('PREFERENCES', @P_FIELDS );
1418         return $ref;
1419 }
1420
1421 sub get_shipping_names {
1422         my $self = shift;
1423         my $ref = $self->get_hash('SHIPPING');
1424         return undef unless ref $ref;
1425         $::Values->{$self->{LOCATION}{SHIPPING}} = join "\n", sort keys %$ref;
1426         return $::Values->{$self->{LOCATION}{SHIPPING}} if $self->{OPTIONS}{show};
1427         return '';
1428 }
1429
1430 sub get_shipping_hashref {
1431         my $self = shift;
1432         my $ref = $self->get_hash('SHIPPING');
1433         return $ref if ref($ref) eq 'HASH';
1434         return undef;
1435 }
1436
1437 sub get_billing_names {
1438         my $self = shift;
1439         my $ref = $self->get_hash('BILLING');
1440         return undef unless ref $ref;
1441         $::Values->{$self->{LOCATION}{BILLING}} = join "\n", sort keys %$ref;
1442         return $::Values->{$self->{LOCATION}{BILLING}} if $self->{OPTIONS}{show};
1443         return '';
1444 }
1445
1446 sub get_billing_hashref {
1447         my $self = shift;
1448         my $ref = $self->get_hash('BILLING');
1449         return $ref if ref($ref) eq 'HASH';
1450         return undef;
1451 }
1452
1453 sub get_preferences_names {
1454         my $self = shift;
1455         my $ref = $self->get_hash('PREFERENCES');
1456         return undef unless ref $ref;
1457         $::Values->{$self->{LOCATION}{PREFERENCES}} = join "\n", sort keys %$ref;
1458         return $::Values->{$self->{LOCATION}{PREFERENCES}} if $self->{OPTIONS}{show};
1459         return '';
1460 }
1461
1462 sub get_cart_names {
1463         my $self = shift;
1464         my $ref = $self->get_hash('CARTS');
1465         return undef unless ref $ref;
1466         $::Values->{$self->{LOCATION}{CARTS}} = join "\n", sort keys %$ref;
1467         return $::Values->{$self->{LOCATION}{CARTS}} if $self->{OPTIONS}{show};
1468         return '';
1469 }
1470
1471 sub delete_billing {
1472         my $self = shift;
1473         $self->delete_nickname('BILLING', @B_FIELDS );
1474         return '';
1475 }
1476
1477 sub delete_cart {
1478         my $self = shift;
1479         $self->delete_nickname('CARTS', $self->{NICKNAME});
1480         return '';
1481 }
1482
1483 sub delete_shipping {
1484         my $self = shift;
1485         $self->delete_nickname('SHIPPING', @S_FIELDS );
1486         return '';
1487 }
1488
1489 sub delete_preferences {
1490         my $self = shift;
1491         $self->delete_nickname('PREFERENCES', @P_FIELDS );
1492         return '';
1493 }
1494
1495 sub delete_nickname {
1496         my($self, $name, @fields) = @_;
1497
1498         die errmsg("no fields?") unless @fields;
1499         die errmsg("no name?") unless $name;
1500
1501         $self->get_hash($name) unless ref $self->{$name};
1502
1503         my $nick_field = shift @fields;
1504         my $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1505
1506         delete $self->{$name}{$nick};
1507
1508         my $field_name = $self->{LOCATION}->{$name};
1509         unless($self->{PRESENT}->{$field_name}) {
1510                 $self->{ERROR} = errmsg('%s field not present to set %s', $field_name, $name);
1511                 return undef;
1512         }
1513
1514         my $s = uneval_it($self->{$name});
1515
1516         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
1517
1518         return ($s, $self->{$name});
1519 }
1520
1521 sub set_hash {
1522         my($self, $name, @fields) = @_;
1523
1524         die errmsg("no fields?") unless @fields;
1525         die errmsg("no name?") unless $name;
1526
1527         $self->get_hash($name) unless ref $self->{$name};
1528
1529         my $nick_field = shift @fields;
1530         my $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1531         $nick =~ s/^[\0\s]+//;
1532         $nick =~ s/[\0\s]+.*//;
1533         $::Values->{$nick_field} = $nick;
1534         $CGI::values{$nick_field} = $nick if $self->{CGI};
1535
1536         die errmsg("no nickname?") unless $nick;
1537
1538         $self->{$name}{$nick} = {} unless $self->{OPTIONS}{keep}
1539                                                            and    defined $self->{$name}{$nick};
1540
1541         for(@fields) {
1542                 $self->{$name}{$nick}{$_} = $::Values->{$_}
1543                         if defined $::Values->{$_};
1544         }
1545
1546         my $field_name = $self->{LOCATION}->{$name};
1547         unless($self->{PRESENT}->{$field_name}) {
1548                 $self->{ERROR} = errmsg('%s field not present to set %s', $field_name, $name);
1549                 return undef;
1550         }
1551
1552         my $s = uneval_it($self->{$name});
1553
1554         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
1555
1556         return ($s, $self->{$name});
1557 }
1558
1559 sub get_hash {
1560         my($self, $name, @fields) = @_;
1561
1562         my $field_name = $self->{LOCATION}->{$name};
1563         my ($nick, $s);
1564
1565         eval {
1566                 die errmsg("no name?")                                  unless $name;
1567                 die errmsg("%s field not present to get %s", $field_name, $name) . "\n"
1568                                                                                 unless $self->{PRESENT}->{$field_name};
1569
1570                 $s = $self->{DB}->field( $self->{USERNAME}, $field_name);
1571
1572                 if($s) {
1573                         $self->{$name} = string_to_ref($s);
1574                         die errmsg("Bad structure in %s: %s", $field_name, $@) if $@;
1575                 }
1576                 else {
1577                         $self->{$name} = {};
1578                 }
1579
1580                 die errmsg("eval failed?") . "\n"               unless ref $self->{$name};
1581         };
1582
1583         if($@) {
1584                 $self->{ERROR} = $@;
1585                 return undef;
1586         }
1587
1588         return $self->{$name} unless @fields;
1589
1590         eval {
1591                 my $nick_field = shift @fields;
1592                 $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1593                 $nick =~ s/^[\0\s]+//;
1594                 $nick =~ s/[\0\s]+.*//;
1595                 $::Values->{$nick_field} = $nick;
1596                 $CGI::values{$nick_field} = $nick if $self->{CGI};
1597                 die errmsg("no nickname?") unless $nick;
1598         };
1599
1600         if($@) {
1601                 $self->{ERROR} = $@;
1602                 return undef;
1603         }
1604
1605         $self->{$name}->{$nick} = {} unless defined $self->{$name}{$nick};
1606
1607         for(@fields) {
1608                 delete $::Values->{$_};
1609                 $::Values->{$_} = $self->{$name}{$nick}{$_}
1610                         if defined  $self->{$name}{$nick}{$_};
1611                 next unless $self->{CGI};
1612                 $CGI::values{$_} = $::Values->{$_};
1613         }
1614         ::update_user() if $self->{CGI};
1615         return $self->{$name}{$nick};
1616 }
1617
1618 =over 4
1619
1620 =item enclair_db
1621
1622 Using set_enclair() allows logging of enclair password to separate
1623 database table. Designed to allow administration personnel to look
1624 at passwords, without allowing access to web-connected systems. Or
1625 perhaps more properly, to check prior MD5-encrypted password values 
1626 for repeat passwords.
1627
1628 Designed to log to an insert-only handle on a table, with a database
1629 structure such as:
1630
1631   create table enclair (
1632     username varchar(32),
1633      password varchar(32),
1634      update_date timestamp
1635     )
1636
1637 Then a program on a secure behind-firewall no-select write-only
1638 database can access the table, logged via request and username.
1639
1640 Configured:
1641
1642         UserDB   default  enclair_db   some_table
1643
1644 You can set the following, which have the defaults shown in the
1645 setting. You can also insert %M, which is the MD5 of the password, or
1646 %D which is a datetime localtime value in the form YYYYmmddHHMMSS.
1647
1648         #UserDB   default  enclair_key_field   username
1649         #UserDB   default  enclair_field       password
1650         #UserDB   default  enclair_query_template "INSERT INTO %t (%U,%P) values (%u,%p)"
1651
1652 String substitutions:
1653
1654         %u  value of username
1655         %p  value of password
1656         %U  field of username
1657         %P  field of password
1658         %t  enclair table name
1659         %D  datetime value of form YYYYmmddHHMMSS
1660         %M  MD5 hashed value of password
1661
1662 =back
1663
1664 =cut
1665
1666 sub set_enclair {
1667         my $self = shift;
1668         if( my $tab = $self->{OPTIONS}{enclair_db} ) {
1669                 eval {
1670                         my $dbh = dbref($tab)->dbh();
1671                         my $field = $self->{OPTIONS}{enclair_field} || 'password';
1672                         my $key   = $self->{OPTIONS}{enclair_key_field} || 'username';
1673                         my $datetime = POSIX::strftime('%Y%m%d%H%M%S', localtime());
1674                         my $md5 = generate_key($self->{PASSWORD});
1675                         my $q = $self->{OPTIONS}{enclair_query_template} || "INSERT INTO %t (%U,%P) values (%u,%p)";
1676                         $q =~ s/\%M/$dbh->quote($md5)/eg;
1677                         $q =~ s/\%D/$dbh->quote($datetime)/eg;
1678                         $q =~ s/\%t/$tab/g;
1679                         $q =~ s/\%U/$key/g;
1680                         $q =~ s/\%P/$field/g;
1681                         $q =~ s/\%u/$dbh->quote($self->{USERNAME})/eg;
1682                         $q =~ s/\%p/$dbh->quote($self->{PASSWORD})/eg;
1683                         $dbh->do($q);
1684                 };
1685                 if($@) {
1686                         $self->log_either("Failed to set enclair password for $self->{USERNAME}: $@");
1687                 }
1688         }
1689 }
1690
1691
1692 sub login {
1693         my $self;
1694
1695         $self = shift
1696                 if ref $_[0];
1697
1698         my(%options) = @_;
1699         my ($user_data, $pw);
1700
1701         # Show this generic error message on login page to avoid
1702         # helping would-be intruders
1703         my $stock_error = errmsg("Invalid user name or password.");
1704         
1705         eval {
1706                 unless($self) {
1707                         $self = new Vend::UserDB %options;
1708                 }
1709
1710                 if($Vend::Cfg->{CookieLogin}) {
1711                         $self->{USERNAME} = Vend::Util::read_cookie('MV_USERNAME')
1712                                 if ! $self->{USERNAME};
1713                         $self->{PASSWORD} = Vend::Util::read_cookie('MV_PASSWORD')
1714                                 if ! $self->{PASSWORD};
1715                 }
1716
1717                 if ($self->{VALIDCHARS} !~ / /) {
1718                         # If space isn't a valid character in usernames,
1719                         # be nice and strip leading and trailing whitespace.
1720                         $self->{USERNAME} =~ s/^\s+//;
1721                         $self->{USERNAME} =~ s/\s+$//;
1722                 }
1723
1724                 if ($self->{OPTIONS}{ignore_case}) {
1725                         $self->{PASSWORD} = lc $self->{PASSWORD};
1726                         $self->{USERNAME} = lc $self->{USERNAME};
1727                 }
1728
1729                 # We specifically check for login attempts with group names to see if
1730                 # anyone is trying to exploit a former vulnerability in the demo catalog.
1731                 if ($self->{USERNAME} =~ /^:/) {
1732                         $self->log_either(errmsg("Denied attempted login with group name '%s'",
1733                                 $self->{USERNAME}));
1734                         die $stock_error, "\n";
1735                 }
1736
1737                 # Username must be long enough
1738                 if (length($self->{USERNAME}) < $self->{USERMINLEN}) {
1739                         $self->log_either(errmsg("Denied attempted login for user name '%s'; must have at least %s characters",
1740                                 $self->{USERNAME}, $self->{USERMINLEN}));
1741                         die $stock_error, "\n";
1742                 }
1743
1744                 # Username must contain only valid characters
1745                 if ($self->{USERNAME} !~ m{^$self->{VALIDCHARS}+$}) {
1746                         $self->log_either(errmsg("Denied attempted login for user name '%s' with illegal characters",
1747                                 $self->{USERNAME}));
1748                         die $stock_error, "\n";
1749                 }
1750
1751                 # Fail if password is too short
1752                 if (length($self->{PASSWORD}) < $self->{PASSMINLEN}) {
1753                         $self->log_either(errmsg("Denied attempted login with user name '%s' and password less than %s characters",
1754                                 $self->{USERNAME}, $self->{PASSMINLEN}));
1755                         die $stock_error, "\n";
1756                 }
1757
1758                 my $udb = $self->{DB};
1759                 my $foreign = $self->{OPTIONS}{indirect_login};
1760
1761                 if($foreign) {
1762                         my $uname = ($self->{PASSED_USERNAME} ||= $self->{USERNAME});
1763                         my $ufield = $self->{LOCATION}{USERNAME};
1764                         my $quname = $udb->quote($uname);
1765                         my $q = "select $ufield from $self->{DB_ID} where $foreign = $quname";
1766 #::logDebug("indirect login query: $q");
1767                         my $ary = $udb->query($q)
1768                                 or do {
1769                                         my $msg = errmsg( "Database access error for query: %s", $q);
1770                                         die "$msg\n";
1771                                 };
1772                         @$ary == 1
1773                                 or do {
1774                                         $self->log_either(errmsg(
1775                                                 @$ary ? "Denied attempted login with ambiguous (indirect from %s) user name %s" : "Denied attempted login with nonexistent (indirect from %s) user name %s",
1776                                                 $foreign,
1777                                                 $quname,
1778                                                 $self->{USERNAME},
1779                                         ));
1780                                         if ($self->{OPTIONS}{fallback_login}) {
1781                                                 $ary->[0][0] = $uname;
1782                                         }
1783                                         else {
1784                                                 die $stock_error, "\n";
1785                                         }
1786                                 };
1787                         $self->{USERNAME} = $ary->[0][0];
1788                 }
1789
1790                 # If not superuser, an entry must exist in access database
1791                 unless ($Vend::superuser) {
1792                         unless ($udb->record_exists($self->{USERNAME})) {
1793                                 $self->log_either(errmsg("Denied attempted login with nonexistent user name '%s'",
1794                                         $self->{USERNAME}));
1795                                 die $stock_error, "\n";
1796                         }
1797                         unless ($user_data = $udb->row_hash($self->{USERNAME})) {
1798                                 $self->log_either(errmsg("Login denied after failed fetch of user data for user '%s'",
1799                                         $self->{USERNAME}));
1800                                 die $stock_error, "\n";
1801                         }
1802                         my $db_pass = $user_data->{ $self->{LOCATION}{PASSWORD} };
1803                         unless ($db_pass) {
1804                                 $self->log_either(errmsg("Refusing to use blank password from '%s' database for user '%s'", $self->{DB_ID}, $self->{USERNAME}));
1805                                 die $stock_error, "\n";
1806                         }
1807                         $pw = $self->{PASSWORD};
1808
1809                         if ( $self->{CRYPT} && $self->{OPTIONS}{promote} ) {
1810                                 my ($cur_method) = grep { $self->{OPTIONS}{ $_ } } keys %enc_subs;
1811                                 $cur_method ||= 'default';
1812
1813                                 my $stored_by = $enc_id{ determine_cipher($db_pass) };
1814                                 my $from_sub = $self->{OPTIONS}{from_plain} ? sub {$_[1]} : $enc_subs{$stored_by};
1815
1816                                 if (
1817                                         $cur_method ne $stored_by
1818                                         ||
1819                                         $cur_method eq 'bcrypt'
1820                                         &&
1821                                         bcost($self->{OPTIONS}) != bcost($self->{OPTIONS}, bmarshal($db_pass))
1822                                         and
1823                                         $db_pass eq $from_sub->($self, $pw, $db_pass)
1824                                 ) {
1825
1826                                         my $newpass = $enc_subs{$cur_method}->($self, $pw, Vend::Util::random_string(2));
1827                                         my $db_newpass = eval {
1828                                                 $self->{DB}->set_field(
1829                                                         $self->{USERNAME},
1830                                                         $self->{LOCATION}{PASSWORD},
1831                                                         $newpass,
1832                                                 );
1833                                         };
1834
1835                                         if ($db_newpass ne $newpass) {
1836                                                 # Usually, an error in the update will cause $db_newpass to be set to a
1837                                                 # useful error string. The usefulness is dependent on DB store itself, though.
1838                                                 my $err_msg = qq{Could not update database "%s" field "%s" with promoted password due to error:\n}
1839                                                         . "%s\n"
1840                                                         . qq{Check that field "%s" is at least %s characters wide.\n};
1841                                                 $err_msg = ::errmsg(
1842                                                         $err_msg,
1843                                                         $self->{DB_ID},
1844                                                         $self->{LOCATION}{PASSWORD},
1845                                                         $DBI::errstr,
1846                                                         $self->{LOCATION}{PASSWORD},
1847                                                         length($newpass),
1848                                                 );
1849                                                 ::logError($err_msg);
1850                                                 die $err_msg;
1851                                         } 
1852                                         $db_pass = $newpass;
1853                                 }
1854                         }
1855
1856                         if ($self->{CRYPT}) {
1857                                 $self->{PASSWORD} = $self->do_crypt($pw, $db_pass);
1858                         }
1859                         else {
1860                                 $db_pass = lc $db_pass if $self->{OPTIONS}{ignore_case};
1861                         }
1862 #::logDebug(errmsg("crypt: %s", $self->{CRYPT}));
1863 #::logDebug(errmsg("ignore_case: %s", $self->{OPTIONS}{ignore_case}));
1864 #::logDebug(errmsg("given password: %s", $self->{PASSWORD}));
1865 #::logDebug(errmsg("stored password: %s", $db_pass));
1866                         unless ($self->{PASSWORD} eq $db_pass) {
1867                                 $self->log_either(errmsg("Denied attempted login by user '%s' with incorrect password",
1868                                         $self->{USERNAME}));
1869                                 die $stock_error, "\n";
1870                         }
1871                         $self->log_either(errmsg("Successful login by user '%s'", $self->{USERNAME}));
1872                 }
1873
1874                 if($self->{PRESENT}->{ $self->{LOCATION}{EXPIRATION} } ) {
1875                         my $now = time();
1876                         my $cmp = $now;
1877                         $cmp = POSIX::strftime("%Y%m%d%H%M", localtime($now))
1878                                 unless $self->{OPTIONS}->{unix_time};
1879                         my $exp = $udb->field(
1880                                                 $self->{USERNAME},
1881                                                 $self->{LOCATION}{EXPIRATION},
1882                                                 );
1883                         die errmsg("Expiration date not set.") . "\n"
1884                                 if ! $exp and $self->{EMPTY_EXPIRE_FATAL};
1885                         if($exp and $exp < $cmp) {
1886                                 die errmsg("Expired %s.", $exp) . "\n";
1887                         }
1888                 }
1889
1890                 if($self->{PRESENT}->{ $self->{LOCATION}{MERGED_USER} } ) {
1891                         my $old = $self->{USERNAME};
1892                         my $new = $udb->field(
1893                                                 $self->{USERNAME},
1894                                                 $self->{LOCATION}{MERGED_USER},
1895                                                 );
1896                         if($new) {
1897                                 $self->{USERNAME} = $new;
1898                                 my $msg = errmsg('%s logged in as user %s, merged.', $old, $new);
1899                                 Vend::Tags->warnings($msg);
1900                                 $self->log_either($msg);
1901                         }
1902                 }
1903
1904                 if($self->{PRESENT}->{ $self->{LOCATION}{GROUPS} } ) {
1905                         $Vend::groups
1906                         = $Vend::Session->{groups}
1907                         = $udb->field(
1908                                                 $self->{USERNAME},
1909                                                 $self->{LOCATION}{GROUPS},
1910                                                 );
1911                 }
1912
1913                 username_cookies($self->{PASSED_USERNAME} || $self->{USERNAME}, $pw, $self->{OPTIONS}{secure_cookies}) 
1914                         if $Vend::Cfg->{CookieLogin};
1915
1916                 if ($self->{LOCATION}{LAST} ne 'none') {
1917                         my $now = time();
1918                         my $login_time;
1919                         unless($self->{OPTIONS}{null_time}) {
1920                                 $login_time = $self->{OPTIONS}{iso_time}
1921                                                 ? POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime($now))
1922                                                 : $now;
1923                         }
1924                         eval {
1925                                 $udb->set_field( $self->{USERNAME},
1926                                                                         $self->{LOCATION}{LAST},
1927                                                                         $login_time
1928                                                                         );
1929                         };
1930                         if ($@) {
1931                                 my $msg = errmsg("Failed to record timestamp in UserDB: %s", $@);
1932                                 logError($msg);
1933                                 die $msg, "\n";
1934                         }
1935                 }
1936                 $self->log('login') if $options{'log'};
1937                 
1938                 $self->get_values($self->{OPTIONS}{valref}, $self->{OPTIONS}{scratchref}) unless $self->{OPTIONS}{no_get};
1939         };
1940
1941         scrub();
1942
1943         if($@) {
1944                 if(defined $self) {
1945                         $self->{ERROR} = $@;
1946                 }
1947                 else {
1948                         logError( "Vend::UserDB error: %s\n", $@ );
1949                 }
1950                 return undef;
1951         }
1952
1953         PRICING: {
1954                 my $pprof;
1955                 last PRICING
1956                         unless  $self->{LOCATION}{PRICING}
1957                         and             $pprof = $user_data->{ $self->{LOCATION}{PRICING} };
1958
1959                 Vend::Interpolate::tag_profile(
1960                                                                 $pprof,
1961                                                                 { tag => $self->{OPTIONS}{profile} },
1962                                                                 );
1963         }
1964
1965         $Vend::login_table = $Vend::Session->{login_table} = $self->{DB_ID};
1966         $Vend::username = $Vend::Session->{username} = $self->{USERNAME};
1967         $Vend::Session->{logged_in} = 1;
1968
1969         ## $self->{ADMIN} comes when promote_admin option is set to a field,
1970         ## and that field is set in both scratch and the database.
1971         if ( $self->{ADMIN} or $Vend::ReadOnlyCfg->{AdminUserDB}{$self->{PROFILE}} ) {
1972                 $Vend::admin = 1;
1973         }
1974
1975         if (my $macros = $self->{OPTIONS}{postlogin_action}) {
1976                 eval {
1977                         Vend::Dispatch::run_macro $macros;
1978                 };
1979                 if ($@) {
1980                         logError("UserDB postlogin_action execution error: %s\n", $@);
1981                 }
1982         }
1983
1984         1;
1985 }
1986
1987 sub scrub {
1988         for(qw/ mv_password mv_verify mv_password_old /) {
1989                 delete $CGI::values{$_};
1990                 delete $::Values->{$_};
1991         }
1992 }
1993
1994 sub logout {
1995         my $self = shift or return undef;
1996         scrub();
1997
1998         my $opt = $self->{OPTIONS};
1999
2000         if (my $macros = $opt->{prelogout_action}) {
2001                 eval {
2002                         Vend::Dispatch::run_macro $macros;
2003                 };
2004                 if ($@) {
2005                         logError("UserDB prelogout_action execution error: %s\n", $@);
2006                 }
2007         }
2008
2009         if( is_yes($opt->{clear}) ) {
2010                 $self->clear_values();
2011         }
2012
2013         Vend::Interpolate::tag_profile("", { restore => 1 });
2014         no strict 'refs';
2015
2016         my @dels = qw/
2017                                         groups
2018                                         admin
2019                                         superuser
2020                                         login_table
2021                                         username
2022                                         logged_in
2023                                 /;
2024
2025         for(@dels) {
2026                 delete $Vend::Session->{$_};
2027                 undef ${"Vend::$_"};
2028         }
2029
2030         delete $CGI::values{mv_username};
2031         delete $::Values->{mv_username};
2032         $self->log('logout') if $opt->{log};
2033         $self->{MESSAGE} = errmsg('Logged out.');
2034         if ($opt->{clear_cookie}) {
2035                 my @cookies = split /[\s,\0]+/, $opt->{clear_cookie};
2036                 my $exp = 10;
2037                 for(@cookies) {
2038                         Vend::Util::set_cookie($_, '', $exp);
2039                 }
2040         }
2041         if ($opt->{clear_session}) {
2042                 Vend::Session::init_session();
2043         }
2044         return 1;
2045 }
2046
2047 sub change_pass {
2048
2049         my ($self, $original_self);
2050
2051         $self = shift
2052                 if ref $_[0];
2053
2054         my(%options) = @_;
2055         
2056         if ($self->{OPTIONS}{ignore_case}) {
2057            $self->{USERNAME} = lc $self->{USERNAME};
2058            $self->{OLDPASS} = lc $self->{OLDPASS};
2059            $self->{PASSWORD} = lc $self->{PASSWORD};
2060            $self->{VERIFY} = lc $self->{VERIFY};
2061         }
2062
2063         eval {
2064                 # Create copies so that ignore_case doesn't lc the originals.
2065                 my $vend_username = $Vend::username;
2066                 my $cgi_mv_username = $CGI::values{mv_username};
2067                 if ($self->{OPTIONS}{ignore_case}) {
2068                         $vend_username = lc $vend_username;
2069                         $cgi_mv_username = lc $cgi_mv_username
2070                                 if defined $cgi_mv_username;
2071                 }
2072
2073                 # Database operations still use the mixed-case original.
2074                 my $super = $Vend::superuser || (
2075                         $Vend::admin and
2076                         $self->{DB}->field($Vend::username, $self->{LOCATION}{SUPER})
2077                 );
2078
2079                 if ($self->{USERNAME} ne $vend_username or
2080                         defined $cgi_mv_username and
2081                         $self->{USERNAME} ne $cgi_mv_username
2082                 ) {
2083                         if ($super) {
2084                                 if ($cgi_mv_username and
2085                                         $cgi_mv_username ne $self->{USERNAME}) {
2086                                         $original_self = $self;
2087                                         $options{username} = $cgi_mv_username;
2088                                         undef $self;
2089                                 }
2090                         } else {
2091                                 errmsg("Unprivileged user '%s' attempted to change password of user '%s'",
2092                                         $vend_username, $self->{USERNAME}) if $options{log};
2093                                 die errmsg("You are not allowed to change another user's password.");
2094                         }
2095                 }
2096
2097                 unless($self) {
2098                         $self = new Vend::UserDB %options;
2099                 }
2100
2101                 die errmsg("Bad object.") unless defined $self;
2102
2103                 die errmsg("'%s' not a user.", $self->{USERNAME}) . "\n"
2104                         unless $self->{DB}->record_exists($self->{USERNAME});
2105
2106                 unless ($super and $self->{USERNAME} ne $Vend::username) {
2107                         my $db_pass = $self->{DB}->field($self->{USERNAME}, $self->{LOCATION}{PASSWORD});
2108                         if ($self->{CRYPT}) {
2109                                 $self->{OLDPASS} = $self->do_crypt($self->{OLDPASS}, $db_pass);
2110                         }
2111                         die errmsg("Must have old password.") . "\n"
2112                                 if $self->{OLDPASS} ne $db_pass;
2113                 }
2114
2115                 die errmsg("Must enter at least %s characters for password.",
2116                         $self->{PASSMINLEN}) . "\n"
2117                         if length($self->{PASSWORD}) < $self->{PASSMINLEN}; 
2118                 die errmsg("Password and check value don't match.") . "\n"
2119                         unless $self->{PASSWORD} eq $self->{VERIFY};
2120
2121                 $self->{OPTIONS}{enclair_db} and $self->set_enclair();
2122
2123                 if ( $self->{CRYPT} ) {
2124                         $self->{PASSWORD} = $self->do_crypt(
2125                                 $self->{PASSWORD},
2126                                 Vend::Util::random_string(2),
2127                         );
2128                 }
2129                 
2130                 my $pass = $self->{DB}->set_field(
2131                                                 $self->{USERNAME},
2132                                                 $self->{LOCATION}{PASSWORD},
2133                                                 $self->{PASSWORD}
2134                                                 );
2135                 die errmsg("Database access error.") . "\n" unless defined $pass;
2136                 $self->log(errmsg('change password')) if $options{'log'};
2137         };
2138
2139         scrub();
2140
2141         $self = $original_self if $original_self;
2142
2143         if($@) {
2144                 if(defined $self) {
2145                         $self->{ERROR} = $@;
2146                         $self->log(errmsg('change password failed')) if $options{'log'};
2147                 }
2148                 else {
2149                         logError( "Vend::UserDB error: %s", $@ );
2150                 }
2151                 return undef;
2152         }
2153         
2154         1;
2155 }
2156
2157 sub assign_username {
2158         my $self = shift;
2159         my $file = shift || $self->{OPTIONS}{counter};
2160         my $start = $self->{OPTIONS}{username} || 'U00000';
2161         $file = './etc/username.counter' if ! $file;
2162
2163         my $o = { start => $start, sql => $self->{OPTIONS}{sql_counter} };
2164
2165         my $custno;
2166
2167         if(my $l = $Vend::Cfg->{Accounting}) {
2168
2169                 my $class = $l->{Class};
2170
2171                 my $assign = defined $l->{assign_username} ? $l->{assign_username} : 1;
2172
2173                 if($assign) {
2174 #::logDebug("Accounting class is $class");
2175                 my $obj;
2176                 eval {
2177                                 $obj = $class->new;
2178                 };
2179 #::logDebug("Accounting object is $obj");
2180
2181                 if($@) {
2182                         die errmsg(
2183                                 "Failed to assign new customer number with accounting system %s",
2184                                 $class,
2185                                 );
2186                 }
2187                 $custno = $obj->assign_customer_number();
2188                 }
2189 #::logDebug("assigned new customer number $custno");
2190         }
2191
2192         return $custno || Vend::Interpolate::tag_counter($file, $o);
2193 }
2194
2195 sub new_account {
2196
2197         my $self;
2198
2199         $self = shift
2200                 if ref $_[0];
2201
2202         my(%options) = @_;
2203         
2204         eval {
2205                 unless($self) {
2206                         $self = new Vend::UserDB %options;
2207                 }
2208
2209                 delete $Vend::Session->{auto_created_user};
2210
2211                 die errmsg("Bad object.") . "\n" unless defined $self;
2212
2213                 die errmsg("Already logged in. Log out first.") . "\n"
2214                         if $Vend::Session->{logged_in} and ! $options{no_login};
2215                 die errmsg("Sorry, reserved user name.") . "\n"
2216                         if $self->{OPTIONS}{username_mask} 
2217                                 and $self->{USERNAME} =~ m!$self->{OPTIONS}{username_mask}!;
2218                 die errmsg("Sorry, user name must be an email address.") . "\n"
2219                         if $self->{OPTIONS}{username_email} 
2220                                 and $self->{USERNAME} !~ m!^[[:alnum:]]([.]?([[:alnum:]._-]+)*)?@([[:alnum:]\-_]+\.)+[a-zA-Z]{2,4}$!;
2221                 die errmsg("Must enter at least %s characters for password.",
2222                         $self->{PASSMINLEN}) . "\n"
2223                         if length($self->{PASSWORD}) < $self->{PASSMINLEN};
2224                 die errmsg("Password and check value don't match.") . "\n"
2225                         unless $self->{PASSWORD} eq $self->{VERIFY};
2226
2227                 if ($self->{OPTIONS}{ignore_case}) {
2228                         $self->{PASSWORD} = lc $self->{PASSWORD};
2229                         $self->{USERNAME} = lc $self->{USERNAME};
2230                 }
2231
2232                 my $pw = $self->{PASSWORD};
2233                 if($self->{CRYPT}) {
2234                         eval {
2235                                 $pw = $self->do_crypt($pw, Vend::Util::random_string(2));
2236                         };
2237                 }
2238         
2239                 my $udb = $self->{DB};
2240
2241                 if($self->{OPTIONS}{assign_username}) {
2242                         $self->{PASSED_USERNAME} = $self->{USERNAME};
2243                         $self->{USERNAME} = $self->assign_username();
2244                         $self->{USERNAME} = lc $self->{USERNAME}
2245                                 if $self->{OPTIONS}{ignore_case};
2246                 }
2247                 # plain error message without user-supplied username
2248                 # to avoid XSS exploit (RT #306)
2249                 die errmsg("Username contains illegal characters.") . "\n"
2250                         if $self->{USERNAME} !~ m{^$self->{VALIDCHARS}+$};
2251                 die errmsg("Must have at least %s characters in username.",
2252                         $self->{USERMINLEN}) . "\n"
2253                         if length($self->{USERNAME}) < $self->{USERMINLEN};
2254
2255                 if($self->{OPTIONS}{captcha}) {
2256                         my $status = Vend::Tags->captcha( { function => 'check' });
2257                         die errmsg("Must input captcha code correctly.") . "\n"
2258                                 unless $status;
2259                 }
2260
2261                 # Here we put the username in a non-primary key field, checking
2262                 # for existence
2263                 my $foreign = $self->{OPTIONS}{indirect_login};
2264                 if ($foreign) {
2265                         my $uname = ($self->{PASSED_USERNAME} ||= $self->{USERNAME});
2266                         $uname = $udb->quote($uname);
2267                         my $q = "select $foreign from $self->{DB_ID} where $foreign = $uname";
2268                         my $ary = $udb->query($q)
2269                                 or do {
2270                                         my $msg = errmsg( "Database access error for query: %s", $q);
2271                                         die "$msg\n";
2272                                 };
2273                         @$ary == 0
2274                                 or do {
2275                                         my $msg = errmsg( "Username already exists (indirect).");
2276                                         die "$msg\n";
2277                                 };
2278                 }
2279
2280                 if ($udb->record_exists($self->{USERNAME})) {
2281                         die errmsg("Username already exists.") . "\n";
2282                 }
2283
2284                 if($foreign) {
2285                          $udb->set_field(
2286                                                 $self->{USERNAME},
2287                                                 $foreign,
2288                                                 $self->{PASSED_USERNAME},
2289                                                 )
2290                                 or die errmsg("Database access error.");
2291                 }
2292
2293                 $self->{OPTIONS}{enclair_db} and $self->set_enclair();
2294
2295                 my $pass = $udb->set_field(
2296                                                 $self->{USERNAME},
2297                                                 $self->{LOCATION}{PASSWORD},
2298                                                 $pw,
2299                                                 );
2300
2301                 die errmsg("Database access error.") . "\n" unless defined $pass;
2302
2303                 if($self->{OPTIONS}{username_email}) {
2304                         my $field_name = $self->{OPTIONS}{username_email_field} || 'email';
2305                         $::Values->{$field_name} ||= $self->{USERNAME};
2306                         $udb->set_field(
2307                                                 $self->{USERNAME},
2308                                                 $field_name,
2309                                                 $self->{USERNAME},
2310                                                 )
2311                                  or die errmsg("Database access error: %s", $udb->errstr) . "\n";
2312                 }
2313
2314                 my $dfield;
2315                 my $dstring;
2316                 if($dfield = $self->{OPTIONS}{created_date_iso}) {
2317                         if($self->{OPTIONS}{created_date_gmtime}) {
2318                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%SZ', gmtime());
2319                         }
2320                         elsif($self->{OPTIONS}{created_date_showzone}) {
2321                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S %z', localtime());
2322                         }
2323                         else {
2324                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime());
2325                         }
2326                 }
2327                 elsif($dfield = $self->{OPTIONS}{created_date_epoch}) {
2328                         $dstring = time;
2329                 }
2330
2331                 if($dfield and $dstring) {
2332                         $udb->set_field(
2333                                                 $self->{USERNAME},
2334                                                 $dfield,
2335                                                 $dstring,
2336                                                 )
2337                                 or do { 
2338                                         my $msg = errmsg('Failed to set new account creation date: %s', $udb->errstr);
2339                                         Vend::Tags->warnings($msg);
2340                                 };
2341                 }
2342
2343                 if($options{no_login}) {
2344                         $Vend::Session->{auto_created_user} = $self->{USERNAME};
2345                 }
2346                 else {
2347                         $self->set_values() unless $self->{OPTIONS}{no_set};
2348                         $self->{USERNAME} = $foreign if $foreign;
2349                         username_cookies($self->{USERNAME}, $pw, $self->{OPTIONS}{secure_cookies}) 
2350                                 if $Vend::Cfg->{CookieLogin};
2351
2352                         $self->log('new account') if $options{'log'};
2353                         $self->login()
2354                                 or die errmsg(
2355                                                         "Cannot log in after new account creation: %s",
2356                                                         $self->{ERROR},
2357                                                 );
2358                 }
2359         };
2360
2361         scrub();
2362
2363         if($@) {
2364                 if(defined $self) {
2365                         $self->{ERROR} = $@;
2366                 }
2367                 else {
2368                         logError( "Vend::UserDB error: %s\n", $@ );
2369                 }
2370                 return undef;
2371         }
2372         
2373         1;
2374 }
2375
2376 sub username_cookies {
2377                 my ($user, $pw, $secure) = @_;
2378                 return unless
2379                          $CGI::values{mv_cookie_password}               or
2380                          $CGI::values{mv_cookie_username}               or
2381                          Vend::Util::read_cookie('MV_PASSWORD') or
2382                          Vend::Util::read_cookie('MV_USERNAME');
2383                 $::Instance->{Cookies} = [] unless defined $::Instance->{Cookies};
2384                 my $exp = time() + $Vend::Cfg->{SaveExpire};
2385                 $secure ||= $CGI::secure;
2386                 push @{$::Instance->{Cookies}},
2387                         ['MV_USERNAME', $user, $exp];
2388                 return unless
2389                         $CGI::values{mv_cookie_password}                or
2390                         Vend::Util::read_cookie('MV_PASSWORD');
2391                 push @{$::Instance->{Cookies}},
2392                         ['MV_PASSWORD', $pw, $exp, undef, undef, $secure];
2393                 return;
2394 }
2395
2396 sub get_cart {
2397         my($self, %options) = @_;
2398
2399         my $from = $self->{NICKNAME};
2400         my $to;
2401
2402         my $opt = $self->{OPTIONS};
2403
2404         if ($opt->{target}) {
2405                 $to = ($::Carts->{$opt->{target}} ||= []);
2406         }
2407         else {
2408                 $to = $Vend::Items;
2409         }
2410
2411 #::logDebug ("to=$to nick=$opt->{target} from=$from cart=" . ::uneval_it($from));
2412
2413         my $field_name = $self->{LOCATION}->{CARTS};
2414         my $cart = [];
2415
2416         eval {
2417                 die errmsg("no from cart name?")                                unless $from;
2418                 die errmsg("%s field not present to get %s", $field_name, $from) . "\n"
2419                                                                                 unless $self->{PRESENT}->{$field_name};
2420
2421                 my $s = $self->{DB}->field( $self->{USERNAME}, $field_name);
2422
2423                 die errmsg("no saved carts.") . "\n" unless $s;
2424
2425                 my @carts = split /\0/, $from;
2426                 my $d = string_to_ref($s);
2427 #::logDebug ("saved carts=" . ::uneval_it($d));
2428
2429                 die errmsg("eval failed?")                              unless ref $d;
2430
2431                 for(@carts) {
2432                         die errmsg("source cart '%s' does not exist.", $from) . "\n" unless ref $d->{$_};
2433                         push @$cart, @{$d->{$_}};
2434                 }
2435
2436         };
2437
2438         if($@) {
2439                 $self->{ERROR} = $@;
2440                 return undef;
2441         }
2442 #::logDebug ("to=$to nick=$opt->{target} from=$from cart=" . ::uneval_it($cart));
2443
2444         if($opt->{merge}) {
2445                 $to = [] unless ref $to;
2446                 my %used;
2447                 my %alias;
2448                 my $max;
2449
2450                 for(@$to) {
2451                         my $master;
2452                         next unless $master = $_->{mv_mi};
2453                         $used{$master} = 1;
2454                         $max = $master if $master > $max;
2455                 }
2456
2457                 $max++;
2458
2459                 my $rename;
2460                 my $alias = 100;
2461                 for(@$cart) {
2462                         my $master;
2463                         next unless $master = $_->{mv_mi};
2464                         next unless $used{$master};
2465
2466                         if(! $_->{mv_si}) {
2467                                 $alias{$master} = $max++;
2468                                 $_->{mv_mi} = $alias{$master};
2469                         }
2470                         else {
2471                                 $_->{mv_mi} = $alias{$master};
2472                         }
2473                 }
2474
2475                 push(@$to,@$cart);
2476
2477         }
2478         else {
2479                 @$to = @$cart;
2480         }
2481 }
2482
2483 sub set_cart {
2484         my($self, %options) = @_;
2485
2486         my $from;
2487         my $to   = $self->{NICKNAME};
2488
2489         my $opt = $self->{OPTIONS};
2490
2491         if ($opt->{source}) {
2492                 $from = $::Carts->{$opt->{source}} || [];
2493         }
2494         else {
2495                 $from = $Vend::Items;
2496         }
2497
2498         my $field_name = $self->{LOCATION}->{CARTS};
2499         my ($cart,$s,$d);
2500
2501         eval {
2502                 die errmsg("no to cart name?") . "\n"                                   unless $to;
2503                 die errmsg('%s field not present to set %s', $field_name, $from) . "\n"
2504                                                                                 unless $self->{PRESENT}->{$field_name};
2505
2506                 $d = string_to_ref( $self->{DB}->field( $self->{USERNAME}, $field_name) );
2507
2508                 $d = {} unless $d;
2509
2510                 die errmsg("eval failed?")                              unless ref $d;
2511
2512                 if($opt->{merge}) {
2513                         $d->{$to} = [] unless ref $d->{$to};
2514                         push(@{$d->{$to}}, @{$from});
2515                 }
2516                 else {
2517                 }
2518
2519                 $d->{$to} = $from;
2520
2521                 $s = uneval $d;
2522
2523         };
2524
2525         if($@) {
2526                 $self->{ERROR} = $@;
2527                 return undef;
2528         }
2529
2530         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
2531
2532 }
2533
2534
2535 =head2 The [userdb ...] tag
2536
2537 Interchange provides a C<[userdb ...]> tag to access the UserDB functions.
2538
2539  [userdb
2540         function=function_name
2541         username="username"
2542         assign_username=1
2543         username_mask=REGEX
2544         password="password"
2545         verify="password"
2546         oldpass="old password"
2547         crypt="1|0"
2548                 bcrypt=1
2549                 promote=1
2550                 md5=1
2551                 md5_salted=1
2552                 sha1=1
2553                 valref=user_record
2554                 scratchref=user_record
2555         shipping="fields for shipping save"
2556         billing="fields for billing save"
2557         preferences="fields for preferences save"
2558         ignore_case="1|0"
2559         force_lower=1
2560         param1=value
2561         param2=value
2562         ...
2563         ]
2564
2565 All parameters are optional except for the function. Normally, parameters 
2566 are set in catalog.cfg with the I<UserDB> directive.
2567
2568 It is normally called in an C<mv_click> or C<mv_check> setting, as in:
2569
2570     [set Login]
2571     mv_todo=return
2572     mv_nextpage=welcome
2573     [userdb function=login]
2574     [/set]
2575
2576     <FORM ACTION="[process-target]" METHOD=POST>
2577     <INPUT TYPE=hidden NAME=mv_click VALUE=Login>
2578     Username <INPUT NAME=mv_username SIZE=10>
2579     Password <INPUT NAME=mv_password SIZE=10>
2580     </FORM>
2581
2582 There are several global parameters that apply to any use of
2583 the C<userdb> functions. Most importantly, by default the database
2584 table is set to be I<userdb>. If you must use another table name,
2585 then you should include a C<database=table> parameter with any
2586 call to C<userdb>. The global parameters (default in parens):
2587
2588     database     Sets user database table (userdb)
2589     show         Show the return value of certain functions
2590                  or the error message, if any (0)
2591     force_lower  Force possibly upper-case database fields
2592                  to lower case session variable names (0)
2593     billing      Set the billing fields (see Accounts)
2594     shipping     Set the shipping fields (see Address Book)
2595     preferences  Set the preferences fields (see Preferences)
2596     bill_field   Set field name for accounts (accounts)
2597     addr_field   Set field name for address book (address_book)
2598     pref_field   Set field name for preferences (preferences)
2599     cart_field   Set field name for cart storage (carts)
2600     pass_field   Set field name for password (password)
2601     time_field   Set field for storing last login time (time)
2602     expire_field Set field for expiration date (expire_date)
2603     acl          Set field for simple access control storage (acl)
2604     file_acl     Set field for file access control storage (file_acl)
2605     db_acl       Set field for database access control storage (db_acl)
2606
2607 By default the system crypt() call will be used to compare the
2608 password. This is minimal security, but at least the passwords in the user
2609 database will not be human readable. For better security, in descending
2610 order of security, use:
2611
2612         bcrypt    Bcrypt, most secure
2613         sha1      SHA1 digest, more secure than MD5
2614         md5       Not so easily stored in cracklib as md5 unsalted
2615         md5       Better security than crypt
2616
2617 If you don't keep actual user information, don't have users creating
2618 accounts and setting the passwords themselvs, and don't do Interchange
2619 administration via the C<UserDB> capability, then you may
2620 wish to use the <UserDB> directive (described below) to set
2621 encryption off by default:
2622
2623     UserDB   default   crypt   0
2624
2625 That will set encryption off by default. You can still set encryption
2626 on by passing C<crypt=1> with any call to a C<new_account>, C<change_pass>,
2627 or C<login> call.
2628
2629 WARNING: Using unencrypted passwords is never recommended if you have users
2630 setting their passwords. They will use the same passwords as other systems,
2631 possibly compromising important information.
2632
2633 =head2 Setting defaults with the UserDB directive
2634
2635 The I<UserDB> directive provides a way to set defaults for
2636 the user database. For example, if you always wanted to save
2637 and recall the scratch variable C<tickets> in the user database
2638 instead of the form variable C<tickets>, you could set:
2639
2640     UserDB   default   scratch  tickets
2641
2642 That makes every call to C<[userdb function=login]> be equivalent
2643 to C<[userdb function=login scratch=tickets]>.
2644
2645 If you wish to override that default for one call only, you can
2646 use C<[userdb function=login scratch="passes"]>.
2647
2648 If you wish to log failed access authorizations, set the C<UserDB>
2649 profile parameter C<log_failed> true:
2650
2651     UserDB  default  log_failed 1
2652
2653 To disable logging of failed access authorizations (the default), set
2654 the C<UserDB> profile parameter C<log_failed> to 0:
2655
2656     UserDB  default  log_failed 0
2657
2658 The I<UserDB> directive uses the same key-value pair settings
2659 as the I<Locale> and I<Route> directives, and you may have more
2660 than one set of defaults. You can set them in a hash structure:
2661
2662     UserDB  case_crypt  scratch     tickets
2663     UserDB  case_crypt  bcrypt      1
2664     UserDB  case_crypt  ignore_case 0
2665
2666     UserDB  default     scratch     tickets
2667     UserDB  default     sha1        1
2668     UserDB  default     ignore_case 1
2669
2670 The last one to be set becomes the default.
2671
2672 The option C<profile> selects the set to use. So if you wanted
2673 usernames and passwords to be case sensitive with bcrypt encryption,
2674 you could pass this call:
2675
2676     [userdb function=new_account profile=case_crypt]
2677
2678 The username and password will be stored as typed in, and the
2679 password will be encrypted in the database.
2680
2681 =head2 User Database functions
2682
2683 The user database features are implemented as a series of functions
2684 attached to the C<userdb> tag. The functions are:
2685
2686 =over 4
2687
2688 =item login
2689
2690 Log in to Interchange. By default, the username is contained in the
2691 form variable C<mv_username> and the password in C<mv_password>.
2692 If the login is successful, the session value C<username>
2693 (C<[data session username]>) will be set to the user name.
2694
2695 This will recall the values of all non-special fields in the user
2696 database and place them in their corresponding user form variables.
2697
2698 =item logout
2699
2700 Log out of Interchange. No additional parameters are needed.
2701
2702 =item new_account
2703
2704 Create a new account. It requires the C<username>, C<password>, and
2705 C<verify> parameters, which are by default contained in the form
2706 variables C<mv_username>, C<mv_password>, C<mv_verify> respectively.
2707
2708 If you set the C<assign_username> parameter, then UserDB will assign
2709 a sequential username. The C<counter> parameter can be used to set
2710 the filename (must be absolute), or you can accept the default of
2711 CATALOG_DIR/etc/username.counter. The first username will be "U0001"
2712 if the counter doesn't exist already.
2713
2714 The C<ignore_case> parameter forces the username and password to
2715 lower case in the database, in effect rendering the username and
2716 password case-insensitive.
2717
2718 If you set C<username_mask> to a valid Perl regular expression (without
2719 the surrounding / /) then any username containing a matching string will
2720 not be allowed for use. For example, to screen out order numbers from
2721 being used by a random user:
2722
2723     [userdb function=new_account
2724             username_mask="^[A-Z]*[0-9]"
2725             ]
2726
2727 The I<CookieLogin> directive (catalog.cfg) allows users to save
2728 their username/password in a cookie. Expiration time is set by
2729 I<SaveExpire>, renewed every time they log in. To cause the cookie to
2730 be generated originally, the form variable C<mv_cookie_password> or
2731 C<mv_cookie_username> must be set in the login form. The former causes
2732 both username and password to be saved, the latter just the username.
2733
2734 If you want to automatically create an account for every order,
2735 you can do in the I<OrderReport> file:
2736
2737     [userdb function=new_account
2738             username="[value mv_order_number]"
2739             password="[value zip]"
2740             verify="[value zip]"
2741             database="orders"
2742             ]
2743
2744 This would be coupled with a login form that asked for order number and
2745 zip code; thereupon allowing you to display the contents of a transaction
2746 database with (presumably updated) order status information or a shipping
2747 company tracking number.
2748
2749 =item change_pass
2750
2751 Change the password on the currently logged-in account. It requires
2752 the C<username>, C<password>, C<verify>, and C<oldpass> parameters,
2753 which are by default contained in the form variables C<mv_username>,
2754 C<mv_password>, C<mv_verify>, C<mv_password_old> respectively.
2755
2756 =item set_shipping
2757
2758 Active parameters: nickname, shipping, ship_field
2759
2760 Place an entry in the shipping Address book. Example:
2761
2762     [userdb function=set_shipping nickname=Dad]
2763
2764 See I<Address Book> below.
2765
2766 =item get_shipping
2767
2768 Active parameters: nickname, shipping, ship_field
2769
2770 Recall an entry from the shipping Address book. Example:
2771
2772     [userdb function=get_shipping nickname=Dad]
2773
2774 See I<Address Book> below.
2775
2776 =item get_shipping_names
2777
2778 Active parameters: ship_field
2779
2780 Gets the names of shipping address book entries and places
2781 them in the variable C<address_book>. By default, it does not return
2782 the values; if you wish them to be returned you can set
2783 the parameter C<show> to 1, as in:
2784
2785     [set name=shipping_nicknames
2786          interpolate=1]
2787       [userdb function=get_shipping_names show=1]
2788     [/set]
2789
2790 =item set_billing
2791
2792 Active parameters: nickname, billing, bill_field
2793
2794 Place an entry in the billing accounts book. Example:
2795
2796     [userdb function=set_billing nickname=discover]
2797
2798 See I<Accounts Book> below.
2799
2800 =item get_billing
2801
2802 Active parameters: nickname, billing, bill_field
2803
2804 Recall an entry from the billing accounts book. Example:
2805
2806     [userdb function=get_billing nickname=visa]
2807
2808 See I<Accounts Book> below.
2809
2810 =item save
2811
2812 Saves all non-special form values that have columns in the user database.
2813
2814 =item load
2815
2816 Performs the transfer of user values to the values space, scratch space, and
2817 constant space. Performed automatically upon login.
2818
2819 If you pass the C<valref> option, that will be used instead of C<$Values> for
2820 the values space. It can either be a real hash reference, or a scalar that
2821 will be a key directly in C<$Vend::Session>. If it contains a colon (C<:>), it
2822 will be a subreference in C<$Vend::Session>. For example:
2823
2824         [userdb function=load valref=`$Session->{user_record} ||= {}`]
2825
2826 Will store the values in C<$Vend::Session->{user_record}>, clearing it first.
2827 The below accomplishes the same thing:
2828
2829         [userdb function=load valref=user_record]
2830
2831 If you want to place it a couple of levels down, do:
2832
2833         [userdb function=load valref=`$Session->{values_repository}{userdb} ||= {}`]
2834
2835 or
2836
2837         [userdb function=load valref="values_repository:userdb"]
2838
2839 To clear the record instead of add to the existing values, add an
2840 asterisk at the end:
2841
2842         [userdb function=load valref="values_repository:userdb*"]
2843
2844 Which is equivalent to:
2845
2846         [userdb function=load valref=`$Session->{values_repository}{userdb} = {}`]
2847
2848 The C<scratchref> option is the same as C<valref>, but for the scratch values
2849 passed with C<UserDB scratch>.
2850
2851 =item set_cart
2852
2853 Save the contents of a shopping cart.
2854
2855     [userdb function=set_cart nickname=christmas]
2856
2857 See I<Carts> below.
2858
2859 =item get_cart
2860
2861 Active parameters: nickname, carts_field, target
2862
2863 Recall a saved shopping cart. 
2864
2865     [userdb function=get_cart nickname=mom_birthday]
2866
2867 Setting C<target> saves to a different shopping cart than the
2868 default main cart. The C<carts_field> controls the database
2869 field used for storage.
2870
2871 =item set_acl
2872
2873 Active parameters: location, acl_field, delete
2874
2875 Set a simple acl. Example:
2876
2877     [userdb function=set_acl location=cartcfg/editcart]
2878
2879 This allows the current user to access the page "cartcfg/editcart" if 
2880 it is access-protected.
2881
2882 To delete access, do:
2883
2884     [userdb function=set_acl location=cartcfg/editcart delete=1]
2885
2886 To display the setting at the same time as setting use the
2887 C<show> attribute:
2888
2889     [userdb function=set_acl location=cartcf/editcart show=1]
2890
2891 =item check_acl
2892
2893 Active parameters: location, acl_field
2894
2895 Checks the simple access control listing for a location, returning
2896 1 if allowed and the empty string if not allowed.
2897
2898     [if type=explicit
2899         compare="[userdb
2900                     function=check_acl
2901                     location=cartcfg/editcart]"
2902     ]
2903     [page cartcfg/editcart]Edit your cart configuration[/page]
2904     [/if]
2905
2906 =item set_file_acl, set_db_acl
2907
2908 Active parameters: location, mode, db_acl_field, file_acl_field, delete
2909
2910 Sets a complex access control value. Takes the form:
2911
2912     [userdb function=set_file_acl
2913             mode=rw
2914             location=products/inventory.txt]
2915
2916 where mode is any value you wish to check for with check_file_acl. As
2917 with the simple ACL, you can use delete=1 to delete the location entirely.
2918
2919 =item check_file_acl, check_db_acl
2920
2921 Active parameters: location, mode, db_acl_field, file_acl_field
2922
2923 Checks a complex access control value and returns a true/false (1/0)
2924 value. Takes the form:
2925
2926     [userdb function=check_db_acl
2927             mode=w
2928             location=inventory]
2929
2930 where mode is any value you wish to check for with check_file_acl. It
2931 will return true if the mode string is contained within the entry
2932 for that location. Example:
2933
2934     [if type=explicit
2935         compare="[userdb
2936                     function=check_db_acl
2937                     mode=w
2938                     location=inventory]"
2939     ]
2940     [userdb function=set_acl location=cartcfg/edit_inventory]
2941     [page cartcfg/edit_inventory]You may edit the inventory database[/page]
2942     [else]
2943     [userdb function=set_acl location=cartcfg/edit_inventory delete=1]
2944     Sorry, you can't edit inventory.
2945     [/if]
2946
2947 =back
2948
2949 =cut
2950
2951 sub userdb {
2952         my $function = shift;
2953         my $opt = shift;
2954
2955         my %options;
2956
2957         if(ref $opt) {
2958                 %options = %$opt;
2959         }
2960         else {
2961                 %options = ($opt, @_);
2962         }
2963
2964         my $status = 1;
2965         my $user;
2966
2967         my $module = $Vend::Cfg->{UserControl} ? 'Vend::UserControl' : 'Vend::UserDB';
2968
2969         if($function eq 'login') {
2970                 $Vend::Session->{logged_in} = 0;
2971                 delete $Vend::Session->{username};
2972                 delete $Vend::Session->{groups};
2973                 undef $Vend::username;
2974                 undef $Vend::groups;
2975                 undef $Vend::admin;
2976                 $user = $module->new(%options);
2977                 unless (defined $user) {
2978                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2979                         return undef;
2980                 }
2981                 if ($status = $user->login(%options) ) {
2982                         ::update_user();
2983                 }
2984         }
2985         elsif($function eq 'new_account') {
2986                 $user = $module->new(%options);
2987                 unless (defined $user) {
2988                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2989                         return undef;
2990                 }
2991                 $status = $user->new_account(%options);
2992                 if($status and ! $options{no_login}) {
2993                         $Vend::Session->{logged_in} = 1;
2994                         $Vend::Session->{username} = $user->{USERNAME};
2995                 }
2996         }
2997         elsif($function eq 'logout') {
2998                 $user = $module->new(%options)
2999                         or do {
3000                                 $Vend::Session->{failure} = errmsg("Unable to create user object.");
3001                                 return undef;
3002                         };
3003                 $user->logout();
3004         }
3005         elsif (! $Vend::Session->{logged_in}) {
3006                 $Vend::Session->{failure} = errmsg("Not logged in.");
3007                 return undef;
3008         }
3009         elsif($function eq 'save') {
3010                 $user = $module->new(%options);
3011                 unless (defined $user) {
3012                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
3013                         return undef;
3014                 }
3015                 $status = $user->set_values();
3016         }
3017         elsif($function eq 'load') {
3018                 $user = $module->new(%options);
3019                 unless (defined $user) {
3020                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
3021                         return undef;
3022                 }
3023                 $status = $user->get_values($opt->{valref}, $opt->{scratchref});
3024         }
3025         else {
3026                 $user = $module->new(%options);
3027                 unless (defined $user) {
3028                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
3029                         return undef;
3030                 }
3031                 eval {
3032                         $status = $user->$function(%options);
3033                 };
3034                 $user->{ERROR} = $@ if $@;
3035         }
3036         
3037         if(defined $status) {
3038                 delete $Vend::Session->{failure};
3039                 $Vend::Session->{success} = $user->{MESSAGE};
3040                 if($options{show_message}) {
3041                         $status = $user->{MESSAGE};
3042                 }
3043         }
3044         else {
3045                 $Vend::Session->{failure} = $user->{ERROR};
3046                 if($options{show_message}) {
3047                         $status = $user->{ERROR};
3048                 }
3049         }
3050         return $status unless $options{hide};
3051         return;
3052 }
3053
3054 sub do_crypt {
3055         my ($self, $password, $salt) = @_;
3056         my $sub = $self->{ENCSUB};
3057         unless ($sub) {
3058                 for (grep { $self->{OPTIONS}{$_} } keys %enc_subs) {
3059                         $sub = $enc_subs{$_};
3060                         last;
3061                 }
3062                 $self->{ENCSUB} = $sub ||= $enc_subs{default};
3063         }
3064         return $sub->($self, $password, $salt);
3065 }
3066
3067 1;