Also look in the next-highest directory when detecting VCS; add SVN
[interchange.git] / lib / Vend / UserDB.pm
1 # Vend::UserDB - Interchange user database functions
2 #
3 # Copyright (C) 2002-2017 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                                 or die errmsg("Bad structure in %s: %s", $f, $self->{ERROR});
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         my $err = $@;
2361
2362         scrub();
2363
2364         if ($err) {
2365                 if(defined $self) {
2366                         $self->{ERROR} = $err;
2367                 }
2368                 else {
2369                         logError("Vend::UserDB error: %s\n", $err);
2370                 }
2371                 return undef;
2372         }
2373         
2374         1;
2375 }
2376
2377 sub username_cookies {
2378                 my ($user, $pw, $secure) = @_;
2379                 return unless
2380                          $CGI::values{mv_cookie_password}               or
2381                          $CGI::values{mv_cookie_username}               or
2382                          Vend::Util::read_cookie('MV_PASSWORD') or
2383                          Vend::Util::read_cookie('MV_USERNAME');
2384                 $::Instance->{Cookies} = [] unless defined $::Instance->{Cookies};
2385                 my $exp = time() + $Vend::Cfg->{SaveExpire};
2386                 $secure ||= $CGI::secure;
2387                 push @{$::Instance->{Cookies}},
2388                         ['MV_USERNAME', $user, $exp];
2389                 return unless
2390                         $CGI::values{mv_cookie_password}                or
2391                         Vend::Util::read_cookie('MV_PASSWORD');
2392                 push @{$::Instance->{Cookies}},
2393                         ['MV_PASSWORD', $pw, $exp, undef, undef, $secure];
2394                 return;
2395 }
2396
2397 sub get_cart {
2398         my($self, %options) = @_;
2399
2400         my $from = $self->{NICKNAME};
2401         my $to;
2402
2403         my $opt = $self->{OPTIONS};
2404
2405         if ($opt->{target}) {
2406                 $to = ($::Carts->{$opt->{target}} ||= []);
2407         }
2408         else {
2409                 $to = $Vend::Items;
2410         }
2411
2412 #::logDebug ("to=$to nick=$opt->{target} from=$from cart=" . ::uneval_it($from));
2413
2414         my $field_name = $self->{LOCATION}->{CARTS};
2415         my $cart = [];
2416
2417         eval {
2418                 die errmsg("no from cart name?")                                unless $from;
2419                 die errmsg("%s field not present to get %s", $field_name, $from) . "\n"
2420                                                                                 unless $self->{PRESENT}->{$field_name};
2421
2422                 my $s = $self->{DB}->field( $self->{USERNAME}, $field_name);
2423
2424                 die errmsg("no saved carts.") . "\n" unless $s;
2425
2426                 my @carts = split /\0/, $from;
2427                 my $d = string_to_ref($s);
2428 #::logDebug ("saved carts=" . ::uneval_it($d));
2429
2430                 die errmsg("eval failed?")                              unless ref $d;
2431
2432                 for(@carts) {
2433                         die errmsg("source cart '%s' does not exist.", $from) . "\n" unless ref $d->{$_};
2434                         push @$cart, @{$d->{$_}};
2435                 }
2436
2437         };
2438
2439         if($@) {
2440                 $self->{ERROR} = $@;
2441                 return undef;
2442         }
2443 #::logDebug ("to=$to nick=$opt->{target} from=$from cart=" . ::uneval_it($cart));
2444
2445         if($opt->{merge}) {
2446                 $to = [] unless ref $to;
2447                 my %used;
2448                 my %alias;
2449                 my $max;
2450
2451                 for(@$to) {
2452                         my $master;
2453                         next unless $master = $_->{mv_mi};
2454                         $used{$master} = 1;
2455                         $max = $master if $master > $max;
2456                 }
2457
2458                 $max++;
2459
2460                 my $rename;
2461                 my $alias = 100;
2462                 for(@$cart) {
2463                         my $master;
2464                         next unless $master = $_->{mv_mi};
2465                         next unless $used{$master};
2466
2467                         if(! $_->{mv_si}) {
2468                                 $alias{$master} = $max++;
2469                                 $_->{mv_mi} = $alias{$master};
2470                         }
2471                         else {
2472                                 $_->{mv_mi} = $alias{$master};
2473                         }
2474                 }
2475
2476                 push(@$to,@$cart);
2477
2478         }
2479         else {
2480                 @$to = @$cart;
2481         }
2482 }
2483
2484 sub set_cart {
2485         my($self, %options) = @_;
2486
2487         my $from;
2488         my $to   = $self->{NICKNAME};
2489
2490         my $opt = $self->{OPTIONS};
2491
2492         if ($opt->{source}) {
2493                 $from = $::Carts->{$opt->{source}} || [];
2494         }
2495         else {
2496                 $from = $Vend::Items;
2497         }
2498
2499         my $field_name = $self->{LOCATION}->{CARTS};
2500         my ($cart,$s,$d);
2501
2502         eval {
2503                 die errmsg("no to cart name?") . "\n"                                   unless $to;
2504                 die errmsg('%s field not present to set %s', $field_name, $from) . "\n"
2505                                                                                 unless $self->{PRESENT}->{$field_name};
2506
2507                 $d = string_to_ref( $self->{DB}->field( $self->{USERNAME}, $field_name) );
2508
2509                 $d = {} unless $d;
2510
2511                 die errmsg("eval failed?")                              unless ref $d;
2512
2513                 if($opt->{merge}) {
2514                         $d->{$to} = [] unless ref $d->{$to};
2515                         push(@{$d->{$to}}, @{$from});
2516                 }
2517                 else {
2518                 }
2519
2520                 $d->{$to} = $from;
2521
2522                 $s = uneval $d;
2523
2524         };
2525
2526         if($@) {
2527                 $self->{ERROR} = $@;
2528                 return undef;
2529         }
2530
2531         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
2532
2533 }
2534
2535
2536 =head2 The [userdb ...] tag
2537
2538 Interchange provides a C<[userdb ...]> tag to access the UserDB functions.
2539
2540  [userdb
2541         function=function_name
2542         username="username"
2543         assign_username=1
2544         username_mask=REGEX
2545         password="password"
2546         verify="password"
2547         oldpass="old password"
2548         crypt="1|0"
2549                 bcrypt=1
2550                 promote=1
2551                 md5=1
2552                 md5_salted=1
2553                 sha1=1
2554                 valref=user_record
2555                 scratchref=user_record
2556         shipping="fields for shipping save"
2557         billing="fields for billing save"
2558         preferences="fields for preferences save"
2559         ignore_case="1|0"
2560         force_lower=1
2561         param1=value
2562         param2=value
2563         ...
2564         ]
2565
2566 All parameters are optional except for the function. Normally, parameters 
2567 are set in catalog.cfg with the I<UserDB> directive.
2568
2569 It is normally called in an C<mv_click> or C<mv_check> setting, as in:
2570
2571     [set Login]
2572     mv_todo=return
2573     mv_nextpage=welcome
2574     [userdb function=login]
2575     [/set]
2576
2577     <FORM ACTION="[process-target]" METHOD=POST>
2578     <INPUT TYPE=hidden NAME=mv_click VALUE=Login>
2579     Username <INPUT NAME=mv_username SIZE=10>
2580     Password <INPUT NAME=mv_password SIZE=10>
2581     </FORM>
2582
2583 There are several global parameters that apply to any use of
2584 the C<userdb> functions. Most importantly, by default the database
2585 table is set to be I<userdb>. If you must use another table name,
2586 then you should include a C<database=table> parameter with any
2587 call to C<userdb>. The global parameters (default in parens):
2588
2589     database     Sets user database table (userdb)
2590     show         Show the return value of certain functions
2591                  or the error message, if any (0)
2592     force_lower  Force possibly upper-case database fields
2593                  to lower case session variable names (0)
2594     billing      Set the billing fields (see Accounts)
2595     shipping     Set the shipping fields (see Address Book)
2596     preferences  Set the preferences fields (see Preferences)
2597     bill_field   Set field name for accounts (accounts)
2598     addr_field   Set field name for address book (address_book)
2599     pref_field   Set field name for preferences (preferences)
2600     cart_field   Set field name for cart storage (carts)
2601     pass_field   Set field name for password (password)
2602     time_field   Set field for storing last login time (time)
2603     expire_field Set field for expiration date (expire_date)
2604     acl          Set field for simple access control storage (acl)
2605     file_acl     Set field for file access control storage (file_acl)
2606     db_acl       Set field for database access control storage (db_acl)
2607
2608 By default the system crypt() call will be used to compare the
2609 password. This is minimal security, but at least the passwords in the user
2610 database will not be human readable. For better security, in descending
2611 order of security, use:
2612
2613         bcrypt    Bcrypt, most secure
2614         sha1      SHA1 digest, more secure than MD5
2615         md5       Not so easily stored in cracklib as md5 unsalted
2616         md5       Better security than crypt
2617
2618 If you don't keep actual user information, don't have users creating
2619 accounts and setting the passwords themselvs, and don't do Interchange
2620 administration via the C<UserDB> capability, then you may
2621 wish to use the <UserDB> directive (described below) to set
2622 encryption off by default:
2623
2624     UserDB   default   crypt   0
2625
2626 That will set encryption off by default. You can still set encryption
2627 on by passing C<crypt=1> with any call to a C<new_account>, C<change_pass>,
2628 or C<login> call.
2629
2630 WARNING: Using unencrypted passwords is never recommended if you have users
2631 setting their passwords. They will use the same passwords as other systems,
2632 possibly compromising important information.
2633
2634 =head2 Setting defaults with the UserDB directive
2635
2636 The I<UserDB> directive provides a way to set defaults for
2637 the user database. For example, if you always wanted to save
2638 and recall the scratch variable C<tickets> in the user database
2639 instead of the form variable C<tickets>, you could set:
2640
2641     UserDB   default   scratch  tickets
2642
2643 That makes every call to C<[userdb function=login]> be equivalent
2644 to C<[userdb function=login scratch=tickets]>.
2645
2646 If you wish to override that default for one call only, you can
2647 use C<[userdb function=login scratch="passes"]>.
2648
2649 If you wish to log failed access authorizations, set the C<UserDB>
2650 profile parameter C<log_failed> true:
2651
2652     UserDB  default  log_failed 1
2653
2654 To disable logging of failed access authorizations (the default), set
2655 the C<UserDB> profile parameter C<log_failed> to 0:
2656
2657     UserDB  default  log_failed 0
2658
2659 The I<UserDB> directive uses the same key-value pair settings
2660 as the I<Locale> and I<Route> directives, and you may have more
2661 than one set of defaults. You can set them in a hash structure:
2662
2663     UserDB  case_crypt  scratch     tickets
2664     UserDB  case_crypt  bcrypt      1
2665     UserDB  case_crypt  ignore_case 0
2666
2667     UserDB  default     scratch     tickets
2668     UserDB  default     sha1        1
2669     UserDB  default     ignore_case 1
2670
2671 The last one to be set becomes the default.
2672
2673 The option C<profile> selects the set to use. So if you wanted
2674 usernames and passwords to be case sensitive with bcrypt encryption,
2675 you could pass this call:
2676
2677     [userdb function=new_account profile=case_crypt]
2678
2679 The username and password will be stored as typed in, and the
2680 password will be encrypted in the database.
2681
2682 =head2 User Database functions
2683
2684 The user database features are implemented as a series of functions
2685 attached to the C<userdb> tag. The functions are:
2686
2687 =over 4
2688
2689 =item login
2690
2691 Log in to Interchange. By default, the username is contained in the
2692 form variable C<mv_username> and the password in C<mv_password>.
2693 If the login is successful, the session value C<username>
2694 (C<[data session username]>) will be set to the user name.
2695
2696 This will recall the values of all non-special fields in the user
2697 database and place them in their corresponding user form variables.
2698
2699 =item logout
2700
2701 Log out of Interchange. No additional parameters are needed.
2702
2703 =item new_account
2704
2705 Create a new account. It requires the C<username>, C<password>, and
2706 C<verify> parameters, which are by default contained in the form
2707 variables C<mv_username>, C<mv_password>, C<mv_verify> respectively.
2708
2709 If you set the C<assign_username> parameter, then UserDB will assign
2710 a sequential username. The C<counter> parameter can be used to set
2711 the filename (must be absolute), or you can accept the default of
2712 CATALOG_DIR/etc/username.counter. The first username will be "U0001"
2713 if the counter doesn't exist already.
2714
2715 The C<ignore_case> parameter forces the username and password to
2716 lower case in the database, in effect rendering the username and
2717 password case-insensitive.
2718
2719 If you set C<username_mask> to a valid Perl regular expression (without
2720 the surrounding / /) then any username containing a matching string will
2721 not be allowed for use. For example, to screen out order numbers from
2722 being used by a random user:
2723
2724     [userdb function=new_account
2725             username_mask="^[A-Z]*[0-9]"
2726             ]
2727
2728 The I<CookieLogin> directive (catalog.cfg) allows users to save
2729 their username/password in a cookie. Expiration time is set by
2730 I<SaveExpire>, renewed every time they log in. To cause the cookie to
2731 be generated originally, the form variable C<mv_cookie_password> or
2732 C<mv_cookie_username> must be set in the login form. The former causes
2733 both username and password to be saved, the latter just the username.
2734
2735 If you want to automatically create an account for every order,
2736 you can do in the I<OrderReport> file:
2737
2738     [userdb function=new_account
2739             username="[value mv_order_number]"
2740             password="[value zip]"
2741             verify="[value zip]"
2742             database="orders"
2743             ]
2744
2745 This would be coupled with a login form that asked for order number and
2746 zip code; thereupon allowing you to display the contents of a transaction
2747 database with (presumably updated) order status information or a shipping
2748 company tracking number.
2749
2750 =item change_pass
2751
2752 Change the password on the currently logged-in account. It requires
2753 the C<username>, C<password>, C<verify>, and C<oldpass> parameters,
2754 which are by default contained in the form variables C<mv_username>,
2755 C<mv_password>, C<mv_verify>, C<mv_password_old> respectively.
2756
2757 =item set_shipping
2758
2759 Active parameters: nickname, shipping, ship_field
2760
2761 Place an entry in the shipping Address book. Example:
2762
2763     [userdb function=set_shipping nickname=Dad]
2764
2765 See I<Address Book> below.
2766
2767 =item get_shipping
2768
2769 Active parameters: nickname, shipping, ship_field
2770
2771 Recall an entry from the shipping Address book. Example:
2772
2773     [userdb function=get_shipping nickname=Dad]
2774
2775 See I<Address Book> below.
2776
2777 =item get_shipping_names
2778
2779 Active parameters: ship_field
2780
2781 Gets the names of shipping address book entries and places
2782 them in the variable C<address_book>. By default, it does not return
2783 the values; if you wish them to be returned you can set
2784 the parameter C<show> to 1, as in:
2785
2786     [set name=shipping_nicknames
2787          interpolate=1]
2788       [userdb function=get_shipping_names show=1]
2789     [/set]
2790
2791 =item set_billing
2792
2793 Active parameters: nickname, billing, bill_field
2794
2795 Place an entry in the billing accounts book. Example:
2796
2797     [userdb function=set_billing nickname=discover]
2798
2799 See I<Accounts Book> below.
2800
2801 =item get_billing
2802
2803 Active parameters: nickname, billing, bill_field
2804
2805 Recall an entry from the billing accounts book. Example:
2806
2807     [userdb function=get_billing nickname=visa]
2808
2809 See I<Accounts Book> below.
2810
2811 =item save
2812
2813 Saves all non-special form values that have columns in the user database.
2814
2815 =item load
2816
2817 Performs the transfer of user values to the values space, scratch space, and
2818 constant space. Performed automatically upon login.
2819
2820 If you pass the C<valref> option, that will be used instead of C<$Values> for
2821 the values space. It can either be a real hash reference, or a scalar that
2822 will be a key directly in C<$Vend::Session>. If it contains a colon (C<:>), it
2823 will be a subreference in C<$Vend::Session>. For example:
2824
2825         [userdb function=load valref=`$Session->{user_record} ||= {}`]
2826
2827 Will store the values in C<$Vend::Session->{user_record}>, clearing it first.
2828 The below accomplishes the same thing:
2829
2830         [userdb function=load valref=user_record]
2831
2832 If you want to place it a couple of levels down, do:
2833
2834         [userdb function=load valref=`$Session->{values_repository}{userdb} ||= {}`]
2835
2836 or
2837
2838         [userdb function=load valref="values_repository:userdb"]
2839
2840 To clear the record instead of add to the existing values, add an
2841 asterisk at the end:
2842
2843         [userdb function=load valref="values_repository:userdb*"]
2844
2845 Which is equivalent to:
2846
2847         [userdb function=load valref=`$Session->{values_repository}{userdb} = {}`]
2848
2849 The C<scratchref> option is the same as C<valref>, but for the scratch values
2850 passed with C<UserDB scratch>.
2851
2852 =item set_cart
2853
2854 Save the contents of a shopping cart.
2855
2856     [userdb function=set_cart nickname=christmas]
2857
2858 See I<Carts> below.
2859
2860 =item get_cart
2861
2862 Active parameters: nickname, carts_field, target
2863
2864 Recall a saved shopping cart. 
2865
2866     [userdb function=get_cart nickname=mom_birthday]
2867
2868 Setting C<target> saves to a different shopping cart than the
2869 default main cart. The C<carts_field> controls the database
2870 field used for storage.
2871
2872 =item set_acl
2873
2874 Active parameters: location, acl_field, delete
2875
2876 Set a simple acl. Example:
2877
2878     [userdb function=set_acl location=cartcfg/editcart]
2879
2880 This allows the current user to access the page "cartcfg/editcart" if 
2881 it is access-protected.
2882
2883 To delete access, do:
2884
2885     [userdb function=set_acl location=cartcfg/editcart delete=1]
2886
2887 To display the setting at the same time as setting use the
2888 C<show> attribute:
2889
2890     [userdb function=set_acl location=cartcf/editcart show=1]
2891
2892 =item check_acl
2893
2894 Active parameters: location, acl_field
2895
2896 Checks the simple access control listing for a location, returning
2897 1 if allowed and the empty string if not allowed.
2898
2899     [if type=explicit
2900         compare="[userdb
2901                     function=check_acl
2902                     location=cartcfg/editcart]"
2903     ]
2904     [page cartcfg/editcart]Edit your cart configuration[/page]
2905     [/if]
2906
2907 =item set_file_acl, set_db_acl
2908
2909 Active parameters: location, mode, db_acl_field, file_acl_field, delete
2910
2911 Sets a complex access control value. Takes the form:
2912
2913     [userdb function=set_file_acl
2914             mode=rw
2915             location=products/inventory.txt]
2916
2917 where mode is any value you wish to check for with check_file_acl. As
2918 with the simple ACL, you can use delete=1 to delete the location entirely.
2919
2920 =item check_file_acl, check_db_acl
2921
2922 Active parameters: location, mode, db_acl_field, file_acl_field
2923
2924 Checks a complex access control value and returns a true/false (1/0)
2925 value. Takes the form:
2926
2927     [userdb function=check_db_acl
2928             mode=w
2929             location=inventory]
2930
2931 where mode is any value you wish to check for with check_file_acl. It
2932 will return true if the mode string is contained within the entry
2933 for that location. Example:
2934
2935     [if type=explicit
2936         compare="[userdb
2937                     function=check_db_acl
2938                     mode=w
2939                     location=inventory]"
2940     ]
2941     [userdb function=set_acl location=cartcfg/edit_inventory]
2942     [page cartcfg/edit_inventory]You may edit the inventory database[/page]
2943     [else]
2944     [userdb function=set_acl location=cartcfg/edit_inventory delete=1]
2945     Sorry, you can't edit inventory.
2946     [/if]
2947
2948 =back
2949
2950 =cut
2951
2952 sub userdb {
2953         my $function = shift;
2954         my $opt = shift;
2955
2956         my %options;
2957
2958         if(ref $opt) {
2959                 %options = %$opt;
2960         }
2961         else {
2962                 %options = ($opt, @_);
2963         }
2964
2965         my $status = 1;
2966         my $user;
2967
2968         my $module = $Vend::Cfg->{UserControl} ? 'Vend::UserControl' : 'Vend::UserDB';
2969
2970         if($function eq 'login') {
2971                 $Vend::Session->{logged_in} = 0;
2972                 delete $Vend::Session->{username};
2973                 delete $Vend::Session->{groups};
2974                 undef $Vend::username;
2975                 undef $Vend::groups;
2976                 undef $Vend::admin;
2977                 $user = $module->new(%options);
2978                 unless (defined $user) {
2979                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2980                         return undef;
2981                 }
2982                 if ($status = $user->login(%options) ) {
2983                         ::update_user();
2984                 }
2985         }
2986         elsif($function eq 'new_account') {
2987                 $user = $module->new(%options);
2988                 unless (defined $user) {
2989                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2990                         return undef;
2991                 }
2992                 $status = $user->new_account(%options);
2993                 if($status and ! $options{no_login}) {
2994                         $Vend::Session->{logged_in} = 1;
2995                         $Vend::Session->{username} = $user->{USERNAME};
2996                 }
2997         }
2998         elsif($function eq 'logout') {
2999                 $user = $module->new(%options)
3000                         or do {
3001                                 $Vend::Session->{failure} = errmsg("Unable to create user object.");
3002                                 return undef;
3003                         };
3004                 $user->logout();
3005         }
3006         elsif (! $Vend::Session->{logged_in}) {
3007                 $Vend::Session->{failure} = errmsg("Not logged in.");
3008                 return undef;
3009         }
3010         elsif($function eq 'save') {
3011                 $user = $module->new(%options);
3012                 unless (defined $user) {
3013                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
3014                         return undef;
3015                 }
3016                 $status = $user->set_values();
3017         }
3018         elsif($function eq 'load') {
3019                 $user = $module->new(%options);
3020                 unless (defined $user) {
3021                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
3022                         return undef;
3023                 }
3024                 $status = $user->get_values($opt->{valref}, $opt->{scratchref});
3025         }
3026         else {
3027                 $user = $module->new(%options);
3028                 unless (defined $user) {
3029                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
3030                         return undef;
3031                 }
3032                 eval {
3033                         $status = $user->$function(%options);
3034                 };
3035                 $user->{ERROR} = $@ if $@;
3036         }
3037         
3038         if(defined $status) {
3039                 delete $Vend::Session->{failure};
3040                 $Vend::Session->{success} = $user->{MESSAGE};
3041                 if($options{show_message}) {
3042                         $status = $user->{MESSAGE};
3043                 }
3044         }
3045         else {
3046                 $Vend::Session->{failure} = $user->{ERROR};
3047                 if($options{show_message}) {
3048                         $status = $user->{ERROR};
3049                 }
3050         }
3051         return $status unless $options{hide};
3052         return;
3053 }
3054
3055 sub do_crypt {
3056         my ($self, $password, $salt) = @_;
3057         my $sub = $self->{ENCSUB};
3058         unless ($sub) {
3059                 for (grep { $self->{OPTIONS}{$_} } keys %enc_subs) {
3060                         $sub = $enc_subs{$_};
3061                         last;
3062                 }
3063                 $self->{ENCSUB} = $sub ||= $enc_subs{default};
3064         }
3065         return $sub->($self, $password, $salt);
3066 }
3067
3068 1;