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