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__