[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