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