Add payment module for MerchantWare 4.0 gateway, from Merchant
[interchange.git] / lib / Vend / File.pm
1 # Vend::File - Interchange file functions
2 #
3 # Copyright (C) 2002-2009 Interchange Development Group
4 # Copyright (C) 1996-2002 Red Hat, Inc.
5 #
6 # This program was originally based on Vend 0.2 and 0.3
7 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
8 #
9 # This program is free software; you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 2 of the License, or
12 # (at your option) any later version.
13 #
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 # GNU General Public License for more details.
18 #
19 # You should have received a copy of the GNU General Public
20 # License along with this program; if not, write to the Free
21 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
22 # MA  02110-1301  USA.
23
24 package Vend::File;
25 require Exporter;
26
27 @ISA = qw(Exporter);
28
29 @EXPORT = qw(
30         absolute_or_relative
31         allowed_file
32         catfile
33         exists_filename
34         file_allow
35         file_modification_time
36         file_name_is_absolute
37         get_filename
38         lockfile
39         log_file_violation
40         readfile
41         readfile_db
42         set_lock_type
43         unlockfile
44         writefile
45 );
46
47 use strict;
48 use Config;
49 use Fcntl;
50 use Errno;
51
52 my $PERLQQ = 0x0100; # from Encode(3perl)
53
54 unless( $ENV{MINIVEND_DISABLE_UTF8} ) {
55         require Encode;
56         import Encode qw( is_utf8 );
57         $PERLQQ = Encode::PERLQQ();
58 }
59
60 use Vend::Util;
61 use File::Path;
62 use File::Copy;
63 use subs qw(logError logGlobal);
64 use vars qw($VERSION @EXPORT @EXPORT_OK $errstr);
65 $VERSION = '2.33';
66
67 sub writefile {
68     my($file, $data, $opt) = @_;
69         my($encoding, $fallback);
70
71         if ($::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8}) {
72                 $encoding = $opt->{encoding} ||= 'utf-8';
73                 undef $encoding if $encoding eq 'raw';
74                 $fallback = $opt->{fallback};
75                 $fallback = $PERLQQ unless defined $fallback;
76         }
77
78         $file = ">>$file" unless $file =~ /^[|>]/;
79         if (ref $opt and $opt->{umask}) {
80                 $opt->{umask} = umask oct($opt->{umask});
81         }
82     eval {
83                 unless($file =~ s/^[|]\s*//) {
84                         if (ref $opt and $opt->{auto_create_dir}) {
85                                 my $dir = $file;
86                                 $dir =~ s/>+//;
87
88                                 ## Need to make this OS-independent, requires File::Spec support
89                                 $dir =~ s:[\r\n]::g;   # Just in case
90                                 $dir =~ s:(.*)/.*:$1: or $dir = '';
91                                 if($dir and ! -d $dir) {
92                                         eval{
93                                                 File::Path::mkpath($dir);
94                                         };
95                                         die "mkpath\n" unless -d $dir;
96                                 }
97                         }
98                         # We have checked for beginning > or | previously
99                         open(MVLOGDATA, $file) or die "open\n";
100             if ($encoding) {
101                 local $PerlIO::encoding::fallback = $fallback;
102                 binmode(MVLOGDATA, ":encoding($encoding)");
103             }
104
105                         lockfile(\*MVLOGDATA, 1, 1) or die "lock\n";
106                         seek(MVLOGDATA, 0, 2) or die "seek\n";
107                         if(ref $data) {
108                                 print(MVLOGDATA $$data) or die "write to\n";
109                         }
110                         else {
111                                 print(MVLOGDATA $data) or die "write to\n";
112                         }
113                         unlockfile(\*MVLOGDATA) or die "unlock\n";
114                 }
115                 else {
116             my (@args) = grep /\S/, Text::ParseWords::shellwords($file);
117                         open(MVLOGDATA, "|-") || exec @args;
118             if ($encoding) {
119                 local $PerlIO::encoding::fallback = $fallback;
120                 binmode(MVLOGDATA, ":encoding($encoding)");
121             }
122                         if(ref $data) {
123                                 print(MVLOGDATA $$data) or die "pipe to\n";
124                         }
125                         else {
126                                 print(MVLOGDATA $data) or die "pipe to\n";
127                         }
128                 }
129                 close(MVLOGDATA) or die "close\n";
130     };
131
132         my $status = 1;
133     if ($@) {
134                 ::logError ("Could not %s file '%s': %s\nto write this data:\n%s",
135                                 $@,
136                                 $file,
137                                 $!,
138                                 substr(ref($data) ? $$data : $data,0,120),
139                                 );
140                 $status = 0;
141     }
142
143     if (ref $opt and defined $opt->{umask}) {                                        
144         $opt->{umask} = umask oct($opt->{umask});                                    
145     }
146
147         return $status;
148 }
149
150 sub file_modification_time {
151     my ($fn, $tolerate) = @_;
152     my @s = stat($fn) or ($tolerate and return 0) or die "Can't stat '$fn': $!\n";
153     return $s[9];
154 }
155
156 sub readfile_db {
157         my ($name) = @_;
158         return unless $Vend::Cfg->{FileDatabase};
159         my ($tab, $col) = split /:+/, $Vend::Cfg->{FileDatabase};
160         my $db = $Vend::Interpolate::Db{$tab} || ::database_exists_ref($tab)
161                 or return undef;
162 #::logDebug("tab=$tab exists, db=$db");
163
164         # I guess this is the best test
165         if($col) {
166                 return undef unless $db->column_exists($col);
167         }
168         elsif ( $col = $Global::Variable->{LANG} and $db->column_exists($col) ) {
169                 #do nothing
170         }
171         else {
172                 $col = 'default';
173                 return undef unless $db->column_exists($col);
174         }
175
176 #::logDebug("col=$col exists, db=$db");
177         return undef unless $db->record_exists($name);
178 #::logDebug("ifile=$name exists, db=$db");
179         return $db->field($name, $col);
180 }
181
182 # Reads in an arbitrary file.  Returns the entire contents,
183 # or undef if the file could not be read.
184 # Careful, needs the full path, or will be read relative to
185 # VendRoot..and will return binary. Should be tested by
186 # the user.
187 #
188 # To ensure security in multiple catalog setups, leading /
189 # is not allowed if $Global::NoAbsolute) is true and the file
190 # is not part of the TemplateDir, VendRoot, or is owned by the
191 # defined CatalogUser.
192
193 # If catalog FileDatabase is enabled and there are no contents, we can retrieve
194 # the file from the database.
195
196 sub readfile {
197     my($ifile, $no, $loc, $opt) = @_;
198     my($contents,$encoding,$fallback);
199     local($/);
200
201         $opt ||= {};
202         
203         if ($::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8}) {
204                 $encoding = $opt->{encoding} ||= 'utf-8';
205                 $fallback = $opt->{fallback};
206                 $fallback = $PERLQQ unless defined $fallback;
207                 undef $encoding if $encoding eq 'raw';
208         }
209         
210         unless(allowed_file($ifile)) {
211                 log_file_violation($ifile);
212                 return undef;
213         }
214
215         my $file;
216
217         if (file_name_is_absolute($ifile) and -f $ifile) {
218                 $file = $ifile;
219         }
220         else {
221                 for (".", @{$Vend::Cfg->{TemplateDir} || []}, @{$Global::TemplateDir || []}) {
222                         my $candidate = "$_/$ifile";
223                         log_file_violation($candidate), next if ! allowed_file($candidate);
224                         next if ! -f $candidate;
225                         $file = $candidate;
226                         last;
227                 }
228         }
229
230         if(! $file) {
231
232                 $contents = readfile_db($ifile);
233                 return undef unless defined $contents;
234         }
235         else {
236                 return undef unless open(READIN, "< $file");
237                 $Global::Variable->{MV_FILE} = $file;
238
239                 binmode(READIN) if $Global::Windows;
240
241         if ($encoding) {
242             local $PerlIO::encoding::fallback = $PERLQQ;
243             binmode(READIN, ":encoding($encoding)");
244         }
245
246                 undef $/;
247                 $contents = <READIN>;
248                 close(READIN);
249 #::logDebug("done reading contents");
250
251         # at this point, $contents should be either raw if encoding is
252         # not specified or PerlUnicode.
253         }
254
255         if (
256                 $Vend::Cfg->{Locale}
257                         and
258                 (defined $loc ? $loc : $Vend::Cfg->{Locale}->{readfile} )
259                 )
260         {
261                 Vend::Util::parse_locale(\$contents);
262         }
263     return $contents;
264 }
265
266 ### flock locking
267
268 # sys/file.h:
269 my $flock_LOCK_SH = 1;          # Shared lock
270 my $flock_LOCK_EX = 2;          # Exclusive lock
271 my $flock_LOCK_NB = 4;          # Don't block when locking
272 my $flock_LOCK_UN = 8;          # Unlock
273
274 sub flock_lock {
275     my ($fh, $excl, $wait) = @_;
276     my $flag = $excl ? $flock_LOCK_EX : $flock_LOCK_SH;
277
278     if ($wait) {
279         my $trylimit = $::Limit->{file_lock_retries} || 5;
280         my $failedcount = 0;
281         while (
282                 ! flock($fh, $flag)
283                     and
284                 $failedcount < $trylimit
285                )
286         {
287            $failedcount++;
288            select(undef,undef,undef,0.05 * $failedcount);
289         }
290         die "Could not lock file after $trylimit tries: $!\n" if ($failedcount == $trylimit);
291         return 1;
292     }
293     else {
294         if (! flock($fh, $flag | $flock_LOCK_NB)) {
295             if ($!{EAGAIN} or $!{EWOULDBLOCK}) {
296                                 return 0;
297             }
298             else {
299                 die "Could not lock file: $!\n";
300             }
301         }
302         return 1;
303     }
304 }
305
306 sub flock_unlock {
307     my ($fh) = @_;
308     flock($fh, $flock_LOCK_UN) or die "Could not unlock file: $!\n";
309 }
310
311 sub fcntl_lock {
312     my ($fh, $excl, $wait) = @_;
313     my $flag = $excl ? F_WRLCK : F_RDLCK;
314     my $op = $wait ? F_SETLKW : F_SETLK;
315
316         my $struct = pack('sslli', $flag, 0, 0, 0, $$);
317
318     if ($wait) {
319         fcntl($fh, $op, $struct) or die "Could not fcntl_lock file: $!\n";
320         return 1;
321     }
322     else {
323         if (fcntl($fh, $op, $struct) < 0) {
324             if ($!{EAGAIN} or $!{EWOULDBLOCK}) {
325                 return 0;
326             }
327             else {
328                 die "Could not fcntl_lock file: $!\n";
329             }
330         }
331         return 1;
332     }
333 }
334
335 sub fcntl_unlock {
336     my ($fh) = @_;
337         my $struct = pack('sslli', F_UNLCK, 0, 0, 0, $$);
338         if (fcntl($fh, F_SETLK, $struct) < 0) {
339                 if ($!{EAGAIN} or $!{EWOULDBLOCK}) {
340                         return 0;
341                 }
342                 else {
343                         die "Could not un-fcntl_lock file: $!\n";
344                 }
345         }
346         return 1;
347 }
348
349 my $lock_function = \&flock_lock;
350 my $unlock_function = \&flock_unlock;
351
352 sub set_lock_type {
353         if ($Global::LockType eq 'none') {
354                 ::logDebug("using NO locking");
355                 $lock_function = sub {1};
356                 $unlock_function = sub {1};
357         }
358         elsif ($Global::LockType =~ /fcntl/i) {
359                 ::logDebug("using fcntl(2) locking");
360                 $lock_function = \&fcntl_lock;
361                 $unlock_function = \&fcntl_unlock;
362         }
363         else {
364                 $lock_function = \&flock_lock;
365                 $unlock_function = \&flock_unlock;
366         }
367         return; # VOID
368 }
369  
370 sub lockfile {
371     &$lock_function(@_);
372 }
373
374 sub unlockfile {
375     &$unlock_function(@_);
376 }
377
378 ### Still necessary, sad to say.....
379 if($Global::Windows) {
380         set_lock_type('none');
381 }
382 elsif($^O =~ /hpux/) {
383         set_lock_type('fcntl');
384 }
385
386 # Return a quasi-hashed directory/file combo, creating if necessary
387 sub exists_filename {
388     my ($file,$levels,$chars, $dir) = @_;
389         my $i;
390         $levels = 1 unless defined $levels;
391         $chars = 1 unless defined $chars;
392         $dir = $Vend::Cfg->{ScratchDir} unless $dir;
393     for($i = 0; $i < $levels; $i++) {
394                 $dir .= "/";
395                 $dir .= substr($file, $i * $chars, $chars);
396                 return 0 unless -d $dir;
397         }
398         return -f "$dir/$file" ? 1 : 0;
399 }
400
401 # Return a quasi-hashed directory/file combo, creating if necessary
402 sub get_filename {
403     my ($file,$levels,$chars, $dir) = @_;
404         my $i;
405         $levels = 1 unless defined $levels;
406         $chars = 1 unless defined $chars;
407
408         # Accomodate PermanentDir not existing in pre-5.3.1 catalogs
409         # Block is better than always doing -d test
410         if(! $dir) {
411                 $dir = $Vend::Cfg->{ScratchDir};
412         }
413         else {
414                 mkdir $dir, 0777 unless -d $dir;
415         }
416
417     for($i = 0; $i < $levels; $i++) {
418                 $dir .= "/";
419                 $dir .= substr($file, $i * $chars, $chars);
420                 mkdir $dir, 0777 unless -d $dir;
421         }
422     die "Couldn't make directory $dir (or parents): $!\n"
423                 unless -d $dir;
424     return "$dir/$file";
425 }
426
427 # These were stolen from File::Spec
428 # Can't use that because it INSISTS on object
429 # calls without returning a blessed object
430
431 my $abspat = $^O =~ /win32/i ? qr{^([a-zA-Z]:)?[\\/]} : qr{^/};
432 my $relpat = qr{\.\.[\\/]};
433
434 sub file_name_is_absolute {
435     my($file) = @_;
436     $file =~ $abspat;
437 }
438
439 sub absolute_or_relative {
440     my($file) = @_;
441     $file =~ $abspat or $file =~ $relpat;
442 }
443
444 sub make_absolute_file {
445         my ($path, $global) = @_;
446         # empty string stays empty
447         return unless length($path);
448         # is file already an absolute path?
449         return $path if $path =~ $abspat;
450         # use global or catalog root?
451         my $prefix = ($global ? $Global::VendRoot : $Vend::Cfg->{VendRoot});
452         return catfile($prefix, $path);
453 }
454
455 sub win_catfile {
456     my $file = pop @_;
457     return $file unless @_;
458     my $dir = catdir(@_);
459     $dir =~ s/(\\\.)$//;
460     $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\";
461     return $dir.$file;
462 }
463
464 sub unix_catfile {
465     my $file = pop @_;
466     return $file unless @_;
467     my $dir = catdir(@_);
468     for ($dir) {
469         $_ .= "/" unless substr($_,length($_)-1,1) eq "/";
470     }
471     return $dir.$file;
472 }
473
474 sub unix_path {
475     my $path_sep = ":";
476     my $path = $ENV{PATH};
477     my @path = split $path_sep, $path;
478     foreach(@path) { $_ = '.' if $_ eq '' }
479     @path;
480 }
481
482 sub win_path {
483     local $^W = 1;
484     my $path = $ENV{PATH} || $ENV{Path} || $ENV{'path'};
485     my @path = split(';',$path);
486     foreach(@path) { $_ = '.' if $_ eq '' }
487     @path;
488 }
489
490 sub win_catdir {
491     my @args = @_;
492     for (@args) {
493         # append a slash to each argument unless it has one there
494         $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\";
495     }
496     my $result = canonpath(join('', @args));
497     $result;
498 }
499
500 sub win_canonpath {
501     my($path) = @_;
502     $path =~ s/^([a-z]:)/\u$1/;
503     $path =~ s|/|\\|g;
504     $path =~ s|\\+|\\|g ;                          # xx////xx  -> xx/xx
505     $path =~ s|(\\\.)+\\|\\|g ;                    # xx/././xx -> xx/xx
506     $path =~ s|^(\.\\)+|| unless $path eq ".\\";   # ./xx      -> xx
507     $path =~ s|\\$|| 
508              unless $path =~ m#^([a-z]:)?\\#;      # xx/       -> xx
509     $path .= '.' if $path =~ m#\\$#;
510     $path;
511 }
512
513 sub unix_canonpath {
514     my($path) = @_;
515     $path =~ s|/+|/|g ;                            # xx////xx  -> xx/xx
516     $path =~ s|(/\.)+/|/|g ;                       # xx/././xx -> xx/xx
517     $path =~ s|^(\./)+|| unless $path eq "./";     # ./xx      -> xx
518     $path =~ s|/$|| unless $path eq "/";           # xx/       -> xx
519     $path;
520 }
521
522 sub unix_catdir {
523     my @args = @_;
524     for (@args) {
525         # append a slash to each argument unless it has one there
526         $_ .= "/" if $_ eq '' or substr($_,-1) ne "/";
527     }
528     my $result = join('', @args);
529     # remove a trailing slash unless we are root
530     substr($result,-1) = ""
531         if length($result) > 1 && substr($result,-1) eq "/";
532     $result;
533 }
534
535 my $catdir_routine;
536 my $canonpath_routine;
537 my $catfile_routine;
538 my $path_routine;
539
540 if($^O =~ /win32/i) {
541         $catdir_routine = \&win_catdir;
542         $catfile_routine = \&win_catfile;
543         $path_routine = \&win_path;
544         $canonpath_routine = \&win_canonpath;
545 }
546 else {
547         $catdir_routine = \&unix_catdir;
548         $catfile_routine = \&unix_catfile;
549         $path_routine = \&unix_path;
550         $canonpath_routine = \&unix_canonpath;
551 }
552
553 sub path {
554         return &{$path_routine}(@_);
555 }
556
557 sub catfile {
558         return &{$catfile_routine}(@_);
559 }
560
561 sub catdir {
562         return &{$catdir_routine}(@_);
563 }
564
565 sub canonpath {
566         return &{$canonpath_routine}(@_);
567 }
568
569 #print "catfile a b c --> " . catfile('a', 'b', 'c') . "\n";
570 #print "catdir a b c --> " . catdir('a', 'b', 'c') . "\n";
571 #print "canonpath a/b//../../c --> " . canonpath('a/b/../../c') . "\n";
572 #print "file_name_is_absolute a/b/c --> " . file_name_is_absolute('a/b/c') . "\n";
573 #print "file_name_is_absolute a:b/c --> " . file_name_is_absolute('a:b/c') . "\n";
574 #print "file_name_is_absolute /a/b/c --> " . file_name_is_absolute('/a/b/c') . "\n";
575
576 my %intrinsic = (
577         ic_super => sub { return 1 if $Vend::superuser; },
578         ic_admin => sub { return 1 if $Vend::admin; },
579         ic_logged => sub {
580                                         my ($fn, $checkpath, $write, $sub) = @_;
581                                         return 0 unless $Vend::username;
582                                         return 0 unless $Vend::Session->{logged_in};
583                                         return 0 if $sub and $Vend::login_table ne $sub;
584                                         return 1;
585                                         },
586         ic_session => sub {
587                                         my ($fn, $checkpath, $write, $sub, $compare) = @_;
588                                         my $false = $sub =~ s/^!\s*//;
589                                         my $status      = length($compare)
590                                                                 ? ($Vend::Session->{$sub} eq $compare)
591                                                                 : ($Vend::Session->{$sub});
592                                         return ! $false if $status;
593                                         return $false;
594                                         },
595         ic_scratch => sub {
596                                         my ($fn, $checkpath, $write, $sub, $compare) = @_;
597                                         my $false = $sub =~ s/^!\s*//;
598                                         my $status      = defined $compare && length($compare)
599                                                                 ? ($::Scratch->{$sub} eq $compare)
600                                                                 : ($::Scratch->{$sub});
601                                         return ! $false if $status;
602                                         return $false;
603                                         },
604         ic_userdb => sub {
605                 my ($fn, $checkpath, $write, $profile, $sub, $mode) = @_;
606                 return 0 unless $Vend::username;
607                 return 0 unless $Vend::Session->{logged_in};
608                 $profile ||= 'default';
609                 $sub     ||= 'file_acl';
610                 my $u = new Vend::UserDB profile => $profile;
611                 $mode ||= $write ? 'w' : 'r';
612                 my $func = "check_$sub";
613                 my %o = ( 
614                         location => $fn,
615                         mode => $mode,
616                 );
617                 return undef unless $u->can($func);
618                 my $status = $u->$func( %o );
619                 unless(defined $status) {
620                         $o{location} = $checkpath;
621                         $status = $u->$func( %o );
622                 }
623 #::logDebug("status=$status back from userdb: " . ::uneval(\%o));
624                 return $status;
625         },
626 );
627
628 sub _intrinsic {
629         my ($thing, $fn, $checkpath, $write) = @_;
630         $thing =~ s/^\s+//;
631         $thing =~ s/\s+$//;
632         my @checks = split /\s*;\s*/, $thing;
633         my $status = 1;
634         for(@checks) {
635                 my ($check, @args) = split /:/, $_;
636                 my $sub = $intrinsic{$check}
637                         or do {
638                                 ## $errstr is package global
639                                 $errstr = ::errmsg("Bad intrinsic check '%s', denying.", $_);
640                                 return undef;
641                         };
642                 unless( $sub->($fn, $checkpath, $write, @args) ) {
643                         ## $errstr is package global
644                         $errstr = ::errmsg(
645                                                 "Failed intrinsic check '%s'%s for %s, denying.",
646                                                 $_,
647                                                 $write ? " (write)" : '',
648                                                 $fn,
649                                                 );
650                         $status = 0;
651                         last;
652                 }
653         }
654         return $status;
655 }
656
657 sub check_user_write {
658         my $fn = shift;
659         my $un = $Global::CatalogUser->{$Vend::Cat}
660                 or return undef;
661         my ($mode,$own, $grown) = (stat($fn))[2,4,5];
662         return 0 unless defined $own;
663         my $uid = getpwnam($un);
664         return 1 if $uid eq $own and $mode & 0200;
665         return 0 unless $mode & 020;
666         my @members = split /\s+/, (getgrgid($grown))[3];
667         for(@members) {
668                 return 1 if $un eq $_;
669         }
670         return 0;
671 }
672
673 sub check_user_read {
674         my $fn = shift;
675         my $un = $Global::CatalogUser->{$Vend::Cat}
676                 or return undef;
677         my ($mode,$own, $grown) = (stat($fn))[2,4,5];
678         return 0 unless defined $own;
679         my $uid = getpwnam($un);
680         return 1 if $uid eq $own and $mode & 0400;
681         return 0 unless $mode & 040;
682         my @members = split /\s+/, (getgrgid($grown))[3];
683         for(@members) {
684                 return 1 if $un eq $_;
685         }
686         return 0;
687 }
688
689 sub file_control {
690         my ($fn, $write, $global, @caller) = @_;
691         return 1 if $Vend::superuser and ! $global;
692         my $subref = $global ? $Global::FileControl : $Vend::Cfg->{FileControl};
693         my $f = $fn;
694         CHECKPATH: {
695                 do {
696                         if(ref($subref->{$f}) eq 'CODE') {
697                                 return $subref->{$f}->($fn, $f, $write, @caller);
698                         }
699                         elsif ($subref->{$f}) {
700                                 return _intrinsic($subref->{$f}, $fn, $f, $write);
701                         }
702                 } while $f =~ s{/[^/]*$}{};
703         }
704         return 1;
705 }
706
707 sub allowed_file {
708         my $fn = shift;
709         my $write = shift;
710         my $status = 1;
711         $Vend::File::errstr = '';
712         if(     $Global::NoAbsolute
713                         and
714                 $fn !~ $Global::AllowedFileRegex->{$Vend::Cat}
715                         and
716                 absolute_or_relative($fn)
717                 )
718         {
719                 if($Vend::admin and ! $write and $fn =~ /^$Global::RunDir/ and $fn !~ $relpat) {
720                         $status = 1;
721                 }
722                 else {
723                         $status = $write ? check_user_write($fn) : check_user_read($fn);
724                 }
725         }
726         if($status and $Global::FileControl) {
727                 $status &= file_control($fn, $write, 1, caller(0))
728                         or $Vend::File::errstr ||=
729                                                         ::errmsg(
730                                                                  "Denied %s access to %s by global FileControl.",
731                                                                  $write ? 'write' : 'read',
732                                                                  $fn,
733                                                          );
734         }
735         if($status and $Vend::Cfg->{FileControl}) {
736                 $status &= file_control($fn, $write, 0, caller(0))
737                   or $Vend::File::errstr ||=
738                                                         ::errmsg(
739                                                                  "Denied %s access to %s by catalog FileControl.",
740                                                                  $write ? 'write' : 'read',
741                                                                  $fn,
742                                                          );
743         }
744         
745 #::logDebug("allowed_file check for $fn: $status");
746         return $status;
747 }
748
749 sub log_file_violation {
750         my ($file, $action) = @_;
751         my $msg;
752
753         unless ($msg = $Vend::File::errstr) {
754                 if ($action) {
755                         $msg = ::errmsg ("%s: Can't use file '%s' with NoAbsolute set",
756                                                          $action, $file);
757                 } else {
758                         $msg = ::errmsg ("Can't use file '%s' with NoAbsolute set",
759                                                          $file);
760                 }
761         }
762
763         ::logError($msg);
764         ::logGlobal({ level => 'warning' }, $msg);
765 }
766
767 1;
768 __END__