Permalink
Browse files

This commit was manufactured by cvs2svn to create tag 'REL_4_8_8'.

  • Loading branch information...
1 parent 60079cc commit 9f21e7765f80c08ed7e7f3bd3625872b76abb9c6 cvs2svn committed Dec 16, 2003
Showing with 0 additions and 580 deletions.
  1. +0 −580 perl/Interchange.pm
View
580 perl/Interchange.pm
@@ -1,580 +0,0 @@
-# Interchange.pm - Interchange access for Perl scripts
-#
-# $Id: Interchange.pm,v 2.0.2.2 2003-01-24 06:51:53 jon Exp $
-#
-# Copyright (C) 1996-2003 Red Hat, Inc. and
-# Interchange Development Group, http://www.icdevgroup.org/
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public
-# License along with this program; if not, write to the Free
-# Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
-# MA 02111-1307 USA.
-
-package Interchange;
-require Exporter;
-
-@ISA = qw(Exporter);
-
-@EXPORT = qw();
-@EXPORT_OK = qw();
-
-use strict;
-use Fcntl;
-use vars qw($VERSION @EXPORT @EXPORT_OK);
-$VERSION = substr(q$Revision: 2.0.2.2 $, 10);
-
-BEGIN {
- require 5.005;
- ($Global::VendRoot = $ENV{INTERCHANGE_ROOT})
- if defined $ENV{INTERCHANGE_ROOT};
- ($Global::CatRoot = $ENV{INTERCHANGE_CATDIR})
- if defined $ENV{INTERCHANGE_ROOT};
-
-$Global::VendRoot = $Global::VendRoot || '/work/minivend';
-#$Global::VendRoot = $Global::VendRoot || '~_~INSTALLARCHLIB~_~';
-$Global::CatRoot = $Global::CatRoot || '/work/minivend';
-#$Global::VendRoot = $Global::VendRoot || '~_~INSTALLARCHLIB~_~';
-$Global::ConfigFile = 'minivend.structure';
-
-}
-
-my $Eval_routine;
-my $Eval_routine_file;
-my $Pretty_uneval;
-my $Fast_uneval;
-my $Fast_uneval_file;
-
-### END CONFIGURABLE MODULES
-
-# leaving out 0, O and 1, l
-my $random_chars = "ABCDEFGHIJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz23456789";
-
-# Return a string of random characters.
-
-sub random_string {
- my ($len) = @_;
- $len = 8 unless $len;
- my ($r, $i);
-
- $r = '';
- for ($i = 0; $i < $len; ++$i) {
- $r .= substr($random_chars, int(rand(length($random_chars))), 1);
- }
- $r;
-}
-
-sub hexify {
- my $string = shift;
- $string =~ s/(\W)/sprintf '%%%02x', ord($1)/ge;
- return $string;
-}
-
-sub unhexify {
- my $s = shift;
- $s =~ s/%(..)/chr(hex($1))/ge;
- return $s;
-}
-
-## UNEVAL
-
-# Returns a string representation of an anonymous array, hash, or scaler
-# that can be eval'ed to produce the same value.
-# uneval([1, 2, 3, [4, 5]]) -> '[1,2,3,[4,5,],]'
-# Uses either Storable::freeze or Data::Dumper::DumperX or uneval
-# in
-
-sub uneval_it {
- my($o) = @_; # recursive
- my($r, $s, $i, $key, $value);
-
- local($^W) = 0;
- $r = ref $o;
- if (!$r) {
- $o =~ s/([\\"\$@])/\\$1/g;
- $s = '"' . $o . '"';
- } elsif ($r eq 'ARRAY') {
- $s = "[";
- foreach $i (0 .. $#$o) {
- $s .= uneval_it($o->[$i]) . ",";
- }
- $s .= "]";
- } elsif ($r eq 'HASH') {
- $s = "{";
- while (($key, $value) = each %$o) {
- $s .= "'$key' => " . uneval_it($value) . ",";
- }
- $s .= "}";
- } else {
- $s = "'something else'";
- }
-
- $s;
-}
-
-use subs 'uneval_fast';
-
-sub uneval_it_file {
- my ($ref, $fn) = @_;
- open(UNEV, ">$fn")
- or die "Can't create $fn: $!\n";
- print UNEV uneval_fast($ref);
- close UNEV;
-}
-
-sub eval_it_file {
- my ($fn) = @_;
- local($/) = undef;
- open(UNEV, "< $fn") or return undef;
- my $ref = evalr(<UNEV>);
- close UNEV;
- return $ref;
-}
-
-# See if we have Storable and the user has OKed its use
-# If so, session storage/write will be about 5x faster
-eval {
- die unless $ENV{MINIVEND_STORABLE} || -f "$Global::VendRoot/_session_storable";
- require Storable;
- import Storable 'freeze';
- $Fast_uneval = \&Storable::freeze;
- $Fast_uneval_file = \&Storable::store;
- $Eval_routine = \&Storable::thaw;
- $Eval_routine_file = \&Storable::retrieve;
-};
-
-# See if Data::Dumper is installed with XSUB
-# If it is, session writes will be about 25-30% faster
-eval {
- require Data::Dumper;
- import Data::Dumper 'DumperX';
- $Data::Dumper::Indent = 1;
- $Data::Dumper::Terse = 1;
- $Pretty_uneval = \&Data::Dumper::DumperX;
- $Fast_uneval = \&Data::Dumper::DumperX
- unless defined $Fast_uneval;
-};
-
-*uneval_fast = defined $Fast_uneval ? $Fast_uneval : \&uneval_it;
-*evalr = defined $Eval_routine ? $Eval_routine : sub { eval shift };
-*eval_file = defined $Eval_routine_file ? $Eval_routine_file : \&eval_it_file;
-*uneval_file = defined $Fast_uneval_file ? $Fast_uneval_file : \&uneval_it_file;
-*uneval = defined $Pretty_uneval ? $Pretty_uneval : \&uneval_it;
-
-# Returns a URL which will run the ordering system again. Each URL
-# contains the session ID as well as a unique integer to avoid caching
-# of pages by the browser.
-
-my %Special = (
-
- );
-sub new {
- my ($class, @options) =
- my ($k, $v);
- my $self = {};
- while (defined ($k = shift(@options)) {
- ($self->{$k} = shift(@options), next)
- unless defined $Special{lc $k};
- my $arg = shift @options;
- $Special{lc $k}->($self, $arg);
- }
-
- if(! $self->{Cfg}{CatRoot}) {
- for( $ENV{INTERCHANGE_CATDIR},
- if(-f $ENV{INTERCHANGE_CATDIR}) {
- }
- }
- unless (defined $self->{session}) {
- }
- bless $self, $class;
-}
-
-sub vendUrl {
- my($path, $arguments, $r) = @_;
- $r = $Vend::Cfg->{VendURL}
- unless defined $r;
-
- my @parms;
-
- if(defined $Vend::Cfg->{AlwaysSecure}{$path}) {
- $r = $Vend::Cfg->{SecureURL};
- }
-
- my($id, $ct);
- $id = $Vend::SessionID
- unless $CGI::cookie && $::Scratch->{mv_no_session_id};
-
- $r .= '/' . $path;
- $r .= '.html' if $::Scratch->{mv_add_dot_html} and $r !~ /\.html?$/;
- push @parms, "mv_session_id=$id" if defined $id;
- push @parms, "mv_arg=" . hexify($arguments) if defined $arguments;
- push @parms, "mv_cat=$Vend::Cfg->{CatalogName}"
- if defined $Vend::VirtualCat;
- return $r unless @parms;
- return $r . '?' . join("&", @parms);
-}
-
-sub secure_vendUrl {
- return vendUrl($_[0], $_[1], $Vend::Cfg->{SecureURL});
-}
-
-my $use = undef;
-
-### flock locking
-
-# sys/file.h:
-my $flock_LOCK_SH = 1; # Shared lock
-my $flock_LOCK_EX = 2; # Exclusive lock
-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 ($! =~ m/^Try again/
- or $! =~ m/^Resource temporarily unavailable/
- or $! =~ m/^Operation would block/) {
- 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";
-}
-
-
-### Select based on os, vestigial
-
-use vars qw($lock_function $unlock_function);
-
-$lock_function = \&flock_lock;
-$unlock_function = \&flock_unlock;
-sub fcntl_lock {
- my ($fh, $excl, $wait) = @_;
- my $flag = $excl ? F_WRLCK : F_RDLCK;
- my $buf = pack("ssLL",$flag,0,0,0);
-
- LOCKLOOP:{
- if ($wait) {
- if (! fcntl($fh, F_SETLKW, $buf)) {
- redo LOCKLOOP if $! =~ m/^Interrupted/;
- die "Could not lock file: $!\n";
- }
- }
- else {
- if (! fcntl($fh, F_SETLK, $buf)) {
- redo LOCKLOOP if $! =~ m/^Interrupted/;
- if ($! =~ m/^Try again/
- or $! =~ m/^Resource temporarily unavailable/
- or $! =~ m/^Operation would block/) {
- return 0;
- }
- die "Could not lock file: $!\n";
- }
- }
- return 1;
- }
-}
-
-sub fcntl_unlock {
- my ($fh) = @_;
- my $buf = pack("ssLL",F_WRLCK,0,0,0);
- fcntl($fh, F_UNLCK, $buf) or die "Could not unlock file: $!\n";
-}
-
-sub set_lock_function {
- my ($self, $arg) = @_;
- if(!$arg) {
- return ($self->{_config}{lock_type} ||= 'flock');
- }
- elsif ($arg eq 'flock') {
- $lock_function = \&flock_lock;
- $unlock_function = \&flock_unlock;
- return ($self->{_config}{lock_type} = 'flock');
- }
- elsif($arg eq 'fcntl') {
- $lock_function = \&fcntl_lock;
- $unlock_function = \&fcntl_unlock;
- return ($self->{_config}{lock_type} = 'fcntl');
- }
- elsif ($arg eq 'none') {
- warn "Using NO locking: I hope you know what you are doing!"
- unless $^O =~ /win32/i;
- $lock_function = sub {1};
- $unlock_function = sub {1};
- return ($self->{_config}{lock_type} = 'none');
- }
- else {
- die "unknown lock function $arg";
- }
-}
-
-sub lockfile {
- &$lock_function(@_);
-}
-
-sub unlockfile {
- &$unlock_function(@_);
-}
-
-# Returns the total number of items ordered.
-# Uses the current cart if none specified.
-
-sub tag_nitems {
- my($self, $opt) = @_;
-
- $opt->{cart} = ($self->{_config}{current_cart} ||= 'main')
- unless $opt->{cart};
-
- my ($attr, $sub);
- if($opt->{qualifier}) {
- $attr = $opt->{qualifier};
- my $qr;
- $qr = qr{$opt->{compare}}
- if $opt->{compare};
- if($opt->{compare}) {
- $sub = sub {
- $_[0] =~ $qr;
- };
- }
- else {
- $sub = sub { return $_[0] };
- }
- }
-
- my $total = 0;
- foreach my $item (@$cart) {
- next if $attr and ! $sub->($item->{$attr});
- $total += $item->{'quantity'};
- }
- $total;
-}
-
-sub errmsg {
- my($fmt, @strings) = @_;
- my $location;
- if($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$fmt}) {
- $location = $Vend::Cfg->{Locale};
- }
- elsif($Global::Locale and defined $Global::Locale->{$fmt}) {
- $location = $Global::Locale;
- }
- return sprintf $fmt, @strings if ! $location;
- if(ref $location->{$fmt}) {
- $fmt = $location->{$fmt}[0];
- @strings = @strings[ @{ $location->{$fmt}[1] } ];
- }
- else {
- $fmt = $location->{$fmt};
- }
- return sprintf $fmt, @strings;
-}
-
-# Here for convenience in calls
-sub set_cookie {
- my ($name, $value, $expire) = @_;
- $::Instance->{Cookies} = []
- if ! $::Instance->{Cookies};
- @{$::Instance->{Cookies}} = [$name, $value, $expire];
- return;
-}
-
-# Here for convenience in calls
-sub read_cookie {
- my ($lookfor, $string) = @_;
- $string = $ENV{HTTP_COOKIE}
- unless defined $string;
- return undef unless $string =~ /\b$lookfor=([^\s;]+)/i;
- return unhexify($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 ? '^([a-z]:)?[\\\\/]' : '^/';
-
-sub file_name_is_absolute {
- my($file) = @_;
- $file =~ m{$abspat}oi ;
-}
-
-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";
-
-1;
-__END__

0 comments on commit 9f21e77

Please sign in to comment.