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