[interchange-cvs] interchange - heins modified 11 files
interchange-core@icdevgroup.org
interchange-core@icdevgroup.org
Mon Mar 31 23:13:00 2003
User: heins
Date: 2003-04-01 04:12:32 GMT
Modified: scripts interchange.PL
Modified: lib/Vend Config.pm Data.pm Dispatch.pm Glimpse.pm
Modified: Interpolate.pm Order.pm Page.pm Scan.pm Util.pm
Added: lib/Vend File.pm
Log:
* Add new Vend::File module with minimal functions.
* Relocate following routines (and their subsidiaries) from Vend::Util:
canonpath
catdir
catfile
exists_filename
file_modification_time
file_name_is_absolute
get_filename
lockfile
path
readfile
readfile_db
set_lock_type
unlockfile
writefile
Added stubs so that package-based calls to those routines will not
break software.
* Added CatalogUser directive that allows setting in interchange.cfg
of allowed username that is used for access to absolute-path names.
CatalogUser foundation joe
CatalogUser reports jane
This sets the user for allowed_file() for further read/write checks
based on username.
* Created allowed_file() routine and replaced all current inline checks
for NoAbsolute with call to that routine. It behaves as:
NoAbsolute is No: all files are accessible, always
Allowed for read/write:
Path name is relative with no ..
Path name is absolute but in the catalog directory
Path name is absolute but in a TemplateDir
Allowed for read:
CatalogUser set to a valid username and file is readable by that user
CatalogUser set to a valid username and file is readable by a group
containing that user
Allowed for write:
CatalogUser set to a valid username and file is writable by that user
CatalogUser set to a valid username and file is writable by a group
containing that user
* Changed display_special_page so that special page entries with ../
will not break things.
* TODO:
-- Code read for open() calls.
-- Code read for chmod() calls.
-- Code read for unlink() calls.
* Passes all regression tests; takes an order on foundation; runs UI including
file navigator.
Revision Changes Path
2.68 +2 -1 interchange/scripts/interchange.PL
rev 2.68, prev_rev 2.67
Index: interchange.PL
===================================================================
RCS file: /var/cvs/interchange/scripts/interchange.PL,v
retrieving revision 2.67
retrieving revision 2.68
diff -u -r2.67 -r2.68
--- interchange.PL 2 Feb 2003 21:04:23 -0000 2.67
+++ interchange.PL 1 Apr 2003 04:12:31 -0000 2.68
@@ -3,7 +3,7 @@
#
# Interchange version 4.9.7
#
-# $Id: interchange.PL,v 2.67 2003/02/02 21:04:23 racke Exp $
+# $Id: interchange.PL,v 2.68 2003/04/01 04:12:31 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. and others.
# http://www.icdevgroup.org/
@@ -223,6 +223,7 @@
use Vend::Util;
+use Vend::File;
use Vend::Server;
use Vend::Session;
use Vend::Config;
2.103 +13 -2 interchange/lib/Vend/Config.pm
rev 2.103, prev_rev 2.102
Index: Config.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Config.pm,v
retrieving revision 2.102
retrieving revision 2.103
diff -u -r2.102 -r2.103
--- Config.pm 31 Mar 2003 20:32:55 -0000 2.102
+++ Config.pm 1 Apr 2003 04:12:32 -0000 2.103
@@ -1,6 +1,6 @@
# Vend::Config - Configure Interchange
#
-# $Id: Config.pm,v 2.102 2003/03/31 20:32:55 ramoore Exp $
+# $Id: Config.pm,v 2.103 2003/04/01 04:12:32 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
# Copyright (C) 2003 ICDEVGROUP <interchange@icdevgroup.org>
@@ -44,9 +44,10 @@
use Fcntl;
use Vend::Parse;
use Vend::Util;
+use Vend::File;
use Vend::Data;
-$VERSION = substr(q$Revision: 2.102 $, 10);
+$VERSION = substr(q$Revision: 2.103 $, 10);
my %CDname;
@@ -212,6 +213,7 @@
['RunDir', 'root_dir', $Global::RunDir || 'etc'],
['DebugFile', undef, ''],
+ ['CatalogUser', 'hash', ''],
['ConfigDir', undef, 'etc/lib'],
['ConfigDatabase', 'config_db', ''],
['ConfigParseComments', 'yesno', 'Yes'],
@@ -2379,6 +2381,15 @@
return 1;
},
ProductFiles => \&set_default_search,
+ VendRoot => sub {
+ my @paths = map { quotemeta $_ }
+ $C->{VendRoot},
+ @{$C->{TemplateDir} || []},
+ @{$Global::TemplateDir || []};
+ my $re = join "|", @paths;
+ $C->{AllowedFileRegex} = qr{^($re)};
+ return 1;
+ },
);
sub set_global_defaults {
2.27 +7 -8 interchange/lib/Vend/Data.pm
rev 2.27, prev_rev 2.26
Index: Data.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Data.pm,v
retrieving revision 2.26
retrieving revision 2.27
diff -u -r2.26 -r2.27
--- Data.pm 31 Mar 2003 15:42:36 -0000 2.26
+++ Data.pm 1 Apr 2003 04:12:32 -0000 2.27
@@ -1,6 +1,6 @@
# Vend::Data - Interchange databases
#
-# $Id: Data.pm,v 2.26 2003/03/31 15:42:36 mheins Exp $
+# $Id: Data.pm,v 2.27 2003/04/01 04:12:32 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -302,10 +302,8 @@
if($options->{file}) {
$fn = $options->{file};
- if( $Global::NoAbsolute) {
- die "No absolute file names like '$fn' allowed.\n"
- if Vend::Util::file_name_is_absolute($fn);
- }
+ Vend::File::allowed_file($fn)
+ or die "No absolute file names like '$fn' allowed.\n";
}
else {
Vend::Util::writefile($fn, $text)
@@ -874,10 +872,11 @@
($base,$path,$tail) = fileparse $database_txt, '\.[^/.]+$';
if(Vend::Util::file_name_is_absolute($database_txt)) {
- if ($Global::NoAbsolute) {
+ unless (allowed_file($database_txt)) {
my $msg = errmsg(
- "Security violation for NoAbsolute, trying to import %s",
- $database_txt);
+ "Security violation, trying to import %s",
+ $database_txt,
+ );
logError( $msg );
die "Security violation.\n";
}
1.13 +3 -7 interchange/lib/Vend/Dispatch.pm
rev 1.13, prev_rev 1.12
Index: Dispatch.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Dispatch.pm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- Dispatch.pm 14 Mar 2003 16:25:13 -0000 1.12
+++ Dispatch.pm 1 Apr 2003 04:12:32 -0000 1.13
@@ -1,6 +1,6 @@
# Vend::Dispatch - Handle Interchange page requests
#
-# $Id: Dispatch.pm,v 1.12 2003/03/14 16:25:13 racke Exp $
+# $Id: Dispatch.pm,v 1.13 2003/04/01 04:12:32 mheins Exp $
#
# Copyright (C) 2002 ICDEVGROUP <interchange@icdevgroup.org>
# Copyright (C) 2002 Mike Heins <mike@perusion.net>
@@ -26,7 +26,7 @@
package Vend::Dispatch;
use vars qw($VERSION);
-$VERSION = substr(q$Revision: 1.12 $, 10);
+$VERSION = substr(q$Revision: 1.13 $, 10);
use POSIX qw(strftime);
use Vend::Util;
@@ -344,11 +344,7 @@
$Vend::StatusLine = "Content-Type: " .
($CGI::values{mv_content_type} || 'application/octet-stream');
- ::response( Vend::Util::readfile (
- $CGI::values{mv_data_file},
- $Global::NoAbsolute,
- )
- );
+ ::response( Vend::Util::readfile ($CGI::values{mv_data_file}) );
return 0;
}
2.8 +4 -2 interchange/lib/Vend/Glimpse.pm
rev 2.8, prev_rev 2.7
Index: Glimpse.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Glimpse.pm,v
retrieving revision 2.7
retrieving revision 2.8
diff -u -r2.7 -r2.8
--- Glimpse.pm 1 Sep 2002 23:19:51 -0000 2.7
+++ Glimpse.pm 1 Apr 2003 04:12:32 -0000 2.8
@@ -1,6 +1,6 @@
# Vend::Glimpse - Search indexes with Glimpse
#
-# $Id: Glimpse.pm,v 2.7 2002/09/01 23:19:51 mheins Exp $
+# $Id: Glimpse.pm,v 2.8 2003/04/01 04:12:32 mheins Exp $
#
# Adapted for use with Interchange from Search::Glimpse
#
@@ -25,7 +25,7 @@
require Vend::Search;
@ISA = qw(Vend::Search);
-$VERSION = substr(q$Revision: 2.7 $, 10);
+$VERSION = substr(q$Revision: 2.8 $, 10);
use strict;
sub array {
@@ -241,6 +241,8 @@
# Get field names only if no sort (will throw it off) or
# not already defined
if($s->{mv_field_file}) {
+ allowed_file($s->{mv_field_file})
+ or return $s->search_error("can't open fields file");
$s->{mv_field_file} =
::catfile($Vend::Cfg->{ProductDir}, $s->{mv_field_file})
unless ::file_name_is_absolute($s->{mv_field_file});
2.154 +43 -16 interchange/lib/Vend/Interpolate.pm
rev 2.154, prev_rev 2.153
Index: Interpolate.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Interpolate.pm,v
retrieving revision 2.153
retrieving revision 2.154
diff -u -r2.153 -r2.154
--- Interpolate.pm 26 Mar 2003 14:16:32 -0000 2.153
+++ Interpolate.pm 1 Apr 2003 04:12:32 -0000 2.154
@@ -1,6 +1,6 @@
# Vend::Interpolate - Interpret Interchange tags
#
-# $Id: Interpolate.pm,v 2.153 2003/03/26 14:16:32 mheins Exp $
+# $Id: Interpolate.pm,v 2.154 2003/04/01 04:12:32 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -27,7 +27,7 @@
require Exporter;
@ISA = qw(Exporter);
-$VERSION = substr(q$Revision: 2.153 $, 10);
+$VERSION = substr(q$Revision: 2.154 $, 10);
@EXPORT = qw (
@@ -92,6 +92,7 @@
use strict;
use Vend::Util;
+use Vend::File;
use Vend::Data;
use Vend::Form;
require Vend::Cart;
@@ -1890,7 +1891,7 @@
$MVSAFE::Safe = 0 unless $MVSAFE::Unsafe;
}
- $body = readfile($opt->{file}, $Global::NoAbsolute) . $body
+ $body = readfile($opt->{file}) . $body
if $opt->{file};
$body =~ tr/\r//d if $Global::Windows;
@@ -2189,10 +2190,15 @@
}
$file = Vend::Util::escape_chars($file);
- if($Global::NoAbsolute and (file_name_is_absolute($file) or $file =~ m#\.\./.*\.\.#)) {
- ::logError("Can't use file '%s' with NoAbsolute set", $file);
- ::logGlobal({ level => 'auth'}, "Can't use file '%s' with NoAbsolute set", $file);
- return '';
+ unless(Vend::File::allowed_file($file)) {
+ my $msg = errmsg(
+ "%s: Can't use file '%s' with NoAbsolute set",
+ 'log',
+ $file,
+ );
+ ::logError($msg);
+ ::logGlobal({ level => 'auth'}, $msg);
+ return undef;
}
$file = ">$file" if $opt->{create};
@@ -2417,6 +2423,17 @@
return $val if defined $val;
}
+ unless (allowed_file($file)) {
+ my $msg = errmsg(
+ "%s: Can't use file '%s' with NoAbsolute set",
+ 'counter',
+ $file,
+ );
+ ::logError($msg);
+ ::logGlobal({ level => 'auth'}, $msg);
+ return undef;
+ }
+
$file = $Vend::Cfg->{VendRoot} . "/$file"
unless Vend::Util::file_name_is_absolute($file);
my $ctr = new Vend::CounterFile $file, $opt->{start} || undef;
@@ -4922,7 +4939,7 @@
}
elsif ($opt->{file}) {
#::logDebug("loop resolve file");
- $list = Vend::Util::readfile($opt->{file}, $Global::NoAbsolute);
+ $list = Vend::Util::readfile($opt->{file});
$opt->{lr} = 1 unless
defined $opt->{lr}
or $opt->{quoted};
@@ -5074,10 +5091,15 @@
#::logDebug("fly_page: selector=$selector");
unless (defined $page) {
- if($Global::NoAbsolute and (file_name_is_absolute($selector) or $selector =~ m#\.\./.*\.\.#)) {
- ::logError("Can't use file '%s' with NoAbsolute set", $selector);
- ::logGlobal({ level => 'auth'}, "Can't use file '%s' with NoAbsolute set", $selector);
- return '';
+ unless( allowed_file($selector) ) {
+ my $msg = errmsg(
+ "%s: Can't use file '%s' with NoAbsolute set",
+ 'fly_page',
+ $selector,
+ );
+ ::logError($msg);
+ ::logGlobal({ level => 'auth'}, $msg);
+ return undef;
}
$page = readin($selector);
if (defined $page) {
@@ -5606,10 +5628,15 @@
}
$file = Vend::Util::escape_chars($file);
- if(!$opt->{auto} and $Global::NoAbsolute and (file_name_is_absolute($file) or $file =~ m#\.\./.*\.\.#)) {
- ::logError("Can't use file '%s' with NoAbsolute set", $file);
- ::logGlobal({ level => 'auth'}, "Can't use file '%s' with NoAbsolute set", $file);
- return '';
+ if(! $opt->{auto} and ! allowed_file($file)) {
+ my $msg = errmsg(
+ "%s: Can't use file '%s' with NoAbsolute set",
+ 'timed_build',
+ $file,
+ );
+ ::logError($msg);
+ ::logGlobal({ level => 'auth'}, $msg);
+ return undef;
}
if( ! -f $file or $secs && (stat(_))[9] < (time() - $secs) ) {
2.48 +21 -10 interchange/lib/Vend/Order.pm
rev 2.48, prev_rev 2.47
Index: Order.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Order.pm,v
retrieving revision 2.47
retrieving revision 2.48
diff -u -r2.47 -r2.48
--- Order.pm 29 Mar 2003 22:11:08 -0000 2.47
+++ Order.pm 1 Apr 2003 04:12:32 -0000 2.48
@@ -1,6 +1,6 @@
# Vend::Order - Interchange order routing routines
#
-# $Id: Order.pm,v 2.47 2003/03/29 22:11:08 mheins Exp $
+# $Id: Order.pm,v 2.48 2003/04/01 04:12:32 mheins Exp $
#
# Copyright (C) 1996-2001 Red Hat, Inc. <interchange@redhat.com>
#
@@ -28,7 +28,7 @@
package Vend::Order;
require Exporter;
-$VERSION = substr(q$Revision: 2.47 $, 10);
+$VERSION = substr(q$Revision: 2.48 $, 10);
@ISA = qw(Exporter);
@@ -50,6 +50,7 @@
);
use Vend::Util;
+use Vend::File;
use Vend::Interpolate;
use Vend::Session;
use Vend::Data;
@@ -796,15 +797,20 @@
my($subject);
# LEGACY
if ($::Values->{mv_order_report}) {
- if($Global::NoAbsolute and (file_name_is_absolute($::Values->{mv_order_report}) or $::Values->{mv_order_report} =~ m#\.\./.*\.\.#)) {
- ::logError("Can't use file '%s' with NoAbsolute set", $::Values->{mv_order_report});
- ::logGlobal({ level => 'auth'}, "Can't use file '%s' with NoAbsolute set", $::Values->{mv_order_report});
+ unless( allowed_file($::Values->{mv_order_report}) ) {
+ my $msg = errmsg(
+ "%s: Can't use file '%s' with NoAbsolute set",
+ 'mail_order',
+ $::Values->{mv_order_report},
+ );
+ ::logError($msg);
+ ::logGlobal({ level => 'auth'}, $msg);
return undef;
}
$body = readin($::Values->{mv_order_report})
}
# END LEGACY
- $body = readfile($Vend::Cfg->{OrderReport}, $Global::NoAbsolute)
+ $body = readfile($Vend::Cfg->{OrderReport})
if ! $body;
unless (defined $body) {
::logError(
@@ -817,9 +823,14 @@
$Vend::Cfg->{OrderReport},
$::Values->{mv_order_report},
);
- if($Global::NoAbsolute and (file_name_is_absolute($Vend::Cfg->{OrderReport}) or $Vend::Cfg->{OrderReport} =~ m#\.\./.*\.\.#)) {
- ::logError("Can't use file '%s' with NoAbsolute set", $Vend::Cfg->{OrderReport});
- ::logGlobal({ level => 'auth'}, "Can't use file '%s' with NoAbsolute set", $Vend::Cfg->{OrderReport});
+ unless( allowed_file($Vend::Cfg->{OrderReport}) ) {
+ my $msg = errmsg(
+ "%s: Can't use file '%s' with NoAbsolute set",
+ 'mail_order',
+ $Vend::Cfg->{OrderReport},
+ );
+ ::logError($msg);
+ ::logGlobal({ level => 'auth'}, $msg);
return undef;
}
$body = readin($Vend::Cfg->{OrderReport});
@@ -1690,7 +1701,7 @@
}
else {
$pagefile = $route->{'report'} || $main->{'report'};
- $page = readfile($pagefile, $Global::NoAbsolute);
+ $page = readfile($pagefile);
}
die errmsg(
"No order report %s or %s found.",
2.10 +6 -3 interchange/lib/Vend/Page.pm
rev 2.10, prev_rev 2.9
Index: Page.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Page.pm,v
retrieving revision 2.9
retrieving revision 2.10
diff -u -r2.9 -r2.10
--- Page.pm 14 Jan 2003 02:25:53 -0000 2.9
+++ Page.pm 1 Apr 2003 04:12:32 -0000 2.10
@@ -1,6 +1,6 @@
# Vend::Page - Handle Interchange page routing
#
-# $Id: Page.pm,v 2.9 2003/01/14 02:25:53 mheins Exp $
+# $Id: Page.pm,v 2.10 2003/04/01 04:12:32 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -45,7 +45,7 @@
use vars qw/$VERSION/;
-$VERSION = substr(q$Revision: 2.9 $, 10);
+$VERSION = substr(q$Revision: 2.10 $, 10);
my $wantref = 1;
@@ -63,8 +63,11 @@
};
$subject = $subject || 'unspecified error';
+
+ my $noname = $name;
+ $noname =~ s:^\.\./::;
- $page = readfile($name, $Global::NoAbsolute, 1) || readin($name);
+ $page = readfile($noname, $Global::NoAbsolute, 1) || readin($name);
die ::get_locale_message(412, "Missing special page: %s\n", $name)
unless defined $page;
2.18 +4 -3 interchange/lib/Vend/Scan.pm
rev 2.18, prev_rev 2.17
Index: Scan.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Scan.pm,v
retrieving revision 2.17
retrieving revision 2.18
diff -u -r2.17 -r2.18
--- Scan.pm 18 Oct 2002 07:10:46 -0000 2.17
+++ Scan.pm 1 Apr 2003 04:12:32 -0000 2.18
@@ -1,6 +1,6 @@
# Vend::Scan - Prepare searches for Interchange
#
-# $Id: Scan.pm,v 2.17 2002/10/18 07:10:46 mheins Exp $
+# $Id: Scan.pm,v 2.18 2003/04/01 04:12:32 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -29,10 +29,11 @@
perform_search
);
-$VERSION = substr(q$Revision: 2.17 $, 10);
+$VERSION = substr(q$Revision: 2.18 $, 10);
use strict;
use Vend::Util;
+use Vend::File;
use Vend::Interpolate;
use Vend::Data qw(product_code_exists_ref column_index);
use Vend::TextSearch;
@@ -879,7 +880,7 @@
$passed = [] unless $passed;
my(@files) = grep /\S/, split /\s*[,\0]\s*/, $param, -1;
for(@files) {
- my $ok = (file_name_is_absolute($_) or /\.\./) ? 0 : 1;
+ my $ok = allowed_file($_);
if(!$ok) {
$ok = 1 if $_ eq $::Variable->{MV_SEARCH_FILE};
$ok = 1 if $::Scratch->{$_};
2.56 +19 -494 interchange/lib/Vend/Util.pm
rev 2.56, prev_rev 2.55
Index: Util.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Util.pm,v
retrieving revision 2.55
retrieving revision 2.56
diff -u -r2.55 -r2.56
--- Util.pm 27 Mar 2003 16:52:59 -0000 2.55
+++ Util.pm 1 Apr 2003 04:12:32 -0000 2.56
@@ -1,6 +1,6 @@
# Vend::Util - Interchange utility functions
#
-# $Id: Util.pm,v 2.55 2003/03/27 16:52:59 mheins Exp $
+# $Id: Util.pm,v 2.56 2003/04/01 04:12:32 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -57,6 +57,7 @@
logGlobal
logOnce
logtime
+ parse_locale
random_string
readfile
readin
@@ -83,9 +84,10 @@
use Text::ParseWords;
require HTML::Entities;
use Safe;
+use Vend::File;
use subs qw(logError logGlobal);
use vars qw($VERSION @EXPORT @EXPORT_OK);
-$VERSION = substr(q$Revision: 2.55 $, 10);
+$VERSION = substr(q$Revision: 2.56 $, 10);
my $Eval_routine;
my $Eval_routine_file;
@@ -677,68 +679,6 @@
*uneval_file = defined $Fast_uneval_file ? $Fast_uneval_file : \&uneval_it_file;
*uneval = defined $Pretty_uneval ? $Pretty_uneval : \&uneval_it;
-sub writefile {
- my($file, $data, $opt) = @_;
-
- $file = ">>$file" unless $file =~ /^[|>]/;
- if (ref $opt and $opt->{umask}) {
- $opt->{umask} = umask oct($opt->{umask});
- }
- eval {
- unless($file =~ s/^[|]\s*//) {
- if (ref $opt and $opt->{auto_create_dir}) {
- my $dir = $file;
- $dir =~ s/>+//;
-
- ## Need to make this OS-independent, requires File::Spec support
- $dir =~ s:[\r\n]::g; # Just in case
- $dir =~ s:(.*)/.*:$1: or $dir = '';
- if($dir and ! -d $dir) {
- File::Path::mkpath($dir);
- }
- }
- # We have checked for beginning > or | previously
- open(MVLOGDATA, $file) or die "open\n";
- lockfile(\*MVLOGDATA, 1, 1) or die "lock\n";
- seek(MVLOGDATA, 0, 2) or die "seek\n";
- if(ref $data) {
- print(MVLOGDATA $$data) or die "write to\n";
- }
- else {
- print(MVLOGDATA $data) or die "write to\n";
- }
- unlockfile(\*MVLOGDATA) or die "unlock\n";
- }
- else {
- my (@args) = grep /\S/, Text::ParseWords::shellwords($file);
- open(MVLOGDATA, "|-") || exec @args;
- if(ref $data) {
- print(MVLOGDATA $$data) or die "pipe to\n";
- }
- else {
- print(MVLOGDATA $data) or die "pipe to\n";
- }
- }
- close(MVLOGDATA) or die "close\n";
- };
-
- my $status = 1;
- if ($@) {
- ::logError ("Could not %s file '%s': %s\nto write this data:\n%s",
- $@,
- $file,
- $!,
- $data,
- );
- $status = 0;
- }
-
- if (ref $opt and defined $opt->{umask}) {
- $opt->{umask} = umask oct($opt->{umask});
- }
-
- return $status;
-}
# Log data fields to a data file.
@@ -780,11 +720,6 @@
}
-sub file_modification_time {
- my ($fn, $tolerate) = @_;
- my @s = stat($fn) or ($tolerate and return 0) or die "Can't stat '$fn': $!\n";
- return $s[9];
-}
sub quoted_comma_string {
my ($text) = @_;
@@ -1198,97 +1133,6 @@
return ($contents, $record);
}
-sub readfile_db {
- my ($name) = @_;
- return unless $Vend::Cfg->{FileDatabase};
- my ($tab, $col) = split /:+/, $Vend::Cfg->{FileDatabase};
- my $db = $Vend::Interpolate::Db{$tab} || ::database_exists_ref($tab)
- or return undef;
-#::logDebug("tab=$tab exists, db=$db");
-
- # I guess this is the best test
- if($col) {
- return undef unless $db->column_exists($col);
- }
- elsif ( $col = $Global::Variable->{LANG} and $db->column_exists($col) ) {
- #do nothing
- }
- else {
- $col = 'default';
- return undef unless $db->column_exists($col);
- }
-
-#::logDebug("col=$col exists, db=$db");
- return undef unless $db->record_exists($name);
-#::logDebug("ifile=$name exists, db=$db");
- return $db->field($name, $col);
-}
-
-# Reads in an arbitrary file. Returns the entire contents,
-# or undef if the file could not be read.
-# Careful, needs the full path, or will be read relative to
-# VendRoot..and will return binary. Should be tested by
-# the user.
-
-# Will also look in the *global* TemplateDir. (No need for the
-# extra overhead of local TemplateDir, probably also insecure.)
-#
-# To ensure security in multiple catalog setups, leading /
-# is not allowed if the second subroutine argument passed
-# (caller usually sends $Global::NoAbsolute) is true.
-
-# If catalog FileDatabase is enabled and there are no contents, we can retrieve
-# the file from the database.
-
-sub readfile {
- my($ifile, $no, $loc) = @_;
- my($contents);
- local($/);
-
- if($no and (file_name_is_absolute($ifile) or $ifile =~ m#\.\./.*\.\.#)) {
- ::logError("Can't read file '%s' with NoAbsolute set" , $ifile);
- ::logGlobal({ level => 'auth'}, "Can't read file '%s' with NoAbsolute set" , $ifile );
- return undef;
- }
-
- my $file;
-
- if (file_name_is_absolute($ifile) and -f $ifile) {
- $file = $ifile;
- }
- else {
- for( ".", @{$Global::TemplateDir} ) {
- next if ! -f "$_/$ifile";
- $file = "$_/$ifile";
- last;
- }
- }
-
- if(! $file) {
- $contents = readfile_db($ifile);
- return undef unless defined $contents;
- }
- else {
- return undef unless open(READIN, "< $file");
- $Global::Variable->{MV_FILE} = $file;
-
- binmode(READIN) if $Global::Windows;
- undef $/;
- $contents = <READIN>;
- close(READIN);
- }
-
- if (
- $Vend::Cfg->{Locale}
- and
- (defined $loc ? $loc : $Vend::Cfg->{Locale}->{readfile} )
- )
- {
- parse_locale(\$contents);
- }
- return $contents;
-}
-
sub is_yes {
return( defined($_[0]) && ($_[0] =~ /^[yYtT1]/));
}
@@ -1447,107 +1291,6 @@
my $flock_LOCK_NB = 4; # Don't block when locking
my $flock_LOCK_UN = 8; # Unlock
-sub flock_lock {
- my ($fh, $excl, $wait) = @_;
- my $flag = $excl ? $flock_LOCK_EX : $flock_LOCK_SH;
-
- if ($wait) {
- flock($fh, $flag) or die "Could not lock file: $!\n";
- return 1;
- }
- else {
- if (! flock($fh, $flag | $flock_LOCK_NB)) {
- if ($!{EAGAIN} or $!{EWOULDBLOCK}) {
- return 0;
- }
- else {
- die "Could not lock file: $!\n";
- }
- }
- return 1;
- }
-}
-
-sub flock_unlock {
- my ($fh) = @_;
- flock($fh, $flock_LOCK_UN) or die "Could not unlock file: $!\n";
-}
-
-sub fcntl_lock {
- my ($fh, $excl, $wait) = @_;
- my $flag = $excl ? F_WRLCK : F_RDLCK;
- my $op = $wait ? F_SETLKW : F_SETLK;
-
- my $struct = pack('sslli', $flag, 0, 0, 0, $$);
-
- if ($wait) {
- fcntl($fh, $op, $struct) or die "Could not fcntl_lock file: $!\n";
- return 1;
- }
- else {
- if (fcntl($fh, $op, $struct) < 0) {
- if ($!{EAGAIN} or $!{EWOULDBLOCK}) {
- return 0;
- }
- else {
- die "Could not lock file: $!\n";
- }
- }
- return 1;
- }
-}
-
-sub fcntl_unlock {
- my ($fh) = @_;
- my $struct = pack('sslli', F_UNLCK, 0, 0, 0, $$);
- if (fcntl($fh, F_SETLK, $struct) < 0) {
- if ($!{EAGAIN} or $!{EWOULDBLOCK}) {
- return 0;
- }
- else {
- die "Could not un-fcntl_lock file: $!\n";
- }
- }
- return 1;
-}
-
-my $lock_function = \&flock_lock;
-my $unlock_function = \&flock_unlock;
-
-sub set_lock_type {
- if ($Global::LockType eq 'none') {
- logDebug("using NO locking");
- $lock_function = sub {1};
- $unlock_function = sub {1};
- }
- elsif ($Global::LockType =~ /fcntl/i) {
- logDebug("using fcntl(2) locking");
- $lock_function = \&fcntl_lock;
- $unlock_function = \&fcntl_unlock;
- }
- else {
- $lock_function = \&flock_lock;
- $unlock_function = \&flock_unlock;
- }
- return; # VOID
-}
-
-sub lockfile {
- &$lock_function(@_);
-}
-
-sub unlockfile {
- &$unlock_function(@_);
-}
-
-### Still necessary, sad to say.....
-if($Global::Windows) {
- set_lock_type('none');
-}
-elsif($^O =~ /hpux/) {
- set_lock_type('fcntl');
-}
-
# Returns the total number of items ordered.
# Uses the current cart if none specified.
@@ -2025,223 +1768,6 @@
return unescape_chars($1);
}
-# Return a quasi-hashed directory/file combo, creating if necessary
-sub exists_filename {
- my ($file,$levels,$chars, $dir) = @_;
- my $i;
- $levels = 1 unless defined $levels;
- $chars = 1 unless defined $chars;
- $dir = $Vend::Cfg->{ScratchDir} unless $dir;
- for($i = 0; $i < $levels; $i++) {
- $dir .= "/";
- $dir .= substr($file, $i * $chars, $chars);
- return 0 unless -d $dir;
- }
- return -f "$dir/$file" ? 1 : 0;
-}
-
-# Return a quasi-hashed directory/file combo, creating if necessary
-sub get_filename {
- my ($file,$levels,$chars, $dir) = @_;
- my $i;
- $levels = 1 unless defined $levels;
- $chars = 1 unless defined $chars;
- $dir = $Vend::Cfg->{ScratchDir} unless $dir;
- for($i = 0; $i < $levels; $i++) {
- $dir .= "/";
- $dir .= substr($file, $i * $chars, $chars);
- mkdir $dir, 0777 unless -d $dir;
- }
- die "Couldn't make directory $dir (or parents): $!\n"
- unless -d $dir;
- return "$dir/$file";
-}
-
-# These were stolen from File::Spec
-# Can't use that because it INSISTS on object
-# calls without returning a blessed object
-
-my $abspat = $^O =~ /win32/i ? qr{^([a-zA-Z]:)?[\\/]} : qr{^/};
-my $relpat = qr{\.\.[\\/]};
-
-sub file_name_is_absolute {
- my($file) = @_;
- $file =~ $abspat;
-}
-
-sub absolute_or_relative {
- my($file) = @_;
- $file =~ $abspat or $file =~ $relpat;
-}
-
-sub win_catfile {
- my $file = pop @_;
- return $file unless @_;
- my $dir = catdir(@_);
- $dir =~ s/(\\\.)$//;
- $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\";
- return $dir.$file;
-}
-
-sub unix_catfile {
- my $file = pop @_;
- return $file unless @_;
- my $dir = catdir(@_);
- for ($dir) {
- $_ .= "/" unless substr($_,length($_)-1,1) eq "/";
- }
- return $dir.$file;
-}
-
-sub unix_path {
- my $path_sep = ":";
- my $path = $ENV{PATH};
- my @path = split $path_sep, $path;
- foreach(@path) { $_ = '.' if $_ eq '' }
- @path;
-}
-
-sub win_path {
- local $^W = 1;
- my $path = $ENV{PATH} || $ENV{Path} || $ENV{'path'};
- my @path = split(';',$path);
- foreach(@path) { $_ = '.' if $_ eq '' }
- @path;
-}
-
-sub win_catdir {
- my @args = @_;
- for (@args) {
- # append a slash to each argument unless it has one there
- $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\";
- }
- my $result = canonpath(join('', @args));
- $result;
-}
-
-sub win_canonpath {
- my($path) = @_;
- $path =~ s/^([a-z]:)/\u$1/;
- $path =~ s|/|\\|g;
- $path =~ s|\\+|\\|g ; # xx////xx -> xx/xx
- $path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx
- $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx
- $path =~ s|\\$||
- unless $path =~ m#^([a-z]:)?\\#; # xx/ -> xx
- $path .= '.' if $path =~ m#\\$#;
- $path;
-}
-
-sub unix_canonpath {
- my($path) = @_;
- $path =~ s|/+|/|g ; # xx////xx -> xx/xx
- $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx
- $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx
- $path =~ s|/$|| unless $path eq "/"; # xx/ -> xx
- $path;
-}
-
-sub unix_catdir {
- my @args = @_;
- for (@args) {
- # append a slash to each argument unless it has one there
- $_ .= "/" if $_ eq '' or substr($_,-1) ne "/";
- }
- my $result = join('', @args);
- # remove a trailing slash unless we are root
- substr($result,-1) = ""
- if length($result) > 1 && substr($result,-1) eq "/";
- $result;
-}
-
-
-my $catdir_routine;
-my $canonpath_routine;
-my $catfile_routine;
-my $path_routine;
-
-if($^O =~ /win32/i) {
- $catdir_routine = \&win_catdir;
- $catfile_routine = \&win_catfile;
- $path_routine = \&win_path;
- $canonpath_routine = \&win_canonpath;
-}
-else {
- $catdir_routine = \&unix_catdir;
- $catfile_routine = \&unix_catfile;
- $path_routine = \&unix_path;
- $canonpath_routine = \&unix_canonpath;
-}
-
-sub path {
- return &{$path_routine}(@_);
-}
-
-sub catfile {
- return &{$catfile_routine}(@_);
-}
-
-sub catdir {
- return &{$catdir_routine}(@_);
-}
-
-sub canonpath {
- return &{$canonpath_routine}(@_);
-}
-
-#print "catfile a b c --> " . catfile('a', 'b', 'c') . "\n";
-#print "catdir a b c --> " . catdir('a', 'b', 'c') . "\n";
-#print "canonpath a/b//../../c --> " . canonpath('a/b/../../c') . "\n";
-#print "file_name_is_absolute a/b/c --> " . file_name_is_absolute('a/b/c') . "\n";
-#print "file_name_is_absolute a:b/c --> " . file_name_is_absolute('a:b/c') . "\n";
-#print "file_name_is_absolute /a/b/c --> " . file_name_is_absolute('/a/b/c') . "\n";
-
-#my $MIME_Lite;
-#eval {
-# require MIME::Lite;
-# $MIME_Lite = 1;
-# require Net::SMTP;
-#};
-#
-#sub mime_lite_send {
-# my ($opt, $body) = @_;
-#
-# if(! $MIME_Lite) {
-# return send_mail(
-# $opt->{to},
-# $opt->{subject},
-# $body,
-# $opt->{reply},
-# undef,
-# split /\n+/, $opt->{extra}
-# );
-# }
-#
-# my %special = qw/
-# as_string 1
-# internal 1
-# /;
-# my $mime = new MIME::Lite;;
-#
-# my @ary;
-# my $popt = {};
-# my $mopt = {};
-# for(keys %$opt) {
-# if(ref $opt->{$_}) {
-# push @ary, [ $_, delete $opt->{$_} ];
-# }
-# if($special{$_}) {
-# $popt->{$_} = delete $opt->{$_};
-# }
-# my $m = $_;
-# s/_/-/g;
-# s/(\w+)/\L\u$1/g;
-# s/-/_/g;
-# $mopt->{$_} = $opt->{$m};
-# }
-#
-#}
-
sub send_mail {
my($to, $subject, $body, $reply, $use_mime, @extra_headers) = @_;
@@ -2418,22 +1944,21 @@
$ok;
}
-sub get_cfg_header {
- my ($file) = @_;
- my $cfg = {};
- local ($_, *IN);
- unless (open IN, "<$file") {
- my @msg = ("Can't open config file '%s': %s\n", $file, $!);
- logError(@msg);
- return { error => errmsg(@msg) };
- }
- while (<IN>) {
- ($cfg->{position} = $1, last) if /^\s*#\s*position\s*:\s*(\d+)/i;
- }
- close IN;
- return $cfg;
-}
-
+### Provide stubs for former Vend::Util functions relocated to Vend::File
+*canonpath = \&Vend::File::canonpath;
+*catdir = \&Vend::File::catdir;
+*catfile = \&Vend::File::catfile;
+*exists_filename = \&Vend::File::exists_filename;
+*file_modification_time = \&Vend::File::file_modification_time;
+*file_name_is_absolute = \&Vend::File::file_name_is_absolute;
+*get_filename = \&Vend::File::get_filename;
+*lockfile = \&Vend::File::lockfile;
+*path = \&Vend::File::path;
+*readfile = \&Vend::File::readfile;
+*readfile_db = \&Vend::File::readfile_db;
+*set_lock_type = \&Vend::File::set_lock_type;
+*unlockfile = \&Vend::File::unlockfile;
+*writefile = \&Vend::File::writefile;
1;
__END__
2.1 interchange/lib/Vend/File.pm
rev 2.1, prev_rev 2.0