First pass at adding key files
This commit is contained in:
dsainty
306
site/glist/lib/GT/AutoLoader.pm
Normal file
306
site/glist/lib/GT/AutoLoader.pm
Normal file
@@ -0,0 +1,306 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::AutoLoader
|
||||
# Author: Jason Rhinelander
|
||||
# $Id: AutoLoader.pm,v 1.13 2005/03/21 06:57:58 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::AutoLoader;
|
||||
|
||||
use vars qw($AUTOLOAD %LOG %PACKAGES);
|
||||
use strict qw/vars subs/; # no strict 'refs' - we need several soft references here.
|
||||
|
||||
sub import {
|
||||
shift; # Discard the package, as 'use GT::AutoLoader' calls GT::AutoLoader->import(ARGS)
|
||||
my %opts = @_;
|
||||
|
||||
my $pkg = caller;
|
||||
++$PACKAGES{$pkg};
|
||||
|
||||
if ($opts{LOG} and ref $opts{LOG} eq 'CODE') {
|
||||
$LOG{$pkg} = delete $opts{LOG}; # Everything that requests a log will get one for all modules
|
||||
}
|
||||
|
||||
delete $opts{NAME} if $opts{NAME} and $opts{NAME} eq 'AUTOLOAD'; # Allows "if ($opts{NAME})" later on.
|
||||
|
||||
my $COMPILE;
|
||||
*{$pkg . ($opts{NAME} ? "::$opts{NAME}" : '::AUTOLOAD')} = sub {
|
||||
if ($opts{NAME} or !$AUTOLOAD) { # If they're using another name, it most likely means they are wrapping the AUTOLOAD, which means we have to check for $AUTOLOAD in their package.
|
||||
$AUTOLOAD = ${$pkg . '::AUTOLOAD'};
|
||||
}
|
||||
my ($func) = $AUTOLOAD =~ /([^:]+)$/; # How odd - we use $GT::AutoLoader::AUTOLOAD, even though this is run in some other package
|
||||
|
||||
if ($COMPILE = \%{$pkg . '::COMPILE'}) {
|
||||
if (defined $COMPILE->{$func}) {
|
||||
for (keys %LOG) { $LOG{$_}->($pkg, $func, 'COMPILE') }
|
||||
|
||||
_compile($COMPILE, $pkg, $func);
|
||||
|
||||
$AUTOLOAD = '';
|
||||
|
||||
goto &{"$pkg\::$func"};
|
||||
}
|
||||
}
|
||||
|
||||
if ($opts{NEXT}) {
|
||||
my ($pack, $func) = $opts{NEXT} =~ /(?:(.+)::)?([^:]+?)$/;
|
||||
$pack ||= $pkg;
|
||||
${$pack . '::AUTOLOAD'} = $AUTOLOAD;
|
||||
my $next = "$pack\::$func";
|
||||
$AUTOLOAD = '';
|
||||
goto &$next;
|
||||
}
|
||||
|
||||
# It doesn't exist in %COMPILE, which means we have to look through @ISA for another AUTOLOAD to pass this to
|
||||
if (my @inh = @{"$pkg\::ISA"}) {
|
||||
while (my $inh = shift @inh) {
|
||||
my $al = $inh . '::AUTOLOAD';
|
||||
if (defined &$al) {
|
||||
$$al = "$pkg\::$func"; # Sets $Other::Package::AUTOLOAD
|
||||
$AUTOLOAD = '';
|
||||
goto &$al;
|
||||
}
|
||||
elsif (my @isa = @{$inh . '::ISA'}) {
|
||||
unshift @inh, @isa;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my ($file, $line) = (caller)[1,2];
|
||||
$AUTOLOAD = '';
|
||||
die "$pkg ($$, GT::AutoLoader): Unknown method '$func' called at $file line $line.\n";
|
||||
};
|
||||
|
||||
my $compile = "$pkg\::COMPILE";
|
||||
*$compile = \%$compile; # Implements "use vars qw/%COMPILE/" for you
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
if ($^C) {
|
||||
eval <<'CHECK';
|
||||
sub CHECK {
|
||||
# ------------------------------------------------------------------------------
|
||||
# In Perl 5.6+ this allows you to do: perl -cMMy::Module -e0 to make sure all
|
||||
# your %COMPILE subs compile. In versions of Perl prior to 5.6, this is simply
|
||||
# treated as a sub named "CHECK", which is never called. $^C is also 5.6+
|
||||
# specific - whether or not you are running under "-c"
|
||||
compile_all();
|
||||
}
|
||||
CHECK
|
||||
}
|
||||
}
|
||||
|
||||
sub compile_all {
|
||||
my @pkg = @_;
|
||||
if (@pkg) {
|
||||
@pkg = grep +($PACKAGES{$_} or (warn "$_ is not loaded, does not use GT::AutoLoader, or is not a valid package" and 0)), @pkg;
|
||||
@pkg or die "No valid packages passed to compile_all()!";
|
||||
}
|
||||
else {
|
||||
@pkg = keys %PACKAGES;
|
||||
}
|
||||
|
||||
for my $pkg (@pkg) {
|
||||
my $COMPILE = \%{$pkg . '::COMPILE'} or next;
|
||||
for my $func (keys %$COMPILE) {
|
||||
_compile($COMPILE, $pkg, $func) if $COMPILE->{$func};
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _compile {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Compiles a subroutine from a module's %COMPILE into the module's package.
|
||||
# die()s if the subroutine cannot compile or still does not exist after
|
||||
# compiling. Takes three arguments: A reference to the packages %COMPILE hash,
|
||||
# the package, and the name of the function to load.
|
||||
#
|
||||
my ($COMPILE, $pkg, $func) = @_;
|
||||
|
||||
my $linenum = ($COMPILE->{$func} =~ s/^(\d+)//) ? $1+1 : 0;
|
||||
eval "package $pkg;\n#line $linenum$pkg\::$func\n$COMPILE->{$func}";
|
||||
if ($@) { die "Unable to load $pkg\::$func: $@" }
|
||||
if (not defined &{"$pkg\::$func"}) {
|
||||
die "Unable to load $pkg\::$func: Subroutine did not compile correctly (possible bad name).";
|
||||
}
|
||||
|
||||
undef $COMPILE->{$func}; # Leave the key in the compile hash so that things can test to see if it was defined in the compile hash
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::AutoLoader - load subroutines on demand
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package GT::Module;
|
||||
use GT::AutoLoader; # You now have an AUTOLOAD subroutine that will check for entries in %COMPILE
|
||||
|
||||
or
|
||||
|
||||
package GT::OtherModule;
|
||||
use GT::AutoLoader(NAME => '_AUTOLOAD'); # Import AUTOLOAD as _AUTOLOAD, define our own AUTOLOAD
|
||||
sub AUTOLOAD {
|
||||
...
|
||||
goto &_AUTOLOAD;
|
||||
}
|
||||
|
||||
then:
|
||||
|
||||
$COMPILE{sub} = __LINE__ . <<'END_OF_SUB';
|
||||
sub method_name {
|
||||
...
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B<GT::AutoLoader> module works as a way to speed up your code. Currently,
|
||||
the only thing it does is scan for a %COMPILE hash in your package. If it finds
|
||||
it, it looks for the subroutine you called, and if found compiles and runs it.
|
||||
|
||||
If unable to find a subroutine to compile in %COMPILE, B<GT::AutoLoader> will
|
||||
scan your inheritance tree (@ISA) for another AUTOLOAD subroutine to pass this
|
||||
off to. If there isn't any, a fatal error occurs.
|
||||
|
||||
To use B<GT::AutoLoader>, in its standard behaviour, simply put:
|
||||
C<use GT::AutoLoader;> in your module. When you use GT::AutoLoader, two things
|
||||
will happen. First, an C<AUTOLOAD> subroutine will be imported into your
|
||||
namespace that will automatically compile your subroutines only when they are
|
||||
needed, thus speeding up compile time. Secondly, a %COMPILE hash will be defined
|
||||
in your package, eliminating the need for you to: use vars qw/%COMPILE/;
|
||||
|
||||
=head1 USE
|
||||
|
||||
You can pass options to GT::AutoLoader to change the behaviour of the module.
|
||||
Currently, logging is the only option, however more options (perhaps including
|
||||
a different compiling scheme) will be added at some future point.
|
||||
|
||||
Options are specified as import() arguments. For example:
|
||||
|
||||
use GT::AutoLoader(OPTION => "value");
|
||||
|
||||
=over 4
|
||||
|
||||
=item NAME
|
||||
|
||||
If you want to import the autoload subroutine as something other than
|
||||
'Package::AUTOLOAD', the 'NAME' option should be used. Its value is the name
|
||||
to import as. For example, to import a GT::AutoLoader AUTOLOAD named _AUTOLOAD
|
||||
(this is useful when declaring your own AUTOLOAD behaviour, but still using
|
||||
GT::AutoLoader's behaviour as a fallback), you would do something like:
|
||||
|
||||
use GT::AutoLoader(NAME => '_AUTOLOAD');
|
||||
|
||||
=item LOG
|
||||
|
||||
Takes a code reference as its value. The code reference will be called three
|
||||
arguments - the package name, the name of the function, and the autoload method
|
||||
(Currently only 'COMPILE'). Note that this will be called for ALL autoloaded
|
||||
subroutines, not just the ones in your package.
|
||||
|
||||
WARNING - you cannot put code in your log that relies on autoloaded methods -
|
||||
you'll end up throwing the program into an infinite loop.
|
||||
|
||||
For example, to get a line of debugging after each subroutine is compiled, you
|
||||
could C<use GT::AutoLoader> like this:
|
||||
|
||||
use GT::AutoLoader(LOG => sub {
|
||||
print "Compiled $_[1] in package $_[0]\n"
|
||||
});
|
||||
|
||||
=item NEXT
|
||||
|
||||
Normally, GT::AutoLoader will look for another AUTOLOAD to call in your
|
||||
package's @ISA inheritance tree. You can alter this behaviour and tell
|
||||
GT::AutoLoader what to call next using the NEXT option.
|
||||
|
||||
For example, if you have a sub _AUTOLOAD { } that you wanted to call if the
|
||||
method isn't found by GT::AutoLoader, you would use GT::AutoLoader like this:
|
||||
|
||||
use GT::AutoLoader(NEXT => 'Package::Name::_AUTOLOAD');
|
||||
|
||||
The _AUTOLOAD function in your package will now be called if GT::AutoLoader
|
||||
can't load the method on its own. $AUTOLOAD will be set for you in whichever
|
||||
package the function you provide is in. Note that if you simply want to use an
|
||||
inherited AUTOLOAD, you B<should not> use this option; GT::AutoLoader will
|
||||
handle that just fine on its own.
|
||||
|
||||
You may omit the package (Package::Name::) if the function is in your current
|
||||
package.
|
||||
|
||||
=back
|
||||
|
||||
=head1 compile_all
|
||||
|
||||
A function exists in GT::AutoLoader to compile all %COMPILE-subroutines. By
|
||||
default (without arguments) compile_all() compiles every %COMPILE-subroutine in
|
||||
every package that has used GT::AutoLoader. You can, however, pass in a list of
|
||||
packages which compile_all() will check instead of compiling everything. Note
|
||||
that GT::AutoLoader will only compile %COMPILE-subroutines in packages that
|
||||
have used GT::AutoLoader, so if you specify package "Foo", but "Foo" hasn't
|
||||
used GT::AutoLoader, it will be ignored.
|
||||
|
||||
You can do something like:
|
||||
|
||||
GT::AutoLoader::compile_all(__PACKAGE__) if MOD_PERL;
|
||||
|
||||
to have a GT::AutoLoader compile every %COMPILE-subroutine in the current
|
||||
package automatically under mod_perl, or you could add this code to your
|
||||
mod_perl startup file or test script:
|
||||
|
||||
GT::AutoLoader::compile_all;
|
||||
|
||||
Test scripts should definately use compile_all() to ensure that all subroutines
|
||||
compile correctly!
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
None.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Due to the nature of Perl's AUTOLOAD handling, you must take care when using
|
||||
GT::AutoLoader in a subclass. In short, subclassed methods B<MUST NOT> be put
|
||||
into the %COMPILE hash.
|
||||
|
||||
The problem is that since the subroutine does not exist in the package, Perl,
|
||||
while decending the inheritance tree, will not see it but will probably see the
|
||||
parent's method (unless nothing else has called the method, but you should
|
||||
never count on that), and call it rather than looking for your package's
|
||||
AUTOLOAD.
|
||||
|
||||
This isn't to say that subclasses cannot use AUTOLOAD - just that subclasses
|
||||
cannot use autoloaded methods (%COMPILE-subroutines) if a method of the same
|
||||
name exists in the parent class. Autoloaded function calls are not affected.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::Base>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: AutoLoader.pm,v 1.13 2005/03/21 06:57:58 jagerman Exp $
|
||||
|
||||
=cut
|
||||
949
site/glist/lib/GT/Base.pm
Normal file
949
site/glist/lib/GT/Base.pm
Normal file
@@ -0,0 +1,949 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Base
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Base.pm,v 1.132 2005/06/22 19:59:25 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base module that handles common functions like initilization,
|
||||
# debugging, etc. Should not be used except as a base class.
|
||||
#
|
||||
|
||||
package GT::Base;
|
||||
# ===============================================================
|
||||
require 5.004; # We need perl 5.004 for a lot of the OO features.
|
||||
|
||||
use strict qw/vars subs/; # No refs as we do some funky stuff.
|
||||
use vars qw/$AUTOLOAD $DEBUG $VERSION $ATTRIB_CACHE %ERRORS @EXPORT_OK %EXPORT_TAGS @ISA/;
|
||||
use GT::AutoLoader(NEXT => 'GT::Base::_AUTOLOAD');
|
||||
use Exporter();
|
||||
|
||||
# We need to inherit from Exporter for ->require_version support
|
||||
@ISA = qw/Exporter/;
|
||||
|
||||
BEGIN {
|
||||
if ($ENV{MOD_PERL}) {
|
||||
eval { require mod_perl2 } or eval { require mod_perl };
|
||||
}
|
||||
require CGI::SpeedyCGI if $CGI::SpeedyCGI::i_am_speedy or $CGI::SpeedyCGI::_i_am_speedy;
|
||||
}
|
||||
use constants
|
||||
MOD_PERL => $ENV{MOD_PERL} ? $mod_perl2::VERSION || $mod_perl::VERSION : 0,
|
||||
SPEEDY => $CGI::SpeedyCGI::_i_am_speedy || $CGI::SpeedyCGI::i_am_speedy ? $CGI::SpeedyCGI::VERSION : 0;
|
||||
use constants
|
||||
PERSIST => MOD_PERL || SPEEDY;
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.132 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIB_CACHE = {};
|
||||
%ERRORS = (
|
||||
MKDIR => "Could not make directory '%s': %s",
|
||||
OPENDIR => "Could not open directory '%s': %s",
|
||||
RMDIR => "Could not remove directory '%s': %s",
|
||||
CHMOD => "Could not chmod '%s': %s",
|
||||
UNLINK => "Could not unlink '%s': %s",
|
||||
READOPEN => "Could not open '%s' for reading: %s",
|
||||
WRITEOPEN => "Could not open '%s' for writing: %s",
|
||||
OPEN => "Could not open '%s': %s",
|
||||
BADARGS => "Wrong argument passed to this subroutine. %s"
|
||||
);
|
||||
@EXPORT_OK = qw/MOD_PERL SPEEDY PERSIST $MOD_PERL $SPEEDY $PERSIST/;
|
||||
%EXPORT_TAGS = (
|
||||
all => \@EXPORT_OK,
|
||||
persist => [qw/MOD_PERL SPEEDY PERSIST/]
|
||||
);
|
||||
|
||||
# These three are for backwards-compatibility with what GT::Base used to
|
||||
# export; new code should import and use the constants of the same name.
|
||||
use vars qw/$MOD_PERL $SPEEDY $PERSIST/;
|
||||
$MOD_PERL = MOD_PERL;
|
||||
$SPEEDY = SPEEDY;
|
||||
$PERSIST = PERSIST;
|
||||
|
||||
sub new {
|
||||
# -------------------------------------------------------
|
||||
# Create a base object and use set or init to initilize anything.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
|
||||
# Create self with our debug value.
|
||||
my $self = { _debug => defined ${"$class\:\:DEBUG"} ? ${"$class\:\:DEBUG"} : $DEBUG };
|
||||
bless $self, $class;
|
||||
$self->debug("Created new $class object.") if $self->{_debug} > 2;
|
||||
|
||||
# Set initial attributes, and then run init function or call set.
|
||||
$self->reset;
|
||||
if ($self->can('init')) {
|
||||
$self->init(@_);
|
||||
}
|
||||
else {
|
||||
$self->set(@_) if (@_);
|
||||
}
|
||||
|
||||
if (index($self, 'HASH') != -1) {
|
||||
$self->{_debug} = $self->{debug} if $self->{debug};
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# -------------------------------------------------------
|
||||
# Object is nuked.
|
||||
#
|
||||
(index($_[0], 'HASH') > -1) or return;
|
||||
if ($_[0]->{_debug} and $_[0]->{_debug} > 2) {
|
||||
my ($package, $filename, $line) = caller;
|
||||
$_[0]->debug("Destroyed $_[0] in package $package at $filename line $line.");
|
||||
}
|
||||
}
|
||||
|
||||
sub _AUTOLOAD {
|
||||
# -------------------------------------------------------
|
||||
# We use autoload to provide an accessor/setter for all
|
||||
# attributes.
|
||||
#
|
||||
my ($self, $param) = @_;
|
||||
my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/;
|
||||
|
||||
# If this is a known attribute, return/set it and save the function
|
||||
# to speed up future calls.
|
||||
my $autoload_attrib = 0;
|
||||
if (ref $self and index($self, 'HASH') != -1 and exists $self->{$attrib} and not exists $COMPILE{$attrib}) {
|
||||
$autoload_attrib = 1;
|
||||
}
|
||||
else {
|
||||
# Class method possibly.
|
||||
unless (ref $self) {
|
||||
my $attribs = $ATTRIB_CACHE->{$self} || _get_attribs($self);
|
||||
if (exists $attribs->{$attrib}) {
|
||||
$autoload_attrib = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
# This is an accessor, create a function for it.
|
||||
if ($autoload_attrib) {
|
||||
*{$AUTOLOAD} = sub {
|
||||
unless (ref $_[0]) { # Class Method
|
||||
my $attribs = $ATTRIB_CACHE->{$_[0]} || _get_attribs($_[0]);
|
||||
if (@_ > 1) {
|
||||
$_[0]->debug("Setting base attribute '$attrib' => '$_[1]'.") if defined ${$_[0] . '::DEBUG'} and ${$_[0] . '::DEBUG'} > 2;
|
||||
$ATTRIB_CACHE->{$_[0]}->{$attrib} = $_[1];
|
||||
}
|
||||
return $ATTRIB_CACHE->{$_[0]}->{$attrib};
|
||||
}
|
||||
if (@_ > 1) { # Instance Method
|
||||
$_[0]->debug("Setting '$attrib' => '$_[1]'.") if $_[0]->{_debug} and $_[0]->{_debug} > 2;
|
||||
$_[0]->{$attrib} = $_[1];
|
||||
}
|
||||
return $_[0]->{$attrib};
|
||||
};
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
# Otherwise we have an error, let's help the user out and try to
|
||||
# figure out what they were doing.
|
||||
_generate_fatal($self, $attrib, $param);
|
||||
}
|
||||
|
||||
sub set {
|
||||
# -------------------------------------------------------
|
||||
# Set one or more attributes.
|
||||
#
|
||||
return unless (@_);
|
||||
if ( !ref $_[0]) { class_set(@_); }
|
||||
else {
|
||||
my $self = shift;
|
||||
my $p = $self->common_param(@_) or return $self->error('BADARGS', 'FATAL', "Argument to set must be either hash, hash ref, array, array ref or CGI object.");
|
||||
my $attribs = $ATTRIB_CACHE->{ref $self} || _get_attribs(ref $self);
|
||||
my $f = 0;
|
||||
$self->{_debug} = $p->{debug} || 0 if exists $p->{debug};
|
||||
foreach my $attrib (keys %$attribs) {
|
||||
next unless exists $p->{$attrib};
|
||||
$self->debug("Setting '$attrib' to '${$p}{$attrib}'.") if $self->{_debug} and $self->{_debug} > 2;
|
||||
$self->{$attrib} = $p->{$attrib};
|
||||
$f++;
|
||||
}
|
||||
return $f;
|
||||
}
|
||||
}
|
||||
|
||||
sub common_param {
|
||||
# -------------------------------------------------------
|
||||
# Expects to find $self, followed by one or more arguments of
|
||||
# unknown types. Converts them to hash refs.
|
||||
#
|
||||
shift;
|
||||
my $out = {};
|
||||
return $out unless @_ and defined $_[0];
|
||||
CASE: {
|
||||
(ref $_[0] eq 'HASH') and do { $out = shift; last CASE };
|
||||
(UNIVERSAL::can($_[0], 'get_hash')) and do { $out = $_[0]->get_hash; last CASE };
|
||||
(UNIVERSAL::can($_[0], 'param')) and do { foreach ($_[0]->param) { my @vals = $_[0]->param($_); $out->{$_} = (@vals > 1) ? \@vals : $vals[0]; } last CASE };
|
||||
(defined $_[0] and not @_ % 2) and do { $out = {@_}; last CASE };
|
||||
return;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub reset {
|
||||
# -------------------------------------------------------
|
||||
# Resets all attribs in $self.
|
||||
#
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
my $attrib = $ATTRIB_CACHE->{$class} || _get_attribs($class);
|
||||
|
||||
# Deep copy hash and array refs only.
|
||||
while (my ($k, $v) = each %$attrib) {
|
||||
unless (ref $v) {
|
||||
$self->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$self->{$k} = {};
|
||||
foreach my $k1 (keys %{$attrib->{$k}}) {
|
||||
$self->{$k}->{$k1} = $attrib->{$k}->{$k1};
|
||||
}
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$self->{$k} = [];
|
||||
foreach my $v1 (@{$attrib->{$k}}) {
|
||||
push @{$self->{$k}}, $v1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{$k} = $v;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _get_attribs {
|
||||
# -------------------------------------------------------
|
||||
# Searches through ISA and returns this packages attributes.
|
||||
#
|
||||
my $class = shift;
|
||||
my $attrib = defined ${"$class\:\:ATTRIBS"} ? ${"$class\:\:ATTRIBS"} : {};
|
||||
my @pkg_isa = defined @{"$class\:\:ISA"} ? @{"$class\:\:ISA"} : ();
|
||||
|
||||
foreach my $pkg (@pkg_isa) {
|
||||
next if $pkg eq 'Exporter'; # Don't mess with Exporter.
|
||||
next if $pkg eq 'GT::Base';
|
||||
my $fattrib = defined ${"${pkg}::ATTRIBS"} ? ${"${pkg}::ATTRIBS"} : next;
|
||||
foreach (keys %{$fattrib}) {
|
||||
$attrib->{$_} = $fattrib->{$_} unless exists $attrib->{$_};
|
||||
}
|
||||
}
|
||||
$ATTRIB_CACHE->{$class} = $attrib;
|
||||
return $attrib;
|
||||
}
|
||||
|
||||
$COMPILE{debug} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub debug {
|
||||
# -------------------------------------------------------
|
||||
# Displays a debugging message.
|
||||
#
|
||||
my ($self, $msg) = @_;
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
# Add line numbers if asked for.
|
||||
if ($msg !~ /\r?\n$/) {
|
||||
my ($package, $file, $line) = caller;
|
||||
$msg .= " at $file line $line.\n";
|
||||
}
|
||||
# Remove windows linefeeds (breaks unix terminals).
|
||||
$msg =~ s/\r//g unless ($^O eq 'MSWin32');
|
||||
$msg =~ s/\n(?=[^ ])/\n\t/g;
|
||||
print STDERR "$pkg ($$): $msg";
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{debug_level} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub debug_level {
|
||||
# -------------------------------------------------------
|
||||
# Set the debug level for either the class or object.
|
||||
#
|
||||
if (ref $_[0]) {
|
||||
$_[0]->{_debug} = shift if @_ > 1;
|
||||
return $_[0]->{_debug};
|
||||
}
|
||||
else {
|
||||
my $pkg = shift;
|
||||
if (@_) {
|
||||
my $level = shift;
|
||||
${"${pkg}::DEBUG"} = $level;
|
||||
}
|
||||
return ${"${pkg}::DEBUG"};
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{warn} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub warn { shift->error(shift, WARN => @_) }
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{fatal} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub fatal { shift->error(shift, FATAL => @_) }
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{error} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub error {
|
||||
# -------------------------------------------------------
|
||||
# Error handler.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($msg, $level, @args) = @_;
|
||||
my $pkg = ref $self || $self;
|
||||
$level = defined $level ? $level : 'FATAL';
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
|
||||
# Load the ERROR messages.
|
||||
$self->set_basic_errors;
|
||||
|
||||
# err_pkg stores the package just before the users program for displaying where the error was raised
|
||||
# think simplified croak.
|
||||
my $err_pkg = $pkg;
|
||||
if ($is_hash) {
|
||||
$err_pkg = defined $self->{_err_pkg} ? $self->{_err_pkg} : $pkg;
|
||||
}
|
||||
|
||||
# initilize vars to silence -w warnings.
|
||||
# msg_pkg stores which package error messages are stored, defaults to self, but doesn't have to be.
|
||||
${$pkg . '::ERROR_MESSAGE'} ||= '';
|
||||
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
||||
my $debug = $is_hash ? $self->{_debug} : ${$pkg . "::DEBUG"};
|
||||
|
||||
# cls_err stores the actual error hash (error_code => error_string). Initilize to prevent -w
|
||||
# warnings.
|
||||
${$msg_pkg . '::ERRORS'} ||= {};
|
||||
${$pkg . '::ERRORS'} ||= {};
|
||||
my $cls_err = ${$msg_pkg . '::ERRORS'};
|
||||
my $pkg_err = ${$pkg . '::ERRORS'} || $pkg;
|
||||
my %messages = %$cls_err;
|
||||
foreach (keys %$pkg_err) { $messages{$_} = $pkg_err->{$_}; }
|
||||
|
||||
# Return current error if not called with arguments.
|
||||
if ($is_hash) {
|
||||
$self->{_error} ||= [];
|
||||
if (@_ == 0) {
|
||||
my @err = @{$self->{_error}} ? @{$self->{_error}} : (${$msg_pkg . "::error"});
|
||||
return wantarray ? @err : defined($err[0]) ? $err[0] : undef;
|
||||
}
|
||||
}
|
||||
elsif (@_ == 0) {
|
||||
return ${$msg_pkg . '::errcode'};
|
||||
}
|
||||
|
||||
# Set a subroutine that will clear out the error class vars, and self vars under mod_perl.
|
||||
$self->register_persistent_cleanup(sub { $self->_cleanup_obj($msg_pkg, $is_hash) });
|
||||
|
||||
# store the error code.
|
||||
${$msg_pkg . '::errcode'} ||= '';
|
||||
${$msg_pkg . '::errcode'} = $msg;
|
||||
${$msg_pkg . '::errargs'} ||= '';
|
||||
if ($is_hash) {
|
||||
$self->{_errcode} = $msg;
|
||||
$self->{_errargs} = @args ? [@args] : [];
|
||||
}
|
||||
|
||||
# format the error message.
|
||||
if (keys %messages) {
|
||||
if (exists $messages{$msg}) {
|
||||
$msg = $messages{$msg};
|
||||
}
|
||||
$msg = $msg->(@args) if ref $msg eq 'CODE'; # Pass the sprintf arguments to the code ref
|
||||
$msg = @args ? sprintf($msg, map { defined $_ ? $_ : '[undefined]' } @args) : $msg;
|
||||
|
||||
$msg =~ s/\r\n?/\n/g unless $^O eq 'MSWin32';
|
||||
$msg =~ s/\n(?=[^ ])/\n\t/g;
|
||||
}
|
||||
|
||||
# set the formatted error to $msg_pkg::error.
|
||||
push @{$self->{_error}}, $msg if ($is_hash);
|
||||
|
||||
# If we have a fatal error, then we either send it to error_handler if
|
||||
# the user has a custom handler, or print our message and die.
|
||||
|
||||
# Initialize $error to silence -w warnings.
|
||||
${$msg_pkg . '::error'} ||= '';
|
||||
if (uc $level eq 'FATAL') {
|
||||
${$msg_pkg . '::error'} = ref ${$msg_pkg . '::error'} ? _format_err($err_pkg, \$msg) : _format_err($err_pkg, $msg);
|
||||
|
||||
die(_format_err($err_pkg, $msg)) if in_eval();
|
||||
if (exists($SIG{__DIE__}) and $SIG{__DIE__}) {
|
||||
die _format_err($err_pkg, $msg);
|
||||
}
|
||||
else {
|
||||
print STDERR _format_err($err_pkg, $msg);
|
||||
die "\n";
|
||||
}
|
||||
}
|
||||
# Otherwise we set the error message, and print it if we are in debug mode.
|
||||
elsif (uc $level eq 'WARN') {
|
||||
${$msg_pkg . '::error'} = ref ${$msg_pkg . '::error'} ? \$msg : $msg;
|
||||
my $warning = _format_err($err_pkg, $msg);
|
||||
$debug and (
|
||||
$SIG{__WARN__}
|
||||
? CORE::warn $warning
|
||||
: print STDERR $warning
|
||||
);
|
||||
$debug and $debug > 1 and (
|
||||
$SIG{__WARN__}
|
||||
? CORE::warn stack_trace('GT::Base',1)
|
||||
: print STDERR stack_trace('GT::Base',1)
|
||||
);
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_cleanup_obj} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _cleanup_obj {
|
||||
# -------------------------------------------------------
|
||||
# Cleans up the self object under a persitant env.
|
||||
#
|
||||
my ($self, $msg_pkg, $is_hash) = @_;
|
||||
|
||||
${$msg_pkg . '::errcode'} = undef;
|
||||
${$msg_pkg . '::error'} = undef;
|
||||
${$msg_pkg . '::errargs'} = undef;
|
||||
if ($is_hash) {
|
||||
defined $self and $self->{_errcode} = undef;
|
||||
defined $self and $self->{_error} = undef;
|
||||
defined $self and $self->{_errargs} = undef;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{errcode} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub errcode {
|
||||
# -------------------------------------------------------
|
||||
# Returns the last error code generated.
|
||||
#
|
||||
my $self = shift;
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
my $pkg = ref $self || $self;
|
||||
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
||||
if (ref $self and $is_hash) {
|
||||
return $self->{_errcode};
|
||||
}
|
||||
else {
|
||||
return ${$msg_pkg . '::errcode'};
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{errargs} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub errargs {
|
||||
# -------------------------------------------------------
|
||||
# Returns the arguments from the last error. In list
|
||||
# context returns an array, in scalar context returns
|
||||
# an array reference.
|
||||
#
|
||||
my $self = shift;
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
my $pkg = ref $self || $self;
|
||||
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
||||
my $ret = [];
|
||||
if (ref $self and $is_hash) {
|
||||
$self->{_errargs} ||= [];
|
||||
$ret = $self->{_errargs};
|
||||
}
|
||||
else {
|
||||
${$msg_pkg . '::errcode'} ||= [];
|
||||
$ret = ${$msg_pkg . '::errargs'};
|
||||
}
|
||||
return wantarray ? @{$ret} : $ret;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{clear_errors} = __LINE__ . <<'END_OF_SUB';
|
||||
sub clear_errors {
|
||||
# -------------------------------------------------------
|
||||
# Clears the error stack
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{_error} = [];
|
||||
$self->{_errargs} = [];
|
||||
$self->{_errcode} = undef;
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{set_basic_errors} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub set_basic_errors {
|
||||
# -------------------------------------------------------
|
||||
# Sets basic error messages commonly used.
|
||||
#
|
||||
my $self = shift;
|
||||
my $class = ref $self || $self;
|
||||
if (${$class . '::ERROR_MESSAGE'}) {
|
||||
$class = ${$class . '::ERROR_MESSAGE'};
|
||||
}
|
||||
${$class . '::ERRORS'} ||= {};
|
||||
my $err = ${$class . '::ERRORS'};
|
||||
for my $key (keys %ERRORS) {
|
||||
$err->{$key} = $ERRORS{$key} unless exists $err->{$key};
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{whatis} = __LINE__ . <<'END_OF_SUB';
|
||||
sub whatis {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes a package name and returns a list of all packages inherited from, in
|
||||
# the order they would be checked by Perl, _including_ the package passed in.
|
||||
# The argument may be an object or a string, and this method can be called as
|
||||
# a function, class method, or instance method. When called as a method, the
|
||||
# argument is optional - if omitted, the class name will be used.
|
||||
# Duplicate classes are _not_ included.
|
||||
#
|
||||
shift if @_ > 1;
|
||||
my $class = shift;
|
||||
$class = ref $class if ref $class;
|
||||
my @isa = $class;
|
||||
my %found;
|
||||
my $pstash;
|
||||
for (my $c = 0; $c < @isa; $c++) {
|
||||
my $is = $isa[$c];
|
||||
my @parts = split /::/, $is;
|
||||
my $pstash = $::{shift(@parts) . "::"};
|
||||
while (defined $pstash and @parts) {
|
||||
$pstash = $pstash->{shift(@parts) . "::"};
|
||||
}
|
||||
if (defined $pstash and $pstash->{ISA} and my @is = @{*{\$pstash->{ISA}}{ARRAY}}) {
|
||||
splice @isa, $c + 1, 0,
|
||||
grep $_ eq $class
|
||||
? die "Recursive inheritance detected in package $class"
|
||||
: !$found{$_}++,
|
||||
@is;
|
||||
}
|
||||
}
|
||||
@isa
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{in_eval} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub in_eval {
|
||||
# -------------------------------------------------------
|
||||
# Current perl has a variable for it, old perl, we need to look
|
||||
# through the stack trace. Ugh.
|
||||
#
|
||||
my $ineval;
|
||||
if ($] >= 5.005 and !MOD_PERL) { $ineval = defined($^S) ? $^S : (stack_trace('GT::Base',1) =~ /\(eval\)/) }
|
||||
elsif (MOD_PERL) {
|
||||
my $stack = stack_trace('GT::Base', 1);
|
||||
$ineval = $stack =~ m{
|
||||
\(eval\)
|
||||
(?!
|
||||
\s+called\ at\s+
|
||||
(?:
|
||||
/dev/null
|
||||
|
|
||||
-e
|
||||
|
|
||||
/\S*/(?:Apache2?|ModPerl)/(?:Registry(?:Cooker)?|PerlRun)\.pm
|
||||
|
|
||||
PerlHandler\ subroutine\ `(?:Apache2?|ModPerl)::Registry
|
||||
)
|
||||
)
|
||||
}x;
|
||||
}
|
||||
else {
|
||||
my $stack = stack_trace('GT::Base', 1);
|
||||
$ineval = $stack =~ /\(eval\)/;
|
||||
}
|
||||
return $ineval;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{register_persistent_cleanup} = __LINE__ . <<'END_OF_SUB';
|
||||
sub register_persistent_cleanup {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes a code reference and registers it for cleanup under mod_perl and
|
||||
# SpeedyCGI. Has no effect when not under those environments.
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
ref(my $code = shift) eq 'CODE'
|
||||
or __PACKAGE__->fatal(BADARGS => 'Usage: GT::Base->register_persistent_cleanup($coderef)');
|
||||
|
||||
if (MOD_PERL and MOD_PERL >= 1.999022) { # Final mod_perl 2 API
|
||||
require Apache2::ServerUtil;
|
||||
if (Apache2::ServerUtil::restart_count() != 1) {
|
||||
require Apache2::RequestUtil;
|
||||
require APR::Pool;
|
||||
Apache2::RequestUtil->request->pool->cleanup_register($code);
|
||||
}
|
||||
}
|
||||
elsif (MOD_PERL and MOD_PERL >= 1.99) { # mod_perl 2 API prior to 2.0.0-RC5
|
||||
require Apache2;
|
||||
require Apache::ServerUtil;
|
||||
if (Apache::ServerUtil::restart_count() != 1) {
|
||||
require APR::Pool;
|
||||
Apache->request->pool->cleanup_register($code);
|
||||
}
|
||||
}
|
||||
elsif (MOD_PERL and $Apache::Server::Starting != 1) {
|
||||
require Apache;
|
||||
Apache->request->register_cleanup($code);
|
||||
}
|
||||
elsif (SPEEDY) {
|
||||
CGI::SpeedyCGI->new->register_cleanup($code);
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{class_set} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub class_set {
|
||||
# -------------------------------------------------------
|
||||
# Set the class init attributes.
|
||||
#
|
||||
my $pkg = shift;
|
||||
my $attribs = $ATTRIB_CACHE->{$pkg} || _get_attribs($pkg);
|
||||
|
||||
if (ref $attribs ne 'HASH') { return; }
|
||||
|
||||
# Figure out what we were passed in.
|
||||
my $out = GT::Base->common_param(@_) or return;
|
||||
|
||||
# Set the attribs.
|
||||
foreach (keys %$out) {
|
||||
exists $attribs->{$_} and ($attribs->{$_} = $out->{$_});
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{attrib} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub attrib {
|
||||
# -------------------------------------------------------
|
||||
# Returns a list of attributes.
|
||||
#
|
||||
my $class = ref $_[0] || $_[0];
|
||||
my $attribs = $ATTRIB_CACHE->{$class} || _get_attribs($class);
|
||||
return wantarray ? %$attribs : $attribs;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{stack_trace} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub stack_trace {
|
||||
# -------------------------------------------------------
|
||||
# If called with arguments, returns stack trace, otherwise
|
||||
# prints to stdout/stderr depending on whether in cgi or not.
|
||||
#
|
||||
my $pkg = shift || 'Unknown';
|
||||
my $raw = shift || 0;
|
||||
my $rollback = shift || 3;
|
||||
my ($ls, $spc, $fh);
|
||||
if ($raw) {
|
||||
if (defined $ENV{REQUEST_METHOD}) {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
}
|
||||
else {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
}
|
||||
}
|
||||
elsif (defined $ENV{REQUEST_METHOD}) {
|
||||
print STDOUT "Content-type: text/html\n\n";
|
||||
$ls = '<br>';
|
||||
$spc = ' ';
|
||||
$fh = \*STDOUT;
|
||||
}
|
||||
else {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
$fh = \*STDERR;
|
||||
}
|
||||
my $out = $raw ? '' : "${ls}STACK TRACE$ls======================================$ls";
|
||||
{
|
||||
package DB;
|
||||
my $i = $rollback;
|
||||
local $@;
|
||||
while (my ($file, $line, $sub, $args) = (caller($i++))[1,2,3,4]) {
|
||||
my @args;
|
||||
for (@DB::args) {
|
||||
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
|
||||
my $print = $@ ? \$_ : $_;
|
||||
push @args, defined $print ? $print : '[undef]';
|
||||
}
|
||||
if (@args) {
|
||||
my $args = join ", ", @args;
|
||||
$args =~ s/\n\s*\n/\n/g;
|
||||
$args =~ s/\n/\n$spc$spc$spc$spc/g;
|
||||
$out .= qq!$pkg ($$): $sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!;
|
||||
}
|
||||
else {
|
||||
$out .= qq!$pkg ($$): $sub called at $file line $line with no arguments.$ls!;
|
||||
}
|
||||
}
|
||||
}
|
||||
$raw ? return $out : print $fh $out;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_format_err} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _format_err {
|
||||
# -------------------------------------------------------
|
||||
# Formats an error message for output.
|
||||
#
|
||||
my ($pkg, $msg) = @_;
|
||||
my ($file, $line) = get_file_line($pkg);
|
||||
return "$pkg ($$): $msg at $file line $line.\n";
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{get_file_line} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub get_file_line {
|
||||
# -------------------------------------------------------
|
||||
# Find out what line error was generated in.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my $pkg = shift || scalar caller;
|
||||
my %pkg;
|
||||
for (whatis($pkg)) {
|
||||
$pkg{$_}++;
|
||||
}
|
||||
my ($i, $last_pkg);
|
||||
while (my $pack = caller($i++)) {
|
||||
if ($pkg{$pack}) {
|
||||
$last_pkg = $i;
|
||||
}
|
||||
elsif ($last_pkg) {
|
||||
last; # We're one call back beyond the package being looked for
|
||||
}
|
||||
}
|
||||
unless (defined $last_pkg) {
|
||||
# You messed up by trying to pass in a package that was never called
|
||||
GT::Base->fatal("get_file_line() called with an invalid package ($pkg)");
|
||||
}
|
||||
(undef, my ($file, $line)) = caller($last_pkg);
|
||||
|
||||
return ($file, $line);
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_generate_fatal} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _generate_fatal {
|
||||
# -------------------------------------------------------------------
|
||||
# Generates a fatal error caused by misuse of AUTOLOAD.
|
||||
#
|
||||
my ($self, $attrib, $param) = @_;
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
my @poss;
|
||||
if (UNIVERSAL::can($self, 'debug_level') and $self->debug_level) {
|
||||
my @class = @{$pkg . '::ISA'} || ();
|
||||
unshift @class, $pkg;
|
||||
for (@class) {
|
||||
my @subs = keys %{$_ . '::'};
|
||||
my %compiled = %{$_ . '::COMPILE'};
|
||||
for (keys %compiled) {
|
||||
push @subs, $_ if defined $compiled{$_};
|
||||
}
|
||||
for my $routine (@subs) {
|
||||
next if $attrib eq $routine;
|
||||
next unless $self;
|
||||
next unless defined $compiled{$_} or UNIVERSAL::can($self, $routine);
|
||||
if (GT::Base->_sndex($attrib) eq GT::Base->_sndex($routine)) {
|
||||
push @poss, $routine;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Generate an error message, with possible alternatives and die.
|
||||
my $err_pkg = $is_hash ? (defined $self->{_err_pkg} ? $self->{_err_pkg} : $pkg) : $pkg;
|
||||
my ($call_pkg, $file, $line) = caller(1);
|
||||
my $msg = @poss
|
||||
? " Perhaps you meant to call " . join(", or " => @poss) . ".\n"
|
||||
: '';
|
||||
die "$err_pkg ($$): Unknown method '$attrib' called at $file line $line.\n$msg";
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_sndex} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _sndex {
|
||||
# -------------------------------------------------------
|
||||
# Do a soundex lookup to suggest alternate methods the person
|
||||
# might have wanted.
|
||||
#
|
||||
my $self = shift;
|
||||
local $_ = shift;
|
||||
my $search_sound = uc;
|
||||
$search_sound =~ tr/A-Z//cd;
|
||||
if ($search_sound eq '') { $search_sound = 0 }
|
||||
else {
|
||||
my $f = substr($search_sound, 0, 1);
|
||||
$search_sound =~ tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/;
|
||||
my $fc = substr($search_sound, 0, 1);
|
||||
$search_sound =~ s/^$fc+//;
|
||||
$search_sound =~ tr///cs;
|
||||
$search_sound =~ tr/0//d;
|
||||
$search_sound = $f . $search_sound . '000';
|
||||
$search_sound = substr($search_sound, 0, 4);
|
||||
}
|
||||
return $search_sound;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Base - Common base module to be inherited by all classes.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Base;
|
||||
use vars qw/@ISA $ATTRIBS $ERRORS/
|
||||
@ISA = qw/GT::Base/;
|
||||
$ATTRIBS = {
|
||||
accessor => default,
|
||||
accessor2 => default,
|
||||
};
|
||||
$ERRORS = {
|
||||
BADARGS => "Invalid argument: %s passed to subroutine: %s",
|
||||
};
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Base is a base class that is used to provide common error handling,
|
||||
debugging, creators and accessor methods.
|
||||
|
||||
To use GT::Base, simply make your module inherit from GT::Base. That
|
||||
will provide the following functionality:
|
||||
|
||||
=head2 Debugging
|
||||
|
||||
Two new methods are available for debugging:
|
||||
|
||||
$self->debug($msg, [DEBUG_LEVEL]);
|
||||
|
||||
This will send a $msg to STDERR if the current debug level is greater
|
||||
then the debug level passed in (defaults to 1).
|
||||
|
||||
$self->debug_level(DEBUG_LEVEL);
|
||||
Class->debug_level(DEBUG_LEVEL);
|
||||
|
||||
You can call debug_level() to set or get the debug level. It can
|
||||
be set per object by calling it as an object method, or class wide
|
||||
which will initilize all new objects with that debug level (only if
|
||||
using the built in creator).
|
||||
|
||||
The debugging uses a package variable:
|
||||
|
||||
$Class::DEBUG = 0;
|
||||
|
||||
and assumes it exists.
|
||||
|
||||
=head2 Error Handling
|
||||
|
||||
Your object can now generate errors using the method:
|
||||
|
||||
$self->error(CODE, LEVEL, [args]);
|
||||
|
||||
CODE should be a key to a hash of error codes to user readable
|
||||
error messages. This hash should be stored in $ERRORS which is
|
||||
defined in your pacakge, or the package named in $ERROR_MESSAGE.
|
||||
|
||||
LEVEL should be either 'FATAL' or 'WARN'. If not specified it defaults
|
||||
to FATAL. If it's a fatal error, the program will print the message
|
||||
to STDERR and die.
|
||||
|
||||
args can be used to format the error message. For instance, you can
|
||||
defined commonly used errors like:
|
||||
|
||||
CANTOPEN => "Unable to open file: '%s': %s"
|
||||
|
||||
in your $ERRORS hash. Then you can call error like:
|
||||
|
||||
open FILE, "somefile.txt"
|
||||
or return $self->error(CANTOPEN => FATAL => "somefile.txt", "$!");
|
||||
|
||||
The error handler will format your message using sprintf(), so all
|
||||
regular printf formatting strings are allowed.
|
||||
|
||||
Since errors are kept within an array, too many errors can pose a
|
||||
memory problem. To clear the error stack simply call:
|
||||
|
||||
$self->clear_errors();
|
||||
|
||||
=head2 Error Trapping
|
||||
|
||||
You can specify at run time to trap errors.
|
||||
|
||||
$self->catch_errors(\&code_ref);
|
||||
|
||||
which sets a $SIG{__DIE__} handler. Any fatal errors that occur, will
|
||||
run your function. The function will not be run if the fatal was thrown
|
||||
inside of an eval though.
|
||||
|
||||
=head2 Stack Trace
|
||||
|
||||
You can print out a stack trace at any time by using:
|
||||
|
||||
$self->stack_trace(1);
|
||||
Class->stack_trace(1);
|
||||
|
||||
If you pass in 1, the stack trace will be returned as a string, otherwise
|
||||
it will be printed to STDOUT.
|
||||
|
||||
=head2 Accessor Methods
|
||||
|
||||
Using GT::Base automatically provides accessor methods for all your
|
||||
attributes. By specifying:
|
||||
|
||||
$ATTRIBS = {
|
||||
attrib => 'default',
|
||||
...
|
||||
};
|
||||
|
||||
in your package, you can now call:
|
||||
|
||||
my $val = $obj->attrib();
|
||||
$obj->attrib($set_val);
|
||||
|
||||
to set and retrieve the attributes for that value.
|
||||
|
||||
Note: This uses AUTOLOAD, so if you implement AUTOLOAD in your package,
|
||||
you must have it fall back to GT::Base::AUTOLOAD if it fails. This
|
||||
can be done with:
|
||||
|
||||
AUTOLOAD {
|
||||
...
|
||||
goto >::Base::AUTOLOAD;
|
||||
}
|
||||
|
||||
which will pass all arguments as well.
|
||||
|
||||
=head2 Parameter Parsing
|
||||
|
||||
GT::Base also provides a method to parse parameters. In your methods you
|
||||
can do:
|
||||
|
||||
my $self = shift;
|
||||
my $parm = $self->common_param(@_);
|
||||
|
||||
This will convert any of a hash reference, hash or CGI object into a hash
|
||||
reference.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Base.pm,v 1.132 2005/06/22 19:59:25 jagerman Exp $
|
||||
|
||||
=cut
|
||||
838
site/glist/lib/GT/CGI.pm
Normal file
838
site/glist/lib/GT/CGI.pm
Normal file
@@ -0,0 +1,838 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: CGI.pm,v 1.145 2005/06/21 21:02:57 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements CGI.pm's CGI functionality, but faster.
|
||||
#
|
||||
|
||||
package GT::CGI;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use GT::Base(':persist'); # Imports MOD_PERL, SPEEDY and PERSIST
|
||||
use vars qw/@ISA $DEBUG $VERSION $ATTRIBS $ERRORS $PRINTED_HEAD $EOL
|
||||
$FORM_PARSED %PARAMS @PARAMS %COOKIES @EXPORT_OK %EXPORT_TAGS/;
|
||||
use GT::AutoLoader;
|
||||
require Exporter;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.145 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
nph => 0,
|
||||
p => ''
|
||||
};
|
||||
$ERRORS = {
|
||||
INVALIDCOOKIE => "Invalid cookie passed to header: %s",
|
||||
INVALIDDATE => "Date '%s' is not a valid date format.",
|
||||
};
|
||||
|
||||
$EOL = ($^O eq 'MSWin32') ? "\n" : "\015\012"; # IIS has problems with \015\012 on nph scripts.
|
||||
$PRINTED_HEAD = 0;
|
||||
$FORM_PARSED = 0;
|
||||
%PARAMS = ();
|
||||
@PARAMS = ();
|
||||
%COOKIES = ();
|
||||
@EXPORT_OK = qw/escape unescape html_escape html_unescape/;
|
||||
%EXPORT_TAGS = (
|
||||
escape => [qw/escape unescape html_escape html_unescape/]
|
||||
);
|
||||
|
||||
# Pre load our compiled if under mod_perl/speedy.
|
||||
if (PERSIST) {
|
||||
require GT::CGI::Cookie;
|
||||
require GT::CGI::MultiPart;
|
||||
require GT::CGI::Fh;
|
||||
}
|
||||
|
||||
sub load_data {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Loads the form information into PARAMS. Data comes from either a multipart
|
||||
# form, a GET Request, a POST request, or as arguments from command line.
|
||||
#
|
||||
my $self = shift;
|
||||
unless ($FORM_PARSED) {
|
||||
|
||||
# If we are under mod_perl we let mod_perl know that it should call reset_env
|
||||
# when a request is finished.
|
||||
GT::Base->register_persistent_cleanup(\&reset_env);
|
||||
|
||||
# Reset all the cache variables
|
||||
%PARAMS = @PARAMS = %COOKIES = ();
|
||||
|
||||
# Load form data.
|
||||
my $method = defined $ENV{REQUEST_METHOD} ? uc $ENV{REQUEST_METHOD} : '';
|
||||
my $content_length = defined $ENV{'CONTENT_LENGTH'} ? $ENV{'CONTENT_LENGTH'} : 0;
|
||||
|
||||
if ($method eq 'GET' or $method eq 'HEAD') {
|
||||
$self->parse_str(defined $ENV{QUERY_STRING} ? $ENV{QUERY_STRING} : '');
|
||||
}
|
||||
elsif ($method eq 'POST') {
|
||||
if ($content_length) {
|
||||
if ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ /^multipart/) {
|
||||
require GT::CGI::MultiPart;
|
||||
GT::CGI::MultiPart->parse($self);
|
||||
}
|
||||
else {
|
||||
read(STDIN, my $data, $content_length, 0);
|
||||
$data =~ s/\r?\n/&/g;
|
||||
$self->parse_str($data);
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $data = join "&", @ARGV;
|
||||
$self->parse_str($data);
|
||||
}
|
||||
|
||||
# Load cookies.
|
||||
if (defined $ENV{HTTP_COOKIE}) {
|
||||
for (split /;\s*/, $ENV{HTTP_COOKIE}) {
|
||||
/(.*)=(.*)/ or next;
|
||||
my ($key, $val) = (unescape($1), unescape($2));
|
||||
$val = [split '&', $val];
|
||||
$self->{cookies}->{$key} = $val;
|
||||
}
|
||||
}
|
||||
else {
|
||||
%{$self->{cookies}} = ();
|
||||
}
|
||||
|
||||
# Parse form buttons, allowing you to pass in name="foo=bar;a=b;c=d" as a name
|
||||
# tag in the form.
|
||||
for (keys %{$self->{params}}) {
|
||||
if (index($_, '=') >= 0) {
|
||||
next if substr($_, -2) eq '.y';
|
||||
(my $key = $_) =~ s/\.x$//;
|
||||
$self->parse_str($key);
|
||||
}
|
||||
}
|
||||
|
||||
# Save the data for caching
|
||||
while (my ($k, $v) = each %{$self->{params}}) {
|
||||
push @{$PARAMS{$k}}, @$v;
|
||||
}
|
||||
while (my ($k, $v) = each %{$self->{cookies}}) {
|
||||
push @{$COOKIES{$k}}, @$v;
|
||||
}
|
||||
@PARAMS = @{$self->{param_order} || []};
|
||||
|
||||
# Make sure the form is not parsed again during this request
|
||||
$FORM_PARSED = 1;
|
||||
}
|
||||
else { # Load the data from the cache
|
||||
while (my ($k, $v) = each %PARAMS) {
|
||||
push @{$self->{params}->{$k}}, @$v;
|
||||
}
|
||||
while (my ($k, $v) = each %COOKIES) {
|
||||
push @{$self->{cookies}->{$k}}, @$v;
|
||||
}
|
||||
$self->{param_order} = [@PARAMS];
|
||||
}
|
||||
|
||||
|
||||
$self->{data_loaded} = 1;
|
||||
}
|
||||
|
||||
sub class_new {
|
||||
# --------------------------------------------------------------------------------
|
||||
# Creates an object to be used for all class methods, this affects the global
|
||||
# cookies and params.
|
||||
#
|
||||
my $self = bless {} => shift;
|
||||
$self->load_data unless $self->{data_loaded};
|
||||
|
||||
$self->{cookies} = \%COOKIES;
|
||||
$self->{params} = \%PARAMS;
|
||||
$self->{param_order} = \@PARAMS;
|
||||
|
||||
for (keys %{$ATTRIBS}) { $self->{$_} = $ATTRIBS->{$_} }
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub reset_env {
|
||||
# --------------------------------------------------------------------------------
|
||||
# Reset the global environment.
|
||||
#
|
||||
%PARAMS = @PARAMS = %COOKIES = ();
|
||||
$PRINTED_HEAD = $FORM_PARSED = 0;
|
||||
1;
|
||||
}
|
||||
|
||||
sub init {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Called from GT::Base when a new object is created.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# If we are passed a single argument, then we load our data from
|
||||
# the input.
|
||||
if (@_ == 1) {
|
||||
my $p = $_[0];
|
||||
if (ref $p eq 'GT::CGI') {
|
||||
$p = $p->query_string;
|
||||
}
|
||||
$self->parse_str($p ? "&$p" : "");
|
||||
if (defined $ENV{HTTP_COOKIE}) {
|
||||
for (split /;\s*/, $ENV{HTTP_COOKIE}) {
|
||||
/(.*)=(.*)/ or next;
|
||||
my ($key, $val) = (unescape($1), unescape($2));
|
||||
$val = [split '&', $val];
|
||||
$self->{cookies}->{$key} = $val;
|
||||
}
|
||||
}
|
||||
$self->{data_loaded} = 1;
|
||||
$FORM_PARSED = 1;
|
||||
}
|
||||
elsif (@_) {
|
||||
$self->set(@_);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{get_hash} = __LINE__ . <<'END_OF_SUB';
|
||||
sub get_hash {
|
||||
#-------------------------------------------------------------------------------
|
||||
# Returns the parameters as a HASH, with multiple values becoming an array
|
||||
# reference.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my $join = defined $_[0] ? $_[0] : 0;
|
||||
|
||||
keys %{$self->{params}} or return {};
|
||||
|
||||
# Construct hash ref and return it
|
||||
my $opts = {};
|
||||
foreach (keys %{$self->{params}}) {
|
||||
my @vals = @{$self->{params}->{$_}};
|
||||
$opts->{$_} = @vals > 1 ? \@vals : $vals[0];
|
||||
}
|
||||
return $opts;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{delete} = __LINE__ . <<'END_OF_SUB';
|
||||
sub delete {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Remove an element from the parameters.
|
||||
#
|
||||
my ($self, $param) = @_;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my @ret;
|
||||
if (exists $self->{params}->{$param}) {
|
||||
@ret = @{delete $self->{params}->{$param}};
|
||||
for (my $i = 0; $i < @{$self->{param_order}}; $i++) {
|
||||
if ($self->{param_order}->[$i] eq $param) {
|
||||
splice @{$self->{param_order}}, $i, 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
return wantarray ? @ret : $ret[0];
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{cookie} = __LINE__ . <<'END_OF_SUB';
|
||||
sub cookie {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Creates a new cookie for the user, implemented just like CGI.pm.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
if (@_ == 0) { # Return keys.
|
||||
return keys %{$self->{cookies}};
|
||||
}
|
||||
elsif (@_ == 1) { # Return value of param passed in.
|
||||
my $param = shift;
|
||||
return unless defined $param and $self->{cookies}->{$param};
|
||||
return wantarray ? @{$self->{cookies}->{$param}} : $self->{cookies}->{$param}->[0];
|
||||
}
|
||||
elsif (@_ == 2) {
|
||||
require GT::CGI::Cookie;
|
||||
return GT::CGI::Cookie->new(-name => $_[0], -value => $_[1]);
|
||||
}
|
||||
elsif (@_ % 2 == 0) {
|
||||
my %data = @_;
|
||||
if (exists $data{'-value'}) {
|
||||
require GT::CGI::Cookie;
|
||||
return GT::CGI::Cookie->new(%data);
|
||||
}
|
||||
}
|
||||
$self->fatal("Invalid arguments to cookie()");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub param {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Mimick CGI's param function for get/set.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
if (@_ == 0) { # Return keys in the same order they were provided
|
||||
return @{$self->{param_order} || []};
|
||||
}
|
||||
elsif (@_ == 1) { # Return value of param passed in.
|
||||
my $param = shift;
|
||||
return unless (defined($param) and $self->{params}->{$param});
|
||||
return wantarray ? @{$self->{params}->{$param}} : $self->{params}->{$param}->[0];
|
||||
}
|
||||
else { # Set parameter.
|
||||
my ($param, $value) = @_;
|
||||
unless ($self->{params}->{$param}) {
|
||||
# If we're not replacing/changing a parameter, we need to add the param to param_order
|
||||
push @{$self->{param_order}}, $param;
|
||||
}
|
||||
$self->{params}->{$param} = [ref $value eq 'ARRAY' ? @$value : $value];
|
||||
}
|
||||
}
|
||||
|
||||
sub header {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Mimick the header function.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
my %p = (ref($_[0]) eq 'HASH') ? %{$_[0]} : ( @_ % 2 ) ? () : @_;
|
||||
my @headers;
|
||||
|
||||
# Don't print headers twice unless -force'd.
|
||||
return '' if not delete $p{-force} and $PRINTED_HEAD;
|
||||
|
||||
# Start by adding NPH headers if requested.
|
||||
if ($self->{nph} || $p{-nph}) {
|
||||
if ($p{-url}) {
|
||||
push @headers, "HTTP/1.0 302 Moved";
|
||||
}
|
||||
else {
|
||||
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
|
||||
unless (MOD_PERL) {
|
||||
push @headers, "$protocol 200 OK";
|
||||
}
|
||||
}
|
||||
}
|
||||
delete $p{-nph};
|
||||
|
||||
# If requested, add a "Pragma: no-cache"
|
||||
my $no_cache = $p{'no-cache'} || $p{'-no-cache'};
|
||||
delete @p{qw/no-cache -no-cache/};
|
||||
if ($no_cache) {
|
||||
require GT::Date;
|
||||
push @headers,
|
||||
"Expires: Tue, 25 Jan 2000 12:00:00 GMT",
|
||||
"Last-Modified: " . GT::Date::date_get_gm(time, "%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% GMT"),
|
||||
"Cache-Control: no-cache",
|
||||
"Pragma: no-cache";
|
||||
}
|
||||
|
||||
# Add any cookies, we accept either an array of cookies
|
||||
# or a single cookie.
|
||||
my $add_date = 0;
|
||||
my $cookies = 0;
|
||||
my $container = delete($p{-cookie}) || '';
|
||||
require GT::CGI::Cookie if $container;
|
||||
if (ref $container and UNIVERSAL::isa($container, 'GT::CGI::Cookie')) {
|
||||
my $c = $container->cookie_header;
|
||||
push @headers, $c;
|
||||
$add_date = 1;
|
||||
$cookies++;
|
||||
}
|
||||
elsif (ref $container eq 'ARRAY') {
|
||||
foreach my $cookie (@$container) {
|
||||
next unless (defined $cookie and (ref $cookie eq 'GT::CGI::Cookie'));
|
||||
push @headers, $cookie->cookie_header;
|
||||
$add_date = 1;
|
||||
$cookies++;
|
||||
}
|
||||
}
|
||||
elsif ($container) {
|
||||
$self->error('INVALIDCOOKIE', 'WARN', $container);
|
||||
}
|
||||
|
||||
# Print expiry if requested.
|
||||
if (defined(my $expires = delete $p{-expires})) {
|
||||
require GT::CGI::Cookie;
|
||||
my $date = GT::CGI::Cookie->format_date(' ', $expires);
|
||||
unless ($date) {
|
||||
$self->error('INVALIDDATE', 'WARN', $expires);
|
||||
}
|
||||
else {
|
||||
push @headers, "Expires: $date";
|
||||
$add_date = 1;
|
||||
}
|
||||
}
|
||||
|
||||
# Add a Date header if we printed an expires tag or a cookie tag.
|
||||
if ($add_date) {
|
||||
require GT::CGI::Cookie;
|
||||
my $now = GT::CGI::Cookie->format_date(' ');
|
||||
push @headers, "Date: $now";
|
||||
}
|
||||
|
||||
# Add Redirect Header.
|
||||
my $iis_redirect;
|
||||
if (my $url = delete $p{-url}) {
|
||||
if ($ENV{SERVER_SOFTWARE} =~ m|IIS/(\d+)|i and ($cookies or $1 >= 6)) {
|
||||
$iis_redirect = $url;
|
||||
}
|
||||
else {
|
||||
push @headers, "Location: $url";
|
||||
}
|
||||
}
|
||||
|
||||
# Add the Content-type header.
|
||||
my $type = @_ == 1 && !ref($_[0]) ? $_[0] : delete($p{-type}) || 'text/html';
|
||||
push @headers, "Content-type: $type";
|
||||
|
||||
# Add any custom headers.
|
||||
foreach my $key (keys %p) {
|
||||
$key =~ /^\s*-?(.+)/;
|
||||
push @headers, escape(ucfirst $1) . ": " . (ref $p{$key} eq 'SCALAR' ? ${$p{$key}} : escape($p{$key}));
|
||||
}
|
||||
$PRINTED_HEAD = 1;
|
||||
|
||||
my $headers = join($EOL, @headers) . $EOL . $EOL;
|
||||
|
||||
# Fun hack for IIS
|
||||
if ($iis_redirect) {
|
||||
$iis_redirect =~ y/;/&/; # You can't have semicolons in a meta http-equiv tag.
|
||||
return $headers . <<END_OF_HTML;
|
||||
<html><head><title>Document Moved</title><meta http-equiv="refresh" content="0;URL=$iis_redirect"></head>
|
||||
<body><noscript><h1>Object Moved</h1>This document may be found <a HREF="$iis_redirect">here</a></noscript></body></html>
|
||||
END_OF_HTML
|
||||
}
|
||||
return $headers;
|
||||
}
|
||||
|
||||
$COMPILE{redirect} = __LINE__ . <<'END_OF_SUB';
|
||||
sub redirect {
|
||||
#-------------------------------------------------------------------------------
|
||||
# Print a redirect header.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
|
||||
my (@headers, $url);
|
||||
if (@_ == 0) {
|
||||
return $self->header({ -url => $self->self_url });
|
||||
}
|
||||
elsif (@_ == 1) {
|
||||
return $self->header({ -url => shift });
|
||||
}
|
||||
else {
|
||||
my $opts = ref $_[0] eq 'HASH' ? shift : {@_};
|
||||
$opts->{'-url'} ||= $opts->{'-URL'} || $self->self_url;
|
||||
return $self->header($opts);
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub unescape {
|
||||
#-------------------------------------------------------------------------------
|
||||
# returns the url decoded string of the passed argument. Optionally takes an
|
||||
# array reference of multiple strings to decode. The values of the array are
|
||||
# modified directly, so you shouldn't need the return (which is the same array
|
||||
# reference).
|
||||
#
|
||||
my $todecode = pop;
|
||||
return unless defined $todecode;
|
||||
for my $str (ref $todecode eq 'ARRAY' ? @$todecode : $todecode) {
|
||||
$str =~ tr/+/ /; # pluses become spaces
|
||||
$str =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;
|
||||
}
|
||||
$todecode;
|
||||
}
|
||||
|
||||
$COMPILE{escape} = __LINE__ . <<'END_OF_SUB';
|
||||
sub escape {
|
||||
#--------------------------------------------------------------------------------
|
||||
# return the url encoded string of the passed argument
|
||||
#
|
||||
my $toencode = pop;
|
||||
return unless defined $toencode;
|
||||
$toencode =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg;
|
||||
return $toencode;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{html_escape} = __LINE__ . <<'END_OF_SUB';
|
||||
sub html_escape {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Return the string html_escaped.
|
||||
#
|
||||
my $toencode = pop;
|
||||
return unless defined $toencode;
|
||||
if (ref($toencode) eq 'SCALAR') {
|
||||
$$toencode =~ s/&/&/g;
|
||||
$$toencode =~ s/</</g;
|
||||
$$toencode =~ s/>/>/g;
|
||||
$$toencode =~ s/"/"/g;
|
||||
$$toencode =~ s/'/'/g;
|
||||
}
|
||||
else {
|
||||
$toencode =~ s/&/&/g;
|
||||
$toencode =~ s/</</g;
|
||||
$toencode =~ s/>/>/g;
|
||||
$toencode =~ s/"/"/g;
|
||||
$toencode =~ s/'/'/g;
|
||||
}
|
||||
return $toencode;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{html_unescape} = __LINE__ . <<'END_OF_SUB';
|
||||
sub html_unescape {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Return the string html unescaped.
|
||||
#
|
||||
my $todecode = pop;
|
||||
return unless defined $todecode;
|
||||
if (ref $todecode eq 'SCALAR') {
|
||||
$$todecode =~ s/</</g;
|
||||
$$todecode =~ s/>/>/g;
|
||||
$$todecode =~ s/"/"/g;
|
||||
$$todecode =~ s/'/'/g;
|
||||
$$todecode =~ s/&/&/g;
|
||||
}
|
||||
else {
|
||||
$todecode =~ s/</</g;
|
||||
$todecode =~ s/>/>/g;
|
||||
$todecode =~ s/"/"/g;
|
||||
$todecode =~ s/'/'/g;
|
||||
$todecode =~ s/&/&/g;
|
||||
}
|
||||
return $todecode;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{self_url} = __LINE__ . <<'END_OF_SUB';
|
||||
sub self_url {
|
||||
# -------------------------------------------------------------------
|
||||
# Return full URL with query options as CGI.pm
|
||||
#
|
||||
return $_[0]->url(query_string => 1, absolute => 1);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{url} = __LINE__ . <<'END_OF_SUB';
|
||||
sub url {
|
||||
# -------------------------------------------------------------------
|
||||
# Return the current url. Can be called as GT::CGI->url() or $cgi->url().
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my $opts = $self->common_param(@_);
|
||||
|
||||
my $absolute = exists $opts->{absolute} ? $opts->{absolute} : 0;
|
||||
my $query_string = exists $opts->{query_string} ? $opts->{query_string} : 1;
|
||||
my $path_info = exists $opts->{path_info} ? $opts->{path_info} : 0;
|
||||
my $remove_empty = exists $opts->{remove_empty} ? $opts->{remove_empty} : 0;
|
||||
if ($opts->{relative}) {
|
||||
$absolute = 0;
|
||||
}
|
||||
|
||||
my $url = '';
|
||||
my $script = $ENV{SCRIPT_NAME} || $0;
|
||||
my ($path, $prog) = $script =~ m,^(.+?)[/\\]?([^/\\]*)$,;
|
||||
|
||||
if ($absolute) {
|
||||
my ($protocol, $version) = split('/', $ENV{SERVER_PROTOCOL} || 'HTTP/1.0');
|
||||
$url = lc $protocol . "://";
|
||||
|
||||
my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME} || '';
|
||||
$url .= $host;
|
||||
|
||||
$path =~ s,^[/\\]*|[/\\]*$,,g;
|
||||
$url .= "/$path/";
|
||||
}
|
||||
$prog =~ s,^[/\\]*|[/\\]*$,,g;
|
||||
$url .= $prog;
|
||||
|
||||
if ($path_info and $ENV{PATH_INFO}) {
|
||||
my $path = $ENV{PATH_INFO};
|
||||
if (defined $ENV{SERVER_SOFTWARE} && $ENV{SERVER_SOFTWARE} =~ /IIS/) {
|
||||
$path =~ s/\Q$ENV{SCRIPT_NAME}//;
|
||||
}
|
||||
$url .= $path;
|
||||
}
|
||||
if ($query_string) {
|
||||
my $qs = $self->query_string( remove_empty => $remove_empty );
|
||||
if ($qs) {
|
||||
$url .= "?" . $qs;
|
||||
}
|
||||
}
|
||||
return $url;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{query_string} = __LINE__ . <<'END_OF_SUB';
|
||||
sub query_string {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the query string url escaped.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my $opts = $self->common_param(@_);
|
||||
my $qs = '';
|
||||
foreach my $key (@{$self->{param_order} || []}) {
|
||||
my $esc_key = escape($key);
|
||||
foreach my $val (@{$self->{params}->{$key}}) {
|
||||
next if ($opts->{remove_empty} and ($val eq ''));
|
||||
$qs .= $esc_key . "=" . escape($val) . ";";
|
||||
}
|
||||
}
|
||||
$qs and chop $qs;
|
||||
$qs ? return $qs : return '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{browser_info} = __LINE__ . <<'END_OF_SUB';
|
||||
sub browser_info {
|
||||
# -----------------------------------------------------------------------------
|
||||
# my %tags = browser_info();
|
||||
# --------------------------
|
||||
# Returns various is_BROWSER, BROWSER_version tags.
|
||||
#
|
||||
return unless $ENV{HTTP_USER_AGENT};
|
||||
|
||||
my %browser_opts;
|
||||
|
||||
if ($ENV{HTTP_USER_AGENT} =~ m{Opera(?:\s+|/)(\d+\.\d+)}i) {
|
||||
$browser_opts{is_opera} = 1;
|
||||
$browser_opts{opera_version} = $1;
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ /MSIE (\d+(?:\.\d+)?)/i) {
|
||||
$browser_opts{is_ie} = 1;
|
||||
$browser_opts{ie_version} = $1;
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ m{Mozilla/(\d+\.\d+)\s+\([^)]*rv:(\d+\.\d+)}i) {
|
||||
if ($1 >= 5.0) {
|
||||
$browser_opts{is_mozilla} = 1;
|
||||
$browser_opts{mozilla_version} = $2;
|
||||
}
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ m{Safari/(\d+(?:\.\d+)?)}i) {
|
||||
$browser_opts{is_safari} = 1;
|
||||
$browser_opts{safari_version} = $1;
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ m{Konqueror/(\d+\.\d+)}i) {
|
||||
$browser_opts{is_konqueror} = 1;
|
||||
$browser_opts{konqueror_version} = $1;
|
||||
}
|
||||
return %browser_opts;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub parse_str {
|
||||
#--------------------------------------------------------------------------------
|
||||
# parses a query string and add it to the parameter list
|
||||
#
|
||||
my $self = shift;
|
||||
my @input;
|
||||
for (split /[;&]/, shift) {
|
||||
my ($key, $val) = /([^=]+)=(.*)/ or next;
|
||||
|
||||
# Need to remove cr's on windows.
|
||||
if ($^O eq 'MSWin32') {
|
||||
$key =~ s/%0D%0A/%0A/gi; # \x0d = \r, \x0a = \n
|
||||
$val =~ s/%0D%0A/%0A/gi;
|
||||
}
|
||||
push @input, $key, $val;
|
||||
}
|
||||
unescape(\@input);
|
||||
while (@input) {
|
||||
my ($k, $v) = splice @input, 0, 2;
|
||||
$self->{params}->{$k} or push @{$self->{param_order}}, $k;
|
||||
unshift @{$self->{params}->{$k}}, $v;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::CGI - a lightweight replacement for CGI.pm
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::CGI;
|
||||
my $in = new GT::CGI;
|
||||
foreach my $param ($in->param) {
|
||||
print "VALUE: $param => ", $in->param($param), "\n";
|
||||
}
|
||||
|
||||
use GT::CGI qw/-no_parse_buttons/;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::CGI is a lightweight replacement for CGI.pm. It implements most of the
|
||||
functionality of CGI.pm, with the main difference being that GT::CGI does not
|
||||
provide a function-based interface (with the exception of the escape/unescape
|
||||
functions, which can be called as either function or method), nor does it
|
||||
provide the HTML functionality provided by CGI.pm.
|
||||
|
||||
The primary motivation for this is to provide a CGI module that can be shipped
|
||||
with Gossamer products, not having to depend on a recent version of CGI.pm
|
||||
being installed on remote servers. The secondary motivation is to provide a
|
||||
module that loads and runs faster, thus speeding up Gossamer products.
|
||||
|
||||
Credit and thanks goes to the author of CGI.pm. A lot of the code (especially
|
||||
file upload) was taken from CGI.pm.
|
||||
|
||||
=head2 param - Accessing form input.
|
||||
|
||||
Can be called as either a class method or object method. When called with no
|
||||
arguments a list of keys is returned.
|
||||
|
||||
When called with a single argument in scalar context the first (and possibly
|
||||
only) value is returned. When called in list context an array of values is
|
||||
returned.
|
||||
|
||||
When called with two arguments, it sets the key-value pair.
|
||||
|
||||
=head2 header() - Printing HTTP headers
|
||||
|
||||
Can be called as a class method or object method. When called with no
|
||||
arguments, simply returns the HTTP header.
|
||||
|
||||
Other options include:
|
||||
|
||||
=over 4
|
||||
|
||||
=item -force => 1
|
||||
|
||||
Force printing of header even if it has already been displayed.
|
||||
|
||||
=item -type => 'text/plain'
|
||||
|
||||
Set the type of the header to something other then text/html.
|
||||
|
||||
=item -cookie => $cookie
|
||||
|
||||
Display any cookies. You can pass in a single GT::CGI::Cookie object, or an
|
||||
array of them.
|
||||
|
||||
=item -nph => 1
|
||||
|
||||
Display full headers for nph scripts.
|
||||
|
||||
=back
|
||||
|
||||
If called with a single argument, sets the Content-Type.
|
||||
|
||||
=head2 redirect - Redirecting to new URL.
|
||||
|
||||
Returns a Location: header to redirect a user.
|
||||
|
||||
=head2 cookie - Set/Get HTTP Cookies.
|
||||
|
||||
Sets or gets a cookie. To retrieve a cookie:
|
||||
|
||||
my $cookie = $cgi->cookie ('key');
|
||||
my $cookie = $cgi->cookie (-name => 'key');
|
||||
|
||||
or to retrieve a hash of all cookies:
|
||||
|
||||
my $cookies = $cgi->cookie;
|
||||
|
||||
To set a cookie:
|
||||
|
||||
$c = $cgi->cookie (-name => 'foo', -value => 'bar')
|
||||
|
||||
You can also specify -expires for when the cookie should expire, -path for
|
||||
which path the cookie valid, -domain for which domain the cookie is valid, and
|
||||
-secure if the cookie is only valid for secure sites.
|
||||
|
||||
You would then set the cookie by passing it to the header function:
|
||||
|
||||
print $in->header ( -cookie => $c );
|
||||
|
||||
=head2 url - Retrieve the current URL.
|
||||
|
||||
Returns the current URL of the script. It defaults to display just the script
|
||||
name and query string.
|
||||
|
||||
Options include:
|
||||
|
||||
=over 4
|
||||
|
||||
=item absolute => 1
|
||||
|
||||
Return the full URL: http://domain/path/to/script.cgi
|
||||
|
||||
=item relative => 1
|
||||
|
||||
Return only the script name: script.cgi
|
||||
|
||||
=item query_string => 1
|
||||
|
||||
Return the query string as well: script.cgi?a=b
|
||||
|
||||
=item path_info => 1
|
||||
|
||||
Returns the path info as well: script.cgi/foobar
|
||||
|
||||
=item remove_empty => 0
|
||||
|
||||
Removes empty query= from the query string.
|
||||
|
||||
=back
|
||||
|
||||
=head2 get_hash - Return all form input as hash.
|
||||
|
||||
This returns the current parameters as a hash. Any values that have the same
|
||||
key will be returned as an array reference of the multiple values.
|
||||
|
||||
=head2 escape - URL escape a string.
|
||||
|
||||
Returns the passed in value URL escaped. Can be called as class method or
|
||||
object method.
|
||||
|
||||
=head2 unescape - URL unescape a string.
|
||||
|
||||
Returns the passed in value URL un-escaped. Can be called as class method or
|
||||
object method. Optionally can take an array reference of strings instead of a
|
||||
string. If called in this method, the values of the array reference will be
|
||||
directly altered.
|
||||
|
||||
=head2 html_escape - HTML escape a string
|
||||
|
||||
Returns the passed in value HTML escaped. Translates &, <, > and " to their
|
||||
html equivalants.
|
||||
|
||||
=head2 html_unescape - HTML unescapes a string
|
||||
|
||||
Returns the passed in value HTML unescaped.
|
||||
|
||||
=head1 DEPENDENCIES
|
||||
|
||||
Note: GT::CGI depends on L<GT::Base> and L<GT::AutoLoader>, and if you are
|
||||
performing file uploads, GT::CGI::MultiPart, GT::CGI::Fh, and L<GT::TempFile>.
|
||||
The ability to set cookies requires GT::CGI::Cookie.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: CGI.pm,v 1.145 2005/06/21 21:02:57 jagerman Exp $
|
||||
|
||||
=cut
|
||||
101
site/glist/lib/GT/CGI/Action.pm
Normal file
101
site/glist/lib/GT/CGI/Action.pm
Normal file
@@ -0,0 +1,101 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Action
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Action.pm,v 1.8 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# An API to make writting CGIs easier.
|
||||
#
|
||||
|
||||
package GT::CGI::Action;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/@ISA @EXPORT/;
|
||||
use strict;
|
||||
|
||||
use GT::CGI::Action::Common;
|
||||
|
||||
use Carp;
|
||||
|
||||
@ISA = qw(GT::CGI::Action::Common);
|
||||
@EXPORT = qw(ACT_ERROR ACT_OK ACT_EXIT);
|
||||
|
||||
sub can_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $page = shift;
|
||||
croak "No page specified" unless defined $page;
|
||||
|
||||
my $pages = $self->config->{pages};
|
||||
return undef unless defined $pages and exists $pages->{$page};
|
||||
return $pages->{$page}[PAGE_CAN];
|
||||
}
|
||||
|
||||
sub can_action {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $action = shift;
|
||||
croak "No action specified" unless defined $action;
|
||||
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
my $actions = $self->config->{actions};
|
||||
return undef unless defined $actions and exists $actions->{$action};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub run_action {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $action = shift;
|
||||
croak "No page specified" unless defined $action;
|
||||
|
||||
my $actions = $self->config->{actions};
|
||||
croak "$action does not exist"
|
||||
unless defined $actions and exists $actions->{$action};
|
||||
|
||||
my ($class, $func) = ($actions->{$action}[ACT_FUNCTION] =~ /(.+)::([^:]+)/);
|
||||
eval "use $class();";
|
||||
die "$@\n" if $@;
|
||||
my $this = $class->new(%$self);
|
||||
$this->action($action);
|
||||
$this->$func(@_);
|
||||
return $this;
|
||||
}
|
||||
|
||||
# Shortcut function
|
||||
sub run_returns {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $obj = shift;
|
||||
croak "No object defined" unless defined $obj;
|
||||
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
|
||||
if ($obj->return == ACT_ERROR) {
|
||||
$self->print_page($obj->error_page);
|
||||
}
|
||||
elsif ($obj->return == ACT_OK) {
|
||||
$self->print_page($obj->success_page);
|
||||
}
|
||||
elsif ($obj->return != ACT_EXIT) {
|
||||
die "Unknown return from $obj";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
286
site/glist/lib/GT/CGI/Action/Common.pm
Normal file
286
site/glist/lib/GT/CGI/Action/Common.pm
Normal file
@@ -0,0 +1,286 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Action::Common
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Common.pm,v 1.14 2004/09/07 23:35:14 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Provides a base class for GT::CGI::Action objects
|
||||
#
|
||||
|
||||
package GT::CGI::Action::Common;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/@EXPORT @ISA/;
|
||||
use strict;
|
||||
use constants
|
||||
|
||||
# Index in config action values
|
||||
ACT_FUNCTION => 0,
|
||||
ACT_ERROR_PAGE => 1,
|
||||
ACT_SUCCESS_PAGE => 2,
|
||||
|
||||
# Index in config page values
|
||||
PAGE_CAN => 0,
|
||||
PAGE_FUNCTION => 1,
|
||||
|
||||
# Action returns
|
||||
ACT_ERROR => 0,
|
||||
ACT_OK => 1,
|
||||
ACT_EXIT => 3;
|
||||
|
||||
use Carp;
|
||||
use Exporter();
|
||||
|
||||
@ISA = qw/Exporter/;
|
||||
@EXPORT = qw(
|
||||
ACT_FUNCTION
|
||||
ACT_ERROR_PAGE
|
||||
ACT_SUCCESS_PAGE
|
||||
PAGE_CAN
|
||||
PAGE_FUNCTION
|
||||
ACT_EXIT
|
||||
ACT_OK
|
||||
ACT_ERROR
|
||||
);
|
||||
|
||||
sub new {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $class = shift;
|
||||
croak "Areguments to new() must be a hash" if @_ & 1;
|
||||
my %opts = @_;
|
||||
|
||||
my $guess_mime = exists($opts{guess_mime}) ? delete($opts{guess_mime}) : 1;
|
||||
|
||||
my $cgi = delete $opts{cgi};
|
||||
unless (defined $cgi) {
|
||||
require GT::CGI;
|
||||
$cgi = new GT::CGI;
|
||||
}
|
||||
|
||||
my $tpl = delete $opts{template};
|
||||
unless (defined $tpl) {
|
||||
require GT::Template;
|
||||
$tpl = new GT::Template;
|
||||
}
|
||||
|
||||
my $debug = delete $opts{debug};
|
||||
|
||||
my $tags = delete $opts{tags};
|
||||
$tags = {} unless defined $tags;
|
||||
|
||||
my $config = delete $opts{config};
|
||||
croak "No config specified"
|
||||
unless defined $config;
|
||||
|
||||
my $action = delete $opts{action};
|
||||
my $heap = delete $opts{heap};
|
||||
|
||||
croak "Unknown arguments: ", sort keys %opts if keys %opts;
|
||||
|
||||
my $self = bless {
|
||||
cgi => $cgi,
|
||||
template => $tpl,
|
||||
tags => $tags,
|
||||
guess_mime => $guess_mime,
|
||||
action => $action,
|
||||
debug => $debug,
|
||||
heap => $heap
|
||||
}, $class;
|
||||
$self->config($config);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub config {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{config} = shift;
|
||||
unless (ref $self->{config}) {
|
||||
require GT::Config;
|
||||
$self->{config} = GT::Config->load($self->{config}, {
|
||||
inheritance => 1,
|
||||
cache => 1,
|
||||
create_ok => 0,
|
||||
strict => 0,
|
||||
debug => $self->{debug},
|
||||
compile_subs => 0,
|
||||
});
|
||||
}
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{config};
|
||||
}
|
||||
|
||||
sub tags {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my %tags;
|
||||
if (ref($_[0]) eq 'HASH') {
|
||||
%tags = %{shift()};
|
||||
}
|
||||
else {
|
||||
croak "Arguments to tags() must be a hash or hash ref" if @_ & 1;
|
||||
%tags = @_;
|
||||
}
|
||||
@{$self->{tags}}{keys %tags} = (values %tags)
|
||||
if keys %tags;
|
||||
return $self->{tags};
|
||||
}
|
||||
|
||||
sub cgi {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{cgi} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{cgi};
|
||||
}
|
||||
|
||||
sub heap {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{heap} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{heap};
|
||||
}
|
||||
|
||||
sub action {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{action} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{action};
|
||||
}
|
||||
|
||||
sub guess_mime {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{guess_mime} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{guess_mime};
|
||||
}
|
||||
|
||||
sub debug {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{debug} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{debug};
|
||||
}
|
||||
|
||||
sub template {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{template} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{template};
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(message => "message");
|
||||
sub info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
$self->tags(message => $message);
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(message => "message"); $self->print_page("page");
|
||||
sub print_info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $page = shift;
|
||||
croak "No page specified" unless defined $page;
|
||||
$self->info(@_);
|
||||
$self->print_page($page);
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(error => "message");
|
||||
sub error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $error = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
$self->tags(error => $error);
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(error => "message"); $self->print_page("page");
|
||||
sub print_error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $page = shift;
|
||||
croak "No page specified" unless defined $page;
|
||||
$self->info(@_);
|
||||
$self->print_page($page);
|
||||
}
|
||||
|
||||
# Shortcut to print $self->cgi->cookie(..)->cookie_header, "\r\n";
|
||||
sub print_cookie {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
print $self->cgi->cookie(@_)->cookie_header, "\r\n";
|
||||
}
|
||||
|
||||
sub print_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $page = shift;
|
||||
croak "No page specified to print" unless defined $page;
|
||||
$self->tags(page => $page);
|
||||
|
||||
if (defined $self->{config}{pages}{$page}[PAGE_FUNCTION]) {
|
||||
my ($class, $func) = ($self->{config}{pages}{$page}[PAGE_FUNCTION] =~ /(.+)::([^:]+)/);
|
||||
eval "use $class();";
|
||||
die "$@\n" if $@;
|
||||
my $this = $class->new(%$self);
|
||||
$this->$func(@_);
|
||||
}
|
||||
|
||||
if ($self->guess_mime) {
|
||||
require GT::MIMETypes;
|
||||
my $type = GT::MIMETypes->guess_type($page);
|
||||
print $self->cgi->header($type);
|
||||
if ($type =~ /text/) {
|
||||
return $self->template->parse_print($page, $self->tags);
|
||||
}
|
||||
else {
|
||||
local *FH;
|
||||
open FH, "<$page"
|
||||
or die "Could not open $page; Reason: $!";
|
||||
my $buff;
|
||||
binmode STDOUT;
|
||||
while (read(FH, $buff, 4096)) {
|
||||
print STDOUT $buff;
|
||||
}
|
||||
close FH;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $self->cgi->header;
|
||||
}
|
||||
$self->template->parse_print($page, $self->tags);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
106
site/glist/lib/GT/CGI/Action/Plugin.pm
Normal file
106
site/glist/lib/GT/CGI/Action/Plugin.pm
Normal file
@@ -0,0 +1,106 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Action::Plugin
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Plugin.pm,v 1.5 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
#
|
||||
|
||||
package GT::CGI::Action::Plugin;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/@ISA @EXPORT/;
|
||||
use strict;
|
||||
|
||||
use GT::CGI::Action::Common;
|
||||
|
||||
use Carp;
|
||||
|
||||
@ISA = qw(GT::CGI::Action::Common);
|
||||
@EXPORT = qw(ACT_ERROR ACT_OK ACT_EXIT);
|
||||
|
||||
sub return {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{return} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{return};
|
||||
}
|
||||
|
||||
sub info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::info(@_) if @_;
|
||||
$self->return(ACT_OK);
|
||||
}
|
||||
|
||||
sub print_info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::print_info(@_);
|
||||
$self->return(ACT_EXIT);
|
||||
}
|
||||
|
||||
sub error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::error(@_) if @_;
|
||||
$self->return(ACT_ERROR);
|
||||
}
|
||||
|
||||
sub print_error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::print_error(@_);
|
||||
$self->return(ACT_ERROR);
|
||||
}
|
||||
|
||||
sub exit {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->return(ACT_EXIT);
|
||||
}
|
||||
|
||||
sub error_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{error_page} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
if (defined $self->{error_page}) {
|
||||
return $self->{error_page};
|
||||
}
|
||||
croak "No action was ever specified" unless defined $self->action;
|
||||
return $self->{config}{actions}{$self->action}[ACT_ERROR_PAGE];
|
||||
|
||||
}
|
||||
|
||||
sub success_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{success_page} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
if (defined $self->{success_page}) {
|
||||
return $self->{success_page};
|
||||
}
|
||||
croak "No action was ever specified" unless defined $self->action;
|
||||
return $self->{config}{actions}{$self->action}[ACT_SUCCESS_PAGE];
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
101
site/glist/lib/GT/CGI/Cookie.pm
Normal file
101
site/glist/lib/GT/CGI/Cookie.pm
Normal file
@@ -0,0 +1,101 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Cookie
|
||||
# CVS Info :
|
||||
# $Id: Cookie.pm,v 1.5 2004/08/19 23:49:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Handles cookie creation and formatting
|
||||
#
|
||||
|
||||
package GT::CGI::Cookie;
|
||||
#================================================================================
|
||||
|
||||
use strict;
|
||||
use GT::CGI;
|
||||
use GT::Base;
|
||||
use vars qw/@ISA $ATTRIBS @MON @WDAY/;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
|
||||
$ATTRIBS = {
|
||||
-name => '',
|
||||
-value => '',
|
||||
-expires => '',
|
||||
-path => '',
|
||||
-domain => '',
|
||||
-secure => ''
|
||||
};
|
||||
@MON = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
|
||||
@WDAY = qw/Sun Mon Tue Wed Thu Fri Sat/;
|
||||
|
||||
sub cookie_header {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Returns a cookie header.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# make sure we have a name to use
|
||||
$self->{-name} or return;
|
||||
|
||||
my $name = GT::CGI::escape($self->{-name});
|
||||
my $value = GT::CGI::escape($self->{-value});
|
||||
|
||||
# build the header that creates the cookie
|
||||
my $header = "Set-Cookie: $name=$value";
|
||||
|
||||
$self->{-expires} and $header .= "; expires=" . $self->format_date('-', $self->{-expires});
|
||||
$self->{-path} and $header .= "; path=$self->{-path}";
|
||||
$self->{-domain} and $header .= "; domain=$self->{-domain}";
|
||||
$self->{-secure} and $header .= "; secure";
|
||||
|
||||
return "$header";
|
||||
}
|
||||
|
||||
sub format_date {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a string in http_gmt format, but accepts one in unknown format.
|
||||
# Wed, 23 Aug 2000 21:20:14 GMT
|
||||
#
|
||||
my ($self, $sep, $datestr) = @_;
|
||||
my $unix_time = defined $datestr ? $self->expire_calc($datestr) : time;
|
||||
|
||||
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($unix_time);
|
||||
$year += 1900;
|
||||
|
||||
return sprintf(
|
||||
"%s, %02d$sep%s$sep%04d %02d:%02d:%02d GMT",
|
||||
$WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec
|
||||
);
|
||||
}
|
||||
*_format_date = \&format_date; # deprecated
|
||||
|
||||
sub expire_calc {
|
||||
# -------------------------------------------------------------------
|
||||
# Calculates when a date based on +- times. See CGI.pm for more info.
|
||||
#
|
||||
my ($self, $time) = @_;
|
||||
my %mult = (s => 1, m => 60, h => 3600, d => 86400, M => 2592000, y => 31536000);
|
||||
my $offset;
|
||||
|
||||
if (!$time or lc $time eq 'now') {
|
||||
$offset = 0;
|
||||
}
|
||||
elsif ($time =~ /^\d/) {
|
||||
return $time;
|
||||
}
|
||||
elsif ($time=~/^([+-]?(?:\d+(?:\.\d*)?|\.\d+))([smhdMy]?)/) {
|
||||
$offset = $1 * ($mult{$2} || 1);
|
||||
}
|
||||
else {
|
||||
return $time;
|
||||
}
|
||||
return time + $offset;
|
||||
}
|
||||
*_expire_calc = \&expire_calc; # deprecated
|
||||
|
||||
1;
|
||||
502
site/glist/lib/GT/CGI/EventLoop.pm
Normal file
502
site/glist/lib/GT/CGI/EventLoop.pm
Normal file
@@ -0,0 +1,502 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::EventLoop
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: EventLoop.pm,v 1.5 2004/09/07 23:35:14 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Impliments an EventLoop API for CGI programming
|
||||
#
|
||||
|
||||
package GT::CGI::EventLoop;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/$ATTRIBS $ERRORS @EXPORT_OK %EXPORT_TAGS/;
|
||||
use strict;
|
||||
use bases 'GT::Base' => ''; # GT::Base inherits from Exporter
|
||||
use constants
|
||||
STOP => 1,
|
||||
EXIT => 2,
|
||||
CONT => 3,
|
||||
HEAP => 0,
|
||||
EVENT => 1,
|
||||
IN => 2,
|
||||
CGI => 3,
|
||||
ARG0 => 4,
|
||||
ARG1 => 5,
|
||||
ARG2 => 6,
|
||||
ARG3 => 7,
|
||||
ARG4 => 8,
|
||||
ARG5 => 9,
|
||||
ARG6 => 10,
|
||||
ARG7 => 11,
|
||||
ARG8 => 12,
|
||||
ARG9 => 13;
|
||||
|
||||
use GT::CGI;
|
||||
use GT::MIMETypes;
|
||||
|
||||
$ERRORS = {
|
||||
NOACTION => 'No action was passed from CGI input and no default action was set',
|
||||
NOFUNC => 'No function in %s'
|
||||
};
|
||||
|
||||
$ATTRIBS = {
|
||||
do => 'do',
|
||||
format_page_tags => undef,
|
||||
default_do => undef,
|
||||
init_events => undef,
|
||||
init_events_name => undef,
|
||||
default_page => 'home',
|
||||
default_group => undef,
|
||||
default_page_pre_event => undef,
|
||||
default_page_post_event => undef,
|
||||
default_group_pre_event => undef,
|
||||
default_group_post_event => undef,
|
||||
needs_array_input => undef,
|
||||
plugin_object => undef,
|
||||
template_path => undef,
|
||||
pre_package => '',
|
||||
cgi => undef,
|
||||
in => {},
|
||||
heap => {},
|
||||
page_events => {},
|
||||
page_pre_events => {},
|
||||
page_post_events => {},
|
||||
group_pre_events => {},
|
||||
group_post_events => {},
|
||||
groups => {},
|
||||
group => undef,
|
||||
page => undef,
|
||||
print_page => \>::CGI::EventLoop::print_page,
|
||||
status => CONT,
|
||||
cookies => []
|
||||
};
|
||||
|
||||
@EXPORT_OK = qw/
|
||||
STOP EXIT CONT
|
||||
HEAP EVENT IN CGI
|
||||
ARG0 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9
|
||||
/;
|
||||
|
||||
%EXPORT_TAGS = (
|
||||
all => [@EXPORT_OK],
|
||||
status => [qw/STOP EXIT CONT/],
|
||||
args => [qw/
|
||||
HEAP EVENT IN CGI
|
||||
ARG0 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9
|
||||
/]
|
||||
);
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->set( @_ ) if @_;
|
||||
$self->{cgi} ||= new GT::CGI;
|
||||
for ( $self->{cgi}->param ) {
|
||||
my @val = $self->{cgi}->param($_);
|
||||
my $val;
|
||||
my $match;
|
||||
for my $field ( @{$self->{needs_array_input}} ) {
|
||||
if ( $_ eq $field ) {
|
||||
$match = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ( !$match ) {
|
||||
$val = $val[0];
|
||||
}
|
||||
else {
|
||||
$val = \@val;
|
||||
}
|
||||
$self->{in}{$_} = $val;
|
||||
}
|
||||
}
|
||||
|
||||
sub mainloop {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->init( @_ ) if @_;
|
||||
|
||||
if ( !defined $self->{in}{$self->{do}} ) {
|
||||
if ( defined $self->{default_do} ) {
|
||||
$self->{in}{$self->{do}} = $self->{default_do};
|
||||
}
|
||||
else {
|
||||
$self->fatal( 'NOACTION' );
|
||||
}
|
||||
}
|
||||
if ( $self->{init_events} ) {
|
||||
local $self->{in}{$self->{do}} = $self->{init_events_name} if $self->{init_events_name};
|
||||
|
||||
$self->dispatch( $self->{init_events} );
|
||||
return if $self->{status} == EXIT;
|
||||
}
|
||||
$self->_call_group;
|
||||
$self->_call_page;
|
||||
}
|
||||
|
||||
sub do_param {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if ( @_ ) {
|
||||
$self->add_hidden( $self->{do} => $_[0] );
|
||||
}
|
||||
return $self->{in}{$self->{do}};
|
||||
}
|
||||
|
||||
sub stop { $_[0]->{status} = STOP }
|
||||
sub exit { $_[0]->{status} = EXIT }
|
||||
sub cont { $_[0]->{status} = CONT }
|
||||
|
||||
sub _call_group {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
$self->{group} ||= $self->{in}{$self->{do}} || $self->{default_do};
|
||||
my $orig_group = $self->{group};
|
||||
# FIXME Add infinite recursion checks!
|
||||
for ( keys %{$self->{groups}} ) {
|
||||
if ( index( $self->{group}, $_ ) == 0 ) {
|
||||
if ( exists $self->{group_pre_events}{$_} ) {
|
||||
$self->dispatch( $self->{group_pre_events}{$_} );
|
||||
return if $self->{status} == EXIT;
|
||||
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
elsif ( defined $self->{default_group_pre_event} ) {
|
||||
$self->dispatch( $self->{default_group_pre_event} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
$self->dispatch( $self->{groups}{$_} );
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
if ( exists $self->{group_post_events}{$_} ) {
|
||||
$self->dispatch( $self->{group_post_events}{$_} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
elsif ( defined $self->{default_group_post_event} ) {
|
||||
$self->dispatch( $self->{default_group_post_event} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# Default group
|
||||
$self->dispatch( $self->{default_group} ) if $self->{default_group};
|
||||
if ( $self->{default_group} and $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
|
||||
sub _call_page {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
if ( !$self->{page} ) {
|
||||
$self->page( $self->{default_page} );
|
||||
}
|
||||
my $orig_page = $self->{page};
|
||||
if ( exists $self->{page_pre_events}{$self->{page}} ) {
|
||||
$self->dispatch( $self->{page_pre_events}{$self->{page}} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{page} ne $orig_page ) {
|
||||
return $self->_call_page;
|
||||
}
|
||||
}
|
||||
elsif ( defined $self->{default_page_pre_event} ) {
|
||||
$self->dispatch( $self->{default_page_pre_event} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{page} ne $orig_page ) {
|
||||
return $self->_call_page;
|
||||
}
|
||||
}
|
||||
$self->{print_page}->( $self );
|
||||
|
||||
# Run post page events, can't change the page on a post event
|
||||
if ( exists $self->{page_post_events}{$self->{page}} ) {
|
||||
$self->dispatch( $self->{page_post_events}{$self->{page}} );
|
||||
}
|
||||
elsif ( defined $self->{default_page_post_event} ) {
|
||||
$self->dispatch( $self->{default_page_post_event} );
|
||||
}
|
||||
}
|
||||
|
||||
sub cookie_jar {
|
||||
# --------------------------------------------------------------------
|
||||
# $obj->cookie_jar($cookie_object);
|
||||
# ---------------------------------
|
||||
# Stores cookies for printing when print_page is called.
|
||||
# $cookie_object should be a GT::CGI::Cookie object. Passing undef
|
||||
# will empty the cookies array ref.
|
||||
#
|
||||
my $self = shift;
|
||||
if ( !defined( $_[0] ) and @_ > 0 ) {
|
||||
$self->{cookies} = [];
|
||||
}
|
||||
elsif ( @_ > 0 ) {
|
||||
push( @{$self->{cookies}}, $_[0] );
|
||||
}
|
||||
return $self->{cookies};
|
||||
}
|
||||
|
||||
sub add_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if ( @_ and !defined( $_[0] ) ) {
|
||||
$self->{hidden} = {};
|
||||
}
|
||||
elsif ( @_ ) {
|
||||
$self->{hidden}{$_[0]} = $_[1];
|
||||
}
|
||||
}
|
||||
|
||||
sub remove_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return delete $self->{hidden}{$_[0]};
|
||||
}
|
||||
|
||||
sub get_url_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
my $ret = '';
|
||||
for ( keys %{$self->{hidden}} ) {
|
||||
next unless defined $self->{hidden}{$_};
|
||||
$ret .= $self->{cgi}->escape( $_ ).'='.$self->{cgi}->escape( $self->{hidden}{$_} ).';';
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub get_form_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
my $ret = '';
|
||||
for ( keys %{$self->{hidden}} ) {
|
||||
next unless defined $self->{hidden}{$_};
|
||||
$ret .= '<input type="hidden" name="'.$self->{cgi}->html_escape( $_ ).'" value="'.$self->{cgi}->html_escape( $self->{hidden}{$_} ).'">';
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub page {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if ( @_ > 0 ) {
|
||||
$self->{page} = $self->guess_page( $_[0] );
|
||||
$self->debug( "Set page to $self->{page}" ) if $self->{_debug};
|
||||
$self->yield( $self->{page_events} ) if $self->{page_events};
|
||||
}
|
||||
return $self->{page};
|
||||
}
|
||||
|
||||
sub guess_page {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, $page ) = @_;
|
||||
if ( -e "$self->{template_path}/$page.htm" ) {
|
||||
$page = "$page.htm";
|
||||
}
|
||||
elsif ( -e "$self->{template_path}/$page.html" ) {
|
||||
$page = "$page.html";
|
||||
}
|
||||
return $page;
|
||||
}
|
||||
|
||||
sub tags {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my ( %tags ) = ref( $_[0] ) eq 'HASH' ? %{$_[0]} : @_;
|
||||
for ( keys %tags ) {
|
||||
$self->{tags}{$_} = $tags{$_};
|
||||
}
|
||||
return $self->{tags};
|
||||
}
|
||||
|
||||
sub default_tags {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %tags ) = @_;
|
||||
|
||||
my $set;
|
||||
for ( keys %tags ) {
|
||||
$set->{$_} = ( defined( $self->{in}{$_} ) and length( $self->{in}{$_} ) ? $self->{in}{$_} : $tags{$_} );
|
||||
}
|
||||
$self->tags( %$set );
|
||||
}
|
||||
|
||||
sub print_page {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
my $form_hidden = $self->get_form_hidden;
|
||||
my $url_hidden = $self->get_url_hidden;
|
||||
my $tags = $self->tags( url_hidden => \$url_hidden, form_hidden => \$form_hidden );
|
||||
$tags = $self->yield( $self->{format_page_tags}, $tags ) if defined $self->{format_page_tags};
|
||||
my $page = $self->page || 'index.htm';
|
||||
|
||||
# Cookies can be set with CGI input
|
||||
my $cookies = [];
|
||||
if ( $self->{in}{'set-cookie'} ) {
|
||||
foreach my $key ( keys %{$self->{in}} ) {
|
||||
if ( $key =~ /^cookie-(.*)/ ) {
|
||||
push @$cookies, $self->{cgi}->cookie( -name => $1, -value => $self->{in}{$key}, -path => '/' );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# See if we have any cookies in out cookie jar (used through program operation to set cookies without printing
|
||||
# a header)
|
||||
if ( @{$self->cookie_jar} ) {
|
||||
push @$cookies, @{$self->cookie_jar};
|
||||
}
|
||||
|
||||
# If we have cookie header to print print them
|
||||
print @{$cookies}
|
||||
? $self->{cgi}->header(
|
||||
-cookie => $cookies,
|
||||
-type => GT::MIMETypes->guess_type( $page )
|
||||
)
|
||||
: $self->{cgi}->header( GT::MIMETypes->guess_type( $page ) );
|
||||
|
||||
my $base = $self->{template_path};
|
||||
|
||||
# Make sure the template exists and is readable
|
||||
-e "$base/$page" or die "No page ($base/$page)";
|
||||
-r _ or die "Page isn't readable by this process ($< $>) ($base/$page)";
|
||||
|
||||
require GT::Template;
|
||||
GT::Template->parse( $page, $tags, {
|
||||
root => $base,
|
||||
escape => 1,
|
||||
print => 1,
|
||||
heap => [ $self->func_args ]
|
||||
} );
|
||||
|
||||
}
|
||||
|
||||
sub page_pre_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{page_pre_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{page_pre_events}{$self->guess_page( $_ )} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{page_pre_events};
|
||||
}
|
||||
|
||||
sub page_post_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{page_post_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{page_post_events}{$self->guess_page( $_ )} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{page_post_events};
|
||||
}
|
||||
|
||||
sub group_pre_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{group_pre_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{group_pre_events}{$_} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{group_pre_events};
|
||||
}
|
||||
|
||||
sub group_post_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{group_post_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{group_post_events}{$_} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{group_post_events};
|
||||
}
|
||||
|
||||
sub dispatch {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, $pfunc, @args ) = @_;
|
||||
$pfunc = ref( $pfunc ) eq 'ARRAY' ? $pfunc : [ $pfunc ];
|
||||
for ( @$pfunc ) {
|
||||
$self->yield( $_, @args );
|
||||
return if $self->{status} == EXIT or $self->{status} == STOP;
|
||||
}
|
||||
}
|
||||
|
||||
sub yield {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, $pfunc, @args ) = @_;
|
||||
if ( !ref( $pfunc ) ) {
|
||||
$self->debug( "Yielding $pfunc" ) if $self->{_debug} > 1;
|
||||
my ( $pkg, $func );
|
||||
if ( index( $pfunc, '::' ) != -1 ) {
|
||||
($pkg, $func) = $pfunc =~ /^(.*)::(.*)$/;
|
||||
}
|
||||
else {
|
||||
$func = $pfunc;
|
||||
}
|
||||
defined( $func ) or $self->fatal( 'NOFUNC', $pfunc );
|
||||
$pkg = $self->{pre_package}.$pkg if $self->{pre_package} and $pkg;
|
||||
$pkg ||= $self->{pre_package} if $self->{pre_package};
|
||||
$pkg ||= 'main';
|
||||
$pkg =~ s/::$//;
|
||||
no strict 'refs';
|
||||
unless ( defined %{$pkg . '::'} ) {
|
||||
eval "require $pkg";
|
||||
die "Could not compile $pkg; Reason: $@" if $@;
|
||||
}
|
||||
if ( defined $self->{plugin_object} ) {
|
||||
$self->debug( "dispatching --> $pkg\::$func" ) if $self->{_debug};
|
||||
return $self->{plugin_object}->dispatch( $pkg.'::'.$func, \&{$pkg.'::'.$func}, $self->func_args(@args) );
|
||||
}
|
||||
else {
|
||||
no strict 'refs';
|
||||
$self->debug( "Calling $pkg\::$func" ) if $self->{_debug};
|
||||
return &{$pkg.'::'.$func}( $self->func_args(@args) );
|
||||
}
|
||||
$self->yield( $_, @args );
|
||||
}
|
||||
elsif ( ref( $pfunc ) eq 'CODE' ) {
|
||||
$self->debug( "In yeild with code ref.") if $self->{_debug};
|
||||
if ( defined $self->{plugin_object} ) {
|
||||
$self->debug( "dispatching --> $self->{in}{$self->{do}}" ) if $self->{_debug};
|
||||
return $self->{plugin_object}->dispatch( $self->{in}{$self->{do}}, $pfunc, $self->func_args(@args) );
|
||||
}
|
||||
else {
|
||||
$self->debug( "Calling code ref" ) if $self->{_debug};
|
||||
return $pfunc->( $self->func_args(@args) );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub func_args { $_[0]->{heap}, $_[0], $_[0]->{in}, $_[0]->{cgi}, @_[1 .. $#_] }
|
||||
|
||||
1;
|
||||
|
||||
|
||||
70
site/glist/lib/GT/CGI/Fh.pm
Normal file
70
site/glist/lib/GT/CGI/Fh.pm
Normal file
@@ -0,0 +1,70 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Fh
|
||||
# CVS Info :
|
||||
# $Id: Fh.pm,v 1.2 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Magic filehandle that prints the name, but is still a filehandle for reads -
|
||||
# just like CGI.pm.
|
||||
#
|
||||
package GT::CGI::Fh;
|
||||
# ===================================================================
|
||||
use strict 'vars', 'subs';
|
||||
use vars qw/$FH/;
|
||||
use Fcntl qw/O_RDWR O_EXCL/;
|
||||
use overload
|
||||
'""' => \&as_string,
|
||||
'cmp' => \&compare,
|
||||
'fallback' => 1;
|
||||
|
||||
sub new {
|
||||
# -------------------------------------------------------------------
|
||||
# Create a new filehandle based on a counter, and the filename.
|
||||
#
|
||||
my ($pkg, $name, $file, $delete) = @_;
|
||||
my $fname = sprintf("FH%05d%s", ++$FH, $name);
|
||||
|
||||
$fname =~ s/([:'%])/sprintf '%%%02X', ord $1/eg;
|
||||
my $fh = \do { local *{$fname}; *{$fname} };
|
||||
|
||||
sysopen($fh, $file, O_RDWR | O_EXCL, 0600) or die "Can't open file: $file ($!)";
|
||||
unlink($file) if $delete;
|
||||
bless $fh, $pkg;
|
||||
|
||||
return $fh;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
# -------------------------------------------------------------------
|
||||
# Return the filename, strip off leading junk first.
|
||||
#
|
||||
my $self = shift;
|
||||
my $fn = $$self;
|
||||
$fn =~ s/%(..)/ chr(hex($1)) /eg;
|
||||
$fn =~ s/^\*GT::CGI::Fh::FH\d{5}//;
|
||||
return $fn;
|
||||
}
|
||||
|
||||
sub compare {
|
||||
# -------------------------------------------------------------------
|
||||
# Do comparisions, uses as_string to get file name first.
|
||||
#
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return "$self" cmp $value;
|
||||
}
|
||||
|
||||
DESTROY {
|
||||
# -------------------------------------------------------------------
|
||||
# Close file handle.
|
||||
#
|
||||
my $self = shift;
|
||||
close $self;
|
||||
}
|
||||
|
||||
1;
|
||||
254
site/glist/lib/GT/CGI/MultiPart.pm
Normal file
254
site/glist/lib/GT/CGI/MultiPart.pm
Normal file
@@ -0,0 +1,254 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::MultiPart
|
||||
# CVS Info :
|
||||
# $Id: MultiPart.pm,v 1.5 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Multipart form handling for GT::CGI objects.
|
||||
#
|
||||
# This is taken almost entirely from CGI.pm, and is loaded on demand.
|
||||
#
|
||||
|
||||
package GT::CGI::MultiPart;
|
||||
# ==============================================================================
|
||||
use strict 'vars', 'subs';
|
||||
use GT::CGI;
|
||||
use GT::Base;
|
||||
use GT::TempFile();
|
||||
use vars qw/$DEBUG $ERRORS @ISA $ATTRIBS $CRLF/;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
use constants
|
||||
BLOCK_SIZE => 4096,
|
||||
MAX_READS => 2000;
|
||||
$CRLF = "\015\012";
|
||||
$ATTRIBS = {
|
||||
fh => undef, # web request on stdin
|
||||
buffer => '', # buffer to hold tmp data
|
||||
length => 0, # length of file to parse
|
||||
boundary => undef, # mime boundary to look for
|
||||
fillunit => BLOCK_SIZE, # amount to read per chunk
|
||||
safety => 0 # safety counter
|
||||
};
|
||||
$ERRORS = {
|
||||
NOBOUNDARY => "Unable to find a MIME boundary in environment. Content-type looks like: %s",
|
||||
CLIENTABORT => "Unable to read data from server. Still have %s bytes to read, but got 0. Data in buffer is: %s",
|
||||
BADMULTIPART => "Invalid multipart message. Nothing left to read, and can't find closing boundary. Data in buffer is: %s"
|
||||
};
|
||||
|
||||
sub parse {
|
||||
# -------------------------------------------------------------------
|
||||
# Parses a multipart form to handle file uploads.
|
||||
#
|
||||
my ($class, $cgi) = @_;
|
||||
|
||||
# We override any fatal handlers as our handlers typically create a CGI object
|
||||
# avoiding a nasty loop.
|
||||
local $SIG{__DIE__} = 'DEFAULT';
|
||||
|
||||
# We only load the multipart parser if we have multipart code.
|
||||
my $parser = $class->new or return;
|
||||
|
||||
my ($header, $name, $value, $filename);
|
||||
until ($parser->eof) {
|
||||
$header = $parser->read_header or return die "BADREQUEST";
|
||||
$header->{'Content-Disposition'} =~ m/ name=(?:"([^"]*)"|((?!")[^;]*))/;
|
||||
$name = $1 || $2;
|
||||
($filename) = $header->{'Content-Disposition'} =~ m/ filename="?([^\";]*)"?/;
|
||||
|
||||
# Not a file, just regular form data.
|
||||
if (! defined $filename or $filename eq '') {
|
||||
$value = $parser->read_body;
|
||||
|
||||
# Netscape 6 does some fun things with line feeds in multipart form data
|
||||
$value =~ s/\r\r/\r/g; # What it does on unix
|
||||
$value =~ s/\r\n/\n/g if $^O eq 'MSWin32';
|
||||
unless ($cgi->{params}->{$name}) {
|
||||
push @{$cgi->{param_order}}, $name;
|
||||
}
|
||||
unshift @{$cgi->{params}->{$name}}, $value;
|
||||
next;
|
||||
}
|
||||
|
||||
# Print out the data to a temp file.
|
||||
local $\;
|
||||
my $tmp_file = new GT::TempFile;
|
||||
require GT::CGI::Fh;
|
||||
my $fh = GT::CGI::Fh->new($filename, $$tmp_file, 0);
|
||||
binmode $fh;
|
||||
my $data;
|
||||
while (defined($data = $parser->read)) {
|
||||
print $fh $data;
|
||||
}
|
||||
seek $fh, 0, 0;
|
||||
unless ($cgi->{params}->{$name}) {
|
||||
push @{$cgi->{param_order}}, $name;
|
||||
}
|
||||
unshift @{$cgi->{params}->{$name}}, $fh;
|
||||
}
|
||||
}
|
||||
|
||||
sub init {
|
||||
# -------------------------------------------------------------------
|
||||
# Initilize our object.
|
||||
#
|
||||
$DEBUG = $GT::CGI::DEBUG;
|
||||
|
||||
my $self = shift;
|
||||
|
||||
# Get the boundary marker.
|
||||
my $boundary;
|
||||
if (defined $ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ /boundary=\"?([^\";,]+)\"?/) {
|
||||
$boundary = $1;
|
||||
}
|
||||
else {
|
||||
return $self->error("NOBOUNDARY", "FATAL", $ENV{CONTENT_TYPE});
|
||||
}
|
||||
$self->{boundary} = "--$boundary";
|
||||
|
||||
# Get our filehandle.
|
||||
binmode(STDIN);
|
||||
|
||||
# And if the boundary is > the BLOCK_SIZE, adjust.
|
||||
if (length $boundary > $self->{fillunit}) {
|
||||
$self->{fillunit} = length $boundary;
|
||||
}
|
||||
|
||||
# Set the content-length.
|
||||
$self->{length} = $ENV{CONTENT_LENGTH} || 0;
|
||||
|
||||
# Read the preamble and the topmost (boundary) line plus the CRLF.
|
||||
while ($self->read) { }
|
||||
}
|
||||
|
||||
sub fill_buffer {
|
||||
# -------------------------------------------------------------------
|
||||
# Fill buffer.
|
||||
#
|
||||
my ($self, $bytes) = @_;
|
||||
|
||||
return unless $self->{length};
|
||||
|
||||
my $boundary_length = length $self->{boundary};
|
||||
my $buffer_length = length $self->{buffer};
|
||||
my $bytes_to_read = $bytes - $buffer_length + $boundary_length + 2;
|
||||
$bytes_to_read = $self->{length} if $self->{length} < $bytes_to_read;
|
||||
|
||||
my $bytes_read = read(STDIN, $self->{buffer}, $bytes_to_read, $buffer_length);
|
||||
if (! defined $self->{buffer}) {
|
||||
$self->{buffer} = '';
|
||||
}
|
||||
if ($bytes_read == 0) {
|
||||
if ($self->{safety}++ > MAX_READS) {
|
||||
return $self->error(CLIENTABORT => FATAL => $self->{length}, $self->{buffer});
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{safety} = 0;
|
||||
}
|
||||
|
||||
$self->{length} -= $bytes_read;
|
||||
}
|
||||
|
||||
sub read {
|
||||
# -------------------------------------------------------------------
|
||||
# Read some input.
|
||||
#
|
||||
my $self = shift;
|
||||
my $bytes = $self->{fillunit};
|
||||
|
||||
# Load up self->{buffer} with data.
|
||||
$self->fill_buffer($bytes);
|
||||
|
||||
# find the boundary (if exists).
|
||||
my $start = index($self->{buffer}, $self->{boundary});
|
||||
|
||||
# Make sure the post was formed properly.
|
||||
unless (($start >= 0) or ($self->{length} > 0)) {
|
||||
return $self->error(BADMULTIPART => FATAL => $self->{buffer});
|
||||
}
|
||||
|
||||
if ($start == 0) {
|
||||
# Quit if we found the last boundary at the beginning.
|
||||
if (index($self->{buffer},"$self->{boundary}--") == 0) {
|
||||
$self->{buffer} = '';
|
||||
$self->{length} = 0;
|
||||
return;
|
||||
}
|
||||
# Otherwise remove the boundary (+2 to remove line feeds).
|
||||
substr($self->{buffer}, 0, length ($self->{boundary}) + 2) = '';
|
||||
return;
|
||||
}
|
||||
|
||||
my $bytes_to_return;
|
||||
if ($start > 0) {
|
||||
$bytes_to_return = $start > $bytes ? $bytes : $start;
|
||||
}
|
||||
else {
|
||||
$bytes_to_return = $bytes - length($self->{boundary}) + 1;
|
||||
}
|
||||
|
||||
my $return = substr($self->{buffer}, 0, $bytes_to_return);
|
||||
substr($self->{buffer}, 0, $bytes_to_return) = '';
|
||||
|
||||
return $start > 0 ? substr($return, 0, -2) : $return;
|
||||
}
|
||||
|
||||
sub read_header {
|
||||
# -------------------------------------------------------------------
|
||||
# Reads the header.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($ok, $bad, $end, $safety) = (0, 0);
|
||||
until ($ok or $bad) {
|
||||
$self->fill_buffer($self->{fillunit});
|
||||
|
||||
$ok++ if ($end = index($self->{buffer}, "$CRLF$CRLF")) >= 0;
|
||||
$ok++ if $self->{buffer} eq '';
|
||||
$bad++ if !$ok and $self->{length} <= 0;
|
||||
return if $safety++ >= 10;
|
||||
}
|
||||
|
||||
return if $bad;
|
||||
|
||||
my $header = substr($self->{buffer}, 0, $end + 2);
|
||||
substr($self->{buffer}, 0, $end + 4) = '';
|
||||
|
||||
my %header;
|
||||
my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
|
||||
$header =~ s/$CRLF\s+/ /og;
|
||||
while ($header =~ /($token+):\s+([^$CRLF]*)/go) {
|
||||
my ($field_name,$field_value) = ($1,$2);
|
||||
$field_name =~ s/\b(\w)/\u$1/g;
|
||||
$header{$field_name} = $field_value;
|
||||
}
|
||||
return \%header;
|
||||
}
|
||||
|
||||
sub read_body {
|
||||
# -------------------------------------------------------------------
|
||||
# Reads a body and returns as a single scalar value.
|
||||
#
|
||||
my $self = shift;
|
||||
my $data = '';
|
||||
my $return = '';
|
||||
while (defined($data = $self->read)) {
|
||||
$return .= $data;
|
||||
}
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub eof {
|
||||
# -------------------------------------------------------------------
|
||||
# Return true when we've finished reading.
|
||||
#
|
||||
my $self = shift;
|
||||
return 1 if length $self->{buffer} == 0 and $self->{length} <= 0;
|
||||
}
|
||||
|
||||
1;
|
||||
245
site/glist/lib/GT/Cache.pm
Normal file
245
site/glist/lib/GT/Cache.pm
Normal file
@@ -0,0 +1,245 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Cache
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Cache.pm,v 1.13 2004/01/13 01:35:15 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements a tied hash cache that will not grow forever, but expire
|
||||
# old/unused entries. Useful under mod_perl.
|
||||
#
|
||||
|
||||
package GT::Cache;
|
||||
# ===============================================================
|
||||
use vars qw /$DEBUG $VERSION $CACHE_SIZE/;
|
||||
use strict;
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
|
||||
$CACHE_SIZE = 500;
|
||||
|
||||
##
|
||||
# tie %cache, 'GT::Cache', $size, \&function;
|
||||
# ----------------------------
|
||||
# Is called when you tie a hash to this
|
||||
# class. The size should be the size limit
|
||||
# you want on your hash. If not specified
|
||||
# this will default to the CLASS variable
|
||||
# $CACH_SIZE which is initialized to 500
|
||||
##
|
||||
sub TIEHASH {
|
||||
my $this = shift;
|
||||
my $size = shift || $CACHE_SIZE;
|
||||
my $code = shift || sub {undef};
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {
|
||||
cache_size => $size,
|
||||
popularity => [],
|
||||
content => {},
|
||||
indices => {},
|
||||
is_indexed => 0,
|
||||
size => 0,
|
||||
code => $code,
|
||||
}, $class;
|
||||
$#{$self->{popularity}} = $size;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my ($self, $key) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
unless (exists $self->{content}->{$key}) {
|
||||
my $val = $self->{code}->($key);
|
||||
defined $val or return undef;
|
||||
$self->STORE ($key, $val);
|
||||
return $val;
|
||||
}
|
||||
if ($self->{is_indexed}) {
|
||||
my ($pos1, $pos2, $replace);
|
||||
|
||||
$pos1 = $self->{content}->{$key}->[1];
|
||||
$pos2 = $pos1 + (int (rand( ($self->{cache_size} - $pos1) / 2) )) || 1;
|
||||
|
||||
$replace = ${$self->{popularity}}[$pos2];
|
||||
|
||||
${$self->{popularity}}[$pos2] = $key;
|
||||
$self->{content}->{$key}->[1] = $pos2;
|
||||
if (defined $replace) {
|
||||
${$self->{popularity}}[$pos1] = $replace;
|
||||
$self->{content}->{$replace}->[1] = $pos1;
|
||||
}
|
||||
}
|
||||
return $self->{content}->{$key}->[0];
|
||||
}
|
||||
|
||||
##
|
||||
# %cash = (key1 => $field1, key2 => $val2);
|
||||
# -----------------------------------------
|
||||
# $cash{key} = $val;
|
||||
# ------------------
|
||||
# Called when you store something in the hash.
|
||||
# This will check the number of elements in the
|
||||
# hash and delete the oldest one if the limit.
|
||||
# is reached.
|
||||
##
|
||||
sub STORE {
|
||||
my ($self, $key, $value) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
my ($replace, $insid);
|
||||
if ($self->{is_indexed}) {
|
||||
$insid = int (rand($self->{cache_size} / 2)) || 1;
|
||||
if (defined ($replace = ${$self->{popularity}}[$insid])) {
|
||||
delete $self->{content}->{$replace};
|
||||
undef ${$self->{popularity}}[$insid];
|
||||
}
|
||||
${$self->{popularity}}[$insid] = $key;
|
||||
$self->{content}->{$key} = [$value, $insid];
|
||||
}
|
||||
else {
|
||||
${$self->{popularity}}[$self->{size}] = $key;
|
||||
$self->{content}->{$key} = [$value, $self->{size}];
|
||||
if ($self->{size} == $self->{cache_size}) {
|
||||
for (0 .. $#{$self->{popularity}}) {
|
||||
next unless defined $self->{popularity}[$_];
|
||||
$self->{content}{$self->{popularity}[$_]}[1] = $_;
|
||||
}
|
||||
$self->{is_indexed} = 1;
|
||||
}
|
||||
$self->{size}++;
|
||||
}
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $key) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
exists $self->{content}->{$key} or return undef;
|
||||
$self->{size}--;
|
||||
my $aref = delete $self->{content}->{$key};
|
||||
undef $self->{popularity}->[$aref->[1]];
|
||||
return $aref->[0];
|
||||
}
|
||||
|
||||
sub CLEAR {
|
||||
my $self = shift;
|
||||
$self->{content} = {};
|
||||
$self->{size} = 0;
|
||||
$self->{popularity} = [];
|
||||
$self->{is_indexed} = 0;
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my ($self, $key) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
return exists $self->{content}->{$key} ? 1 : 0;
|
||||
}
|
||||
|
||||
sub FIRSTKEY {
|
||||
my $self = shift;
|
||||
my $c = keys %{$self->{content}};
|
||||
return scalar each %{$self->{content}};
|
||||
}
|
||||
|
||||
sub NEXTKEY {return scalar each %{shift()->{content}}}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Cache - Tied hash which caches output of functions.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Cache;
|
||||
my %cache;
|
||||
tie %cache, 'GT::Cache', $size, \&function;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Cache implements a simple but quick caching scheme for remembering
|
||||
the results of functions. It also implements a max size to prevent
|
||||
the cache from growing and drops least frequently requested entries
|
||||
first, making it very useful under mod_perl.
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
use GT::Cache;
|
||||
my %cache;
|
||||
tie %cache, 'GT::Cache', 100, \&complex_func;
|
||||
|
||||
while (<>) {
|
||||
print "RESULT: ", $cache{$_}, "\n";
|
||||
}
|
||||
|
||||
sub complex_func {
|
||||
my $input = shift;
|
||||
# .. do complex work.
|
||||
return $output;
|
||||
}
|
||||
|
||||
This will cache the results of complex_func, and only run it when
|
||||
the input is different. It stores a max of 100 entries at a time,
|
||||
with the least frequently requested getting dropped first.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
Currently, you can only pass as input to the function a single
|
||||
scalar, and the output must be a single scalar. See the
|
||||
Memoize module in CPAN for a much more robust implementation.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Cache.pm,v 1.13 2004/01/13 01:35:15 jagerman Exp $
|
||||
|
||||
=cut
|
||||
927
site/glist/lib/GT/Config.pm
Normal file
927
site/glist/lib/GT/Config.pm
Normal file
@@ -0,0 +1,927 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Config
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Config.pm,v 1.45 2005/03/21 05:49:39 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# A module for handling loading and caching of configuration files.
|
||||
#
|
||||
|
||||
package GT::Config;
|
||||
# ===============================================================
|
||||
|
||||
use strict;
|
||||
|
||||
use GT::Base qw/PERSIST/; # Due to the nature of the config file's hash-like interface, we can't inherit from GT::Base - it sets things in $self. We do need GT::Base for its in_eval function though.
|
||||
use GT::Template::Inheritance;
|
||||
use GT::AutoLoader;
|
||||
|
||||
use constants
|
||||
DATA => 0,
|
||||
INHERITED => 1,
|
||||
FILES => 2,
|
||||
FILES_MOD => 3,
|
||||
CODE_STR => 4;
|
||||
|
||||
use vars qw(%ATT %ATTRIBS %CACHE %SUB_CACHE $error $ERRORS $VERSION);
|
||||
|
||||
# %ATT stores the default attribute values
|
||||
# %ATTRIBS stores the attributes of each object. Since each object works exactly
|
||||
# like a hash ref of the data it represents, these attributes cannot be stored
|
||||
# in $self.
|
||||
# %CACHE is used to cache any data of objects using the 'cache' option. Each
|
||||
# file in here has an array ref value - the first value is a hash ref of the
|
||||
# data, the second a hash ref of inherited keys, the third an array of the
|
||||
# files inherited from, and the fourth a hash of [size, last modification
|
||||
# time] pairs of those files.
|
||||
# %SUB_CACHE is exactly like %CACHE, except that values starting with 'sub {'
|
||||
# will be compiled into code refs. Each array ref has a fifth value - a hash
|
||||
# reference list that stores the original value of any code refs that have
|
||||
# been compiled. %SUB_CACHE is only used when you use 'compile_subs'. Also,
|
||||
# because different packages can be specified, this stores which package the
|
||||
# code ref was compiled in.
|
||||
# $error stores any error that occurs. If a load error happens, you'll need to
|
||||
# use $error to get the error message (when not using the 'create_ok' option).
|
||||
# $ERRORS stores all the error codes
|
||||
# $VERSION - $Id: Config.pm,v 1.45 2005/03/21 05:49:39 jagerman Exp $ - The version.
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.45 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
%ATT = (
|
||||
inheritance => 0, # If set, looks for .tplinfo files for inheritance.
|
||||
local => 0, # If set, will look for "local" directories containing the file. The file will be saved in a "local" subdirectory of the directory given.
|
||||
cache => 1, # If set, GT::Config will look in the cache for the object; objects are always stored in the cache, so that ->load(cache => 0) can be used to reload a file.
|
||||
create_ok => 0, # If set, you'll get a GT::Config object even if the file doesn't exist. You can then save() it to create the file. If not set, a fatal error occurs if the file cannot be located. Note that if the file exists, but has a syntax error, or cannot be read, a fatal error will occur regardless of this option.
|
||||
empty => 0, # If specified, nothing will be read from disk - can be used to force a new, blank config file
|
||||
chmod => 0666, # The octal permissions to set on the file immediately after saving
|
||||
strict => 0, # If true, a fatal error will occur when attempting to access a key that does not exist.
|
||||
debug => 0, # If true, warnings and debugging will be printing to STDERR
|
||||
tmpfile => undef, # Possible values: 0, undef, 1. 0 = no tempfile, undef = tempfile if dir writable, 1 = always tempfile
|
||||
header => '', # Can be set to anything. When saving, this will go before the data. Keep in mind, this has to be correct Perl. [localtime] in here will be replaced with scalar localtime() when saving.
|
||||
compile_subs => '', # Must be set to a package. If set, any value that starts with 'sub {' will be compiled into a code ref, in the package specified.
|
||||
sort_order => undef, # Passed to GT::Dumper->dump as 'order' value if set
|
||||
tab => "\t", # What to use for a "tab" in the config file. Defaults to an actual tab.
|
||||
);
|
||||
|
||||
# Other attributes used internally:
|
||||
# filename => '', # Whatever you give as the filename
|
||||
# file => '', # Just the filename (no path)
|
||||
# path => '', # The path of the filename
|
||||
# files => {}, # A hash of filename => last_mod_time (may contain multiple entries to support inheritance).
|
||||
# file_order => [], # The order of the files in 'files'
|
||||
# data => {}, # The actual data of the config file.
|
||||
# inherited => {}, # Each base key inherited will have $key => 1 in here. Inherited keys are not saved, unless they are changed between load time and save time.
|
||||
# compiled => {}, # Any keys that start with 'sub {' will be compiled into code refs if the compile_subs option is on. The code reference is saved here so that recompiling is not necessary
|
||||
|
||||
$ERRORS = {
|
||||
CANT_LOAD => q _Unable to load '%s': %s._,
|
||||
CANT_COMPILE => q _Unable to compile '%s': %s._,
|
||||
CANT_FIND => q _Config file '%s' does not exist in directory '%s' or has incorrect permissions set._,
|
||||
CANT_WRITE => q _Unable to open '%s' for writing: %s._,
|
||||
CANT_PRINT => q _Unable to write to file '%s': %s._,
|
||||
CANT_RENAME => q _Unable to move '%s' to '%s': %s._,
|
||||
WRITE_MISMATCH => q _Unable to save '%s': wrote %d bytes, but file is %d bytes_,
|
||||
CANT_CREATE_DIR => q _Unable to create directory '%s': %s._,
|
||||
NOT_HASH => q _Config file '%s' did not return a hash reference._,
|
||||
BAD_ARGS => q _Bad arguments. Usage: %s_,
|
||||
NOT_FILE => q _'%s' does not look like a valid filename_,
|
||||
RECURSION => q _Recursive inheritance detected and interrupted: '%s'_,
|
||||
UNKNOWN_OPT => q _Unknown option '%s' passed to %s_,
|
||||
BAD_KEY => q _The key you attempted to access, '%s', does not exist in '%s'_,
|
||||
CANT_COMPILE_CODE => q _Unable to compile '%s' in file '%s': %s_
|
||||
};
|
||||
|
||||
sub load {
|
||||
my $class = shift;
|
||||
|
||||
my (%attribs, %data);
|
||||
|
||||
tie %data, $class, \%attribs;
|
||||
my $self = bless \%data, ref $class || $class;
|
||||
|
||||
$ATTRIBS{$self} = \%attribs; # hehehe ;-)
|
||||
|
||||
my $filename = shift or return $self->error(BAD_ARGS => FATAL => 'GT::Config->load("/path/to/config/file", { opts })');
|
||||
$attribs{filename} = $filename;
|
||||
$attribs{filename_given} = $filename;
|
||||
|
||||
@attribs{'path', 'file'} = ($filename =~ m|^(.*?)[\\/]?([^\\/]+)$|) or return $self->error(NOT_FILE => FATAL => $filename);
|
||||
$attribs{path} = '.' unless length $attribs{path};
|
||||
$filename = $attribs{filename} = "$attribs{path}/$attribs{file}"; # _load_data/_load_tree depend on it being like this.
|
||||
|
||||
my $opts = shift || {};
|
||||
ref $opts eq 'HASH' or return $self->error(BAD_ARGS => FATAL => 'GT::Config->load("/path/to/config/file", { opts })');
|
||||
|
||||
for (keys %ATT) {
|
||||
if (/^(?:inheritance|local|cache|create_ok|strict|empty)$/) {
|
||||
$attribs{$_} = exists $opts->{$_} ? (delete $opts->{$_} ? 1 : 0) : $ATT{$_};
|
||||
}
|
||||
elsif ($_ eq 'tmpfile') {
|
||||
if (exists $opts->{$_}) {
|
||||
my $tmpfile = delete $opts->{$_};
|
||||
$attribs{$_} = defined($tmpfile) ? $tmpfile ? 1 : 0 : undef;
|
||||
}
|
||||
else {
|
||||
$attribs{$_} = $ATT{$_};
|
||||
}
|
||||
}
|
||||
else {
|
||||
$attribs{$_} = exists $opts->{$_} ? delete $opts->{$_} : $ATT{$_};
|
||||
}
|
||||
}
|
||||
|
||||
$self->debug("Received '$filename' for the file to load", 2) if $attribs{debug} >= 2;
|
||||
|
||||
if (keys %$opts) {
|
||||
$self->error(UNKNOWN_OPT => FATAL => keys %$opts => ref($self) . '->load');
|
||||
}
|
||||
|
||||
$self->debug("Loading '$filename' with options: inheritance => '$attribs{inheritance}', local => '$attribs{local}', cache => '$attribs{cache}', create_ok => '$attribs{create_ok}', empty => '$attribs{empty}', chmod => '$attribs{chmod}', strict => '$attribs{strict}', debug => '$attribs{debug}', compile_subs => '$attribs{compile_subs}'") if $attribs{debug};
|
||||
$self->debug("Header: '$attribs{header}'", 2) if $attribs{debug} >= 2;
|
||||
|
||||
if ($attribs{empty}) {
|
||||
# An empty config file doesn't get added to the cache
|
||||
$self->debug("Not loading any data or cache - 'empty' specified") if $attribs{debug};
|
||||
}
|
||||
elsif ($attribs{cache} and $attribs{compile_subs} and $SUB_CACHE{$attribs{compile_subs}}->{$filename} and my $debug_unchanged = $self->_is_unchanged(@{$SUB_CACHE{$attribs{compile_subs}}->{$filename}}[FILES, FILES_MOD])) {
|
||||
$self->debug("Loading '$filename' from compiled sub cache") if $attribs{debug};
|
||||
@attribs{qw{data inherited file_order files compiled}} = @{$SUB_CACHE{$attribs{compile_subs}}->{$filename}};
|
||||
$attribs{cache_hit} = 1;
|
||||
}
|
||||
elsif ($attribs{cache} and not $attribs{compile_subs} and $CACHE{$filename} and $debug_unchanged = $self->_is_unchanged(@{$CACHE{$filename}}[FILES, FILES_MOD])) {
|
||||
$self->debug("Loading '$filename' from regular cache") if $attribs{debug};
|
||||
@attribs{qw{data inherited file_order files}} = @{$CACHE{$filename}};
|
||||
$attribs{cache_hit} = 1;
|
||||
}
|
||||
else {
|
||||
$self->debug("Not loading '$filename' from cache") if $attribs{debug};
|
||||
if ($attribs{debug} > 1) { # If the debug level is > 1, display some debugging as to _why_ we aren't loading from cache
|
||||
$self->debug("Reason: Caching disabled") if not $attribs{cache};
|
||||
if ($attribs{compile_subs} and not $SUB_CACHE{$attribs{compile_subs}}->{$filename}) { $self->debug("Reason: Not in compiled sub cache") }
|
||||
elsif (not $attribs{compile_subs} and not $CACHE{$filename}) { $self->debug("Reason: Not in regular cache") }
|
||||
$self->debug("Reason: File (or inherited files) have changed") if ($attribs{compile_subs} ? $SUB_CACHE{$attribs{compile_subs}}->{$filename} : $CACHE{$filename}) and not $debug_unchanged;
|
||||
}
|
||||
$self->_load_data($filename) or return;
|
||||
if (@{$attribs{file_order}}) { # Don't cache it if it is a new object
|
||||
if ($attribs{compile_subs}) {
|
||||
$self->debug("Adding '$filename' (compile package '$attribs{compile_subs}') to the compiled sub cache") if $attribs{debug};
|
||||
$SUB_CACHE{$attribs{compile_subs}}->{$filename} = [@attribs{qw{data inherited file_order files compiled}}];
|
||||
}
|
||||
else {
|
||||
$self->debug("Adding '$filename' to the regular cache") if $attribs{debug};
|
||||
$CACHE{$filename} = [@attribs{qw{data inherited file_order files}}];
|
||||
}
|
||||
}
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{save} = __LINE__ . <<'END_OF_SUB';
|
||||
sub save {
|
||||
require GT::Dumper;
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
my ($d, $i) = @$att{'data', 'inherited'};
|
||||
|
||||
my %data;
|
||||
for (keys %$d) { # Strip out all inherited data
|
||||
next if $i->{$_};
|
||||
|
||||
$data{$_} = $d->{$_};
|
||||
}
|
||||
|
||||
my $filename = $att->{path};
|
||||
|
||||
local $!;
|
||||
if ($att->{local}) {
|
||||
$filename .= "/local";
|
||||
if (!-d $filename) { # $filename is misleading - it's currently a path
|
||||
# Attempt to create the "local" directory
|
||||
mkdir($filename, 0777) or return $self->error(CANT_CREATE_DIR => FATAL => $filename => "$!");
|
||||
CORE::chmod(0777, $filename);
|
||||
}
|
||||
}
|
||||
|
||||
my $tmpfile = $att->{tmpfile};
|
||||
if (not defined $tmpfile) {
|
||||
# Base whether or not we use the tempfile on whether or not we can
|
||||
# write to the base directory of the file:
|
||||
$tmpfile = -w $filename;
|
||||
}
|
||||
|
||||
$filename .= "/$att->{file}";
|
||||
|
||||
$self->debug("Saving '$filename'") if $att->{debug};
|
||||
|
||||
my $localtime = scalar localtime;
|
||||
my $header = $att->{header};
|
||||
if ($header) {
|
||||
$header =~ s/\[localtime\]/$localtime/g;
|
||||
$header .= "\n" unless $header =~ /\n$/;
|
||||
}
|
||||
|
||||
my $write_filename = $tmpfile ? "$filename.tmp.$$." . time . "." . int rand 10000 : $filename;
|
||||
my $printed = 0;
|
||||
my $windows = $^O eq 'MSWin32';
|
||||
|
||||
local *FILE;
|
||||
open FILE, "> $write_filename" or return $self->error(CANT_WRITE => FATAL => $write_filename => "$!");
|
||||
# Print header, if any:
|
||||
if ($header) {
|
||||
$printed += length $header;
|
||||
$printed += $header =~ y/\n// if $windows; # Windows does \n => \r\n translation on FH output
|
||||
unless (print FILE $header) {
|
||||
my $err = "$!";
|
||||
close FILE;
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
||||
}
|
||||
}
|
||||
# Print actual data:
|
||||
my $dump = GT::Dumper->dump(
|
||||
var => '',
|
||||
data => \%data,
|
||||
sort => 1,
|
||||
$att->{sort_order} ? (order => $att->{sort_order}) : (),
|
||||
tab => $att->{tab}
|
||||
);
|
||||
$printed += length $dump;
|
||||
$printed += $dump =~ y/\n// if $windows;
|
||||
unless (print FILE $dump) {
|
||||
my $err = "$!";
|
||||
close FILE;
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
||||
}
|
||||
# Print the vim info line at the bottom:
|
||||
my $viminfo = "\n# vim:syn=perl:ts=4:noet\n";
|
||||
$printed += length $viminfo;
|
||||
$printed += $viminfo =~ y/\n// if $windows;
|
||||
unless (print FILE $viminfo) {
|
||||
my $err = "$!";
|
||||
close FILE;
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
||||
}
|
||||
|
||||
close FILE;
|
||||
|
||||
# Check that the file is the right size, because print() returns true if a
|
||||
# _partial_ print succeeded. Ideally we would check -s on the filehandle after
|
||||
# each print, but of course that doesn't work on Windows.
|
||||
unless ((my $actual = -s $write_filename) == $printed) {
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(WRITE_MISMATCH => FATAL => $write_filename => $printed => $actual);
|
||||
}
|
||||
|
||||
if ($tmpfile) {
|
||||
$self->debug("'$write_filename' saved; renaming to '$filename'") if $att->{debug} > 1;
|
||||
unless (rename $write_filename, $filename) {
|
||||
my $err = "$!";
|
||||
unlink $write_filename;
|
||||
return $self->error(CANT_RENAME => FATAL => $write_filename => $filename => $err);
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $att->{chmod}) {
|
||||
my $mode = (stat $filename)[2] & 07777;
|
||||
CORE::chmod($att->{chmod}, $filename) unless $att->{chmod} == $mode;
|
||||
}
|
||||
$self->debug("'$filename' saved, $printed bytes.") if $att->{debug};
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Returns true if the current object was loaded from cache, false otherwise.
|
||||
sub cache_hit { $ATTRIBS{$_[0]}->{cache_hit} }
|
||||
|
||||
sub _is_unchanged {
|
||||
my ($self, $old_order, $old_mod) = @_;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$self->debug("Checking for any changes in the file (or inherited files)") if $att->{debug};
|
||||
|
||||
my @old_order = @$old_order; # Copy the old file_order and file modification
|
||||
my %old_mod = %$old_mod; # times. _load_tree will replace them.
|
||||
|
||||
my $just_do_ok = not (PERSIST or $att->{inheritance} or $att->{local} or $att->{create_ok});
|
||||
|
||||
$self->_load_tree($just_do_ok);
|
||||
|
||||
if (@{$att->{file_order}} != @old_order) {
|
||||
$self->debug("The old order and the new differ: Old: (@old_order) New: (@{$att->{file_order}})") if $att->{debug};
|
||||
return;
|
||||
}
|
||||
for (0 .. $#old_order) {
|
||||
if ($old_order[$_] ne $att->{file_order}->[$_]) {
|
||||
$self->debug("The old order and the new differ: Old: (@old_order) New: (@{$att->{file_order}})") if $att->{debug};
|
||||
return; # The inherited files are not the same as before
|
||||
}
|
||||
elsif ($att->{debug} >= 2) {
|
||||
$self->debug("Old order and new order do not differ. Old: (@old_order) New: (@{$att->{file_order}})");
|
||||
}
|
||||
|
||||
if ($old_mod{$old_order[$_]}->[0] != $att->{files}->{$old_order[$_]}->[0]) {
|
||||
$self->debug("The file size of $old_order[$_] has changed: Old: $old_mod{$old_order[$_]}->[0], New: $att->{files}->{$old_order[$_]}->[0]") if $att->{debug};
|
||||
return; # The inherited files have changed in size
|
||||
}
|
||||
elsif ($old_mod{$old_order[$_]}->[1] != $att->{files}->{$old_order[$_]}->[1]) {
|
||||
$self->debug("The modification time of $old_order[$_] has changed: Old: $old_mod{$old_order[$_]}->[1], New: $att->{files}->{$old_order[$_]}->[1]") if $att->{debug};
|
||||
return; # The inherited files have a changed mtime
|
||||
}
|
||||
elsif ($att->{debug} >= 2) {
|
||||
$self->debug("The file size and modification time of $old_order[$_] has not changed");
|
||||
}
|
||||
}
|
||||
|
||||
$self->debug("No changes have been made") if $att->{debug};
|
||||
1; # Here's the prize. Nothing is changed.
|
||||
}
|
||||
|
||||
sub _load_data {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
my $just_do_ok = not (PERSIST or $att->{inheritance} or $att->{local} or $att->{create_ok});
|
||||
|
||||
$self->_load_tree($just_do_ok) or return;
|
||||
|
||||
if ($just_do_ok and not @{$att->{file_order}}) {
|
||||
push @{$att->{file_order}}, $att->{filename_given};
|
||||
}
|
||||
|
||||
for my $file (@{$att->{file_order}}) {
|
||||
local ($@, $!, $^W);
|
||||
$self->debug("do()ing '$file'") if $att->{debug} >= 2;
|
||||
my $data = do $file;
|
||||
if (!$data and $@) {
|
||||
return $self->error(CANT_LOAD => FATAL => $file => "$@");
|
||||
}
|
||||
elsif (!$data and $!) {
|
||||
return $self->error(CANT_COMPILE => FATAL => $file => "$!");
|
||||
}
|
||||
elsif (ref $data ne 'HASH') {
|
||||
return $self->error(NOT_HASH => FATAL => $file);
|
||||
}
|
||||
if ($just_do_ok or $file eq ($att->{local} ? "$att->{path}/local/$att->{file}" : $att->{filename})) {
|
||||
$att->{data} = $data;
|
||||
}
|
||||
else {
|
||||
for (keys %$data) {
|
||||
next if exists $att->{data}->{$_};
|
||||
$att->{data}->{$_} = $data->{$_};
|
||||
$att->{inherited}->{$_} = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1; # Returning true means loading was successful.
|
||||
}
|
||||
|
||||
sub _load_tree {
|
||||
my $self = shift;
|
||||
my $just_do_ok = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
my $root = $att->{path};
|
||||
my $file = $att->{file};
|
||||
|
||||
if ($att->{inheritance}) {
|
||||
$att->{file_order} = [GT::Template::Inheritance->get_all_paths(file => $att->{file}, path => $att->{path})];
|
||||
|
||||
unless (@{$att->{file_order}} or $att->{create_ok} or $just_do_ok) {
|
||||
return $self->error('CANT_FIND' => 'FATAL', $att->{file}, $att->{path});
|
||||
# No files found!
|
||||
}
|
||||
|
||||
for (@{$att->{file_order}}) {
|
||||
$att->{files}->{$_} = [(stat($_))[7, 9]];
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (-e "$root/$file") {
|
||||
$att->{file_order} = ["$root/$file"];
|
||||
$att->{files}->{"$root/$file"} = [(stat("$root/$file"))[7, 9]];
|
||||
}
|
||||
elsif ($att->{create_ok} or $just_do_ok) {
|
||||
$att->{file_order} = [];
|
||||
}
|
||||
else {
|
||||
return $self->error(CANT_FIND => FATAL => $att->{file}, $att->{path});
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
$COMPILE{inheritance} = __LINE__ . <<'END_OF_SUB';
|
||||
sub inheritance {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$att->{inheritance};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{tmpfile} = __LINE__ . <<'END_OF_SUB';
|
||||
sub tmpfile {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{tmpfile};
|
||||
my $tmpfile = shift;
|
||||
$tmpfile = defined($tmpfile) ? $tmpfile ? 1 : 0 : undef;
|
||||
$att->{tmpfile} = $tmpfile;
|
||||
return $ret;
|
||||
}
|
||||
$att->{tmpfile};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Must be specified in load() - this only retrieves the value
|
||||
$COMPILE{create_ok} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_ok {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$att->{create_ok};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{chmod} = __LINE__ . <<'END_OF_SUB';
|
||||
sub chmod {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{chmod};
|
||||
$att->{chmod} = shift;
|
||||
return $ret;
|
||||
}
|
||||
$att->{chmod};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Must be specified in load()
|
||||
$COMPILE{cache} = __LINE__ . <<'END_OF_SUB';
|
||||
sub cache {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$att->{cache};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{strict} = __LINE__ . <<'END_OF_SUB';
|
||||
sub strict {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{strict} ? 1 : 0;
|
||||
$att->{strict} = shift() ? 1 : 0;
|
||||
return $ret;
|
||||
}
|
||||
$att->{strict};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{debug_level} = __LINE__ . <<'END_OF_SUB';
|
||||
sub debug_level {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{debug};
|
||||
$att->{debug} = shift;
|
||||
return $ret;
|
||||
}
|
||||
$att->{debug};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{debug} = __LINE__ . <<'END_OF_SUB';
|
||||
sub debug {
|
||||
# -------------------------------------------------------
|
||||
# Displays a debugging message.
|
||||
#
|
||||
my ($self, $msg, $min) = @_;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
$min ||= 1;
|
||||
return if $att->{debug} < $min;
|
||||
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
# Add line numbers if no \n on the debug message
|
||||
if (substr($msg, -1) ne "\n") {
|
||||
my ($file, $line) = (caller)[1,2];
|
||||
$msg .= " at $file line $line.\n";
|
||||
}
|
||||
|
||||
# Remove windows linefeeds (breaks unix terminals).
|
||||
$msg =~ s/\r//g unless $^O eq 'MSWin32';
|
||||
|
||||
print STDERR "$pkg ($$): $msg";
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{header} = __LINE__ . <<'END_OF_SUB';
|
||||
sub header {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{header};
|
||||
$att->{header} = shift || '';
|
||||
return $ret;
|
||||
}
|
||||
$att->{header};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Be sure to delete the object from %ATTRIBS.
|
||||
sub DESTROY {
|
||||
delete $ATTRIBS{$_[0]} if keys %ATTRIBS and exists $ATTRIBS{$_[0]};
|
||||
}
|
||||
|
||||
$COMPILE{error} = __LINE__ . <<'END_OF_SUB';
|
||||
sub error {
|
||||
my ($self, $code, $type, @args) = @_;
|
||||
$type = $type && uc $type eq 'WARN' ? 'WARN' : 'FATAL';
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
$error = _format_err($pkg, $code, @args);
|
||||
|
||||
if ($type eq 'FATAL') {
|
||||
die $error if GT::Base::in_eval();
|
||||
|
||||
if ($SIG{__DIE__}) {
|
||||
die $error;
|
||||
}
|
||||
else {
|
||||
print STDERR $error;
|
||||
die "\n";
|
||||
}
|
||||
}
|
||||
elsif ($ATTRIBS{$self}->{debug}) { # A warning, and debugging is on
|
||||
if ($SIG{__WARN__}) {
|
||||
CORE::warn $error;
|
||||
}
|
||||
else {
|
||||
print STDERR $error;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub _format_err {
|
||||
# -------------------------------------------------------
|
||||
# Formats an error message for output.
|
||||
#
|
||||
my ($pkg, $code, @args) = @_;
|
||||
my $msg = sprintf($ERRORS->{$code} || $code, @args);
|
||||
|
||||
my ($file, $line) = GT::Base::get_file_line($pkg);
|
||||
return "$pkg ($$): $msg at $file line $line.\n";
|
||||
}
|
||||
|
||||
# Tied hash handling
|
||||
sub TIEHASH { bless $_[1], $_[0] }
|
||||
sub STORE {
|
||||
$_[0]->{data}->{$_[1]} = $_[2];
|
||||
delete $_[0]->{inherited}->{$_[1]};
|
||||
delete $_[0]->{compiled}->{$_[1]};
|
||||
}
|
||||
sub FETCH {
|
||||
my $att = shift; # $_[0] is NOT $self - it is the attribute hashref
|
||||
my $key = shift;
|
||||
|
||||
if ($att->{strict} and not exists $att->{data}->{$key}) {
|
||||
return GT::Config->error(BAD_KEY => FATAL => $key, $att->{filename});
|
||||
}
|
||||
elsif ($att->{compile_subs} and not ref $att->{data}->{$key} and substr($att->{data}->{$key}, 0, 5) eq 'sub {') {
|
||||
return $att->{compiled}->{$key} if exists $att->{compiled}->{$key};
|
||||
|
||||
my ($code, $err);
|
||||
# Perl breaks when the eval below contains a 'use' statement. Somehow, Perl
|
||||
# thinks it's deeper (in terms of { ... }) than it really is, and so ends up
|
||||
# either exiting the subroutine prematurely, or, if we try to work around that
|
||||
# by using another subroutine, or returning early, by jumping back one
|
||||
# subroutine too many with its return value. So, to get around the whole
|
||||
# problem, we wrap the code in double-evals if it contains 'use' or 'BEGIN'.
|
||||
# It won't _break_ anything, but unfortunately it does slow compiled_subs
|
||||
# globals a little bit slower.
|
||||
if ($att->{data}->{$key} =~ /\b(use|no)\s+[\w:]/ or $att->{data}->{$key} =~ /\bBEGIN\b/) {
|
||||
$code = eval "package $att->{compile_subs}; my \$ret = eval qq|\Q$att->{data}->{$key}\E|; die qq|\$\@\n| if \$\@; \$ret;";
|
||||
}
|
||||
else {
|
||||
$code = eval "package $att->{compile_subs}; $att->{data}->{$key};";
|
||||
}
|
||||
$err = "$@";
|
||||
|
||||
# Perl prior to 5.6.1 breaks on this:
|
||||
# perl -e 'my $c = eval "package SomePkg; sub bar { use NotThere }"; eval "package OtherPkg; print 1"; die "$@" if $@'
|
||||
# From that, we die with: syntax error at (eval 2) line 1, near "package OtherPkg"
|
||||
# This little hack fixes it, but don't ask me why:
|
||||
eval "package Hack;" if $] < 5.006001;
|
||||
|
||||
if (ref $code ne 'CODE') {
|
||||
GT::Config->error(CANT_COMPILE_CODE => WARN => $key, $att->{filename}, $err);
|
||||
my $error = "Unable to compile '$key': $err";
|
||||
$code = sub { $error };
|
||||
}
|
||||
|
||||
return $att->{compiled}->{$key} = $code;
|
||||
}
|
||||
|
||||
$att->{data}->{$key};
|
||||
}
|
||||
|
||||
sub FIRSTKEY { keys %{$_[0]->{data}}; each %{$_[0]->{data}} }
|
||||
sub NEXTKEY { each %{$_[0]->{data}} }
|
||||
sub EXISTS { exists $_[0]->{data}->{$_[1]} }
|
||||
sub DELETE {
|
||||
my $val;
|
||||
$val = $_[0]->FETCH($_[1]) if defined wantarray;
|
||||
delete $_[0]->{inherited}->{$_[1]};
|
||||
delete $_[0]->{data}->{$_[1]};
|
||||
delete $_[0]->{compiled}->{$_[1]};
|
||||
$val;
|
||||
}
|
||||
sub CLEAR { %{$_[0]->{data}} = %{$_[0]->{inherited}} = %{$_[0]->{compiled}} = () }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Config - Dumped-hash configuration handler
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Config;
|
||||
my $Config = GT::Config->load($config_file);
|
||||
...
|
||||
print $Config->{variable};
|
||||
...
|
||||
$Config->{othervar} = "something";
|
||||
...
|
||||
$Config->save;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Config provides a simple way to handle loading config files. It can load
|
||||
and save any config file consisting of a dumped hash. You can then use the
|
||||
object as if it were the actual hash reference from the config file. It
|
||||
supports template set inheritance (see L<GT::Template>) and mtime-based
|
||||
caching.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 load
|
||||
|
||||
There is no C<new()> method. To get a new config object you do:
|
||||
|
||||
$Config = GT::Config->load("/path/to/config/file", { options });
|
||||
|
||||
The first argument is the full path to the file to open to read the
|
||||
configuration. The file does not necessarily have to exist - see the options
|
||||
below.
|
||||
|
||||
The second argument is a hash reference of options, and is optional. The
|
||||
possible options are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item inheritance
|
||||
|
||||
If provided as something true, GT::Config will scan for .tplinfo files looking
|
||||
for inherited template sets. This is typically used for loading globals.txt or
|
||||
language.txt files from Gossamer Threads products' template sets.
|
||||
|
||||
Defaults to off.
|
||||
|
||||
=item local
|
||||
|
||||
If provided as something true, GT::Config will look for a "local" directory
|
||||
containing the file. When using inheritance, a "local" directory will also be
|
||||
looked for in each inherited configuration file. However, regardless of the
|
||||
C<inheritance> option, "local" configuration files always inherit from their
|
||||
non-local counterpart.
|
||||
|
||||
Additionally, this option causes GT::Config to save the file into a "local"
|
||||
directory. Also note that the "local" file will _only_ contain keys that were
|
||||
already in the local file, or were assigned to the config object after loading
|
||||
the file.
|
||||
|
||||
Defaults to off.
|
||||
|
||||
=item cache
|
||||
|
||||
If provided, will look in the internal cache for a cached copy of the file. If
|
||||
none is found, a new GT::Config object will be constructed as usual, then saved
|
||||
in the cache.
|
||||
|
||||
Defaults to on. You must pass C<cache =E<gt> 0> to disable cached loading.
|
||||
Note that new objects are always stored in the cache, allowing you to specify
|
||||
C<cache =E<gt> 0> to force a reload of a cached file.
|
||||
|
||||
=item create_ok
|
||||
|
||||
If set, you'll still get back a GT::Config hash even if the file doesn't exist.
|
||||
You can then save() the object to create a new config file. If this option is
|
||||
not set, a fatal error will occur when attempting to load a file that does not
|
||||
exist.
|
||||
|
||||
Defaults to off. Pass in C<create_ok =E<gt> 1> if the config file doesn't
|
||||
necessarily have to exist (i.e. when creating a new config file).
|
||||
|
||||
=item empty
|
||||
|
||||
The C<empty> option is used to create a new, blank config file - it can be
|
||||
thought of as a forced version of the C<create_ok> option. It won't read
|
||||
B<any> files during loading (and as such completely ignores the C<inheritance>
|
||||
and C<cache> options). This is mainly intended to be used when a complete
|
||||
replacement of a file is desired, regardless of what is currently on disk.
|
||||
|
||||
=item chmod
|
||||
|
||||
The C<chmod> option is used to specify the mode of the saved file. It must be
|
||||
passed in octal form, such as 0644 (but B<not> in string form, such as
|
||||
C<"0644">). The default is 0666, to allow writing by any users. Though not
|
||||
terribly secure, this is the sort of environment most CGI scripts require.
|
||||
Setting a chmod value of undef instructs GT::Config to not perform a chmod.
|
||||
|
||||
=item strict
|
||||
|
||||
If set, a fatal error will occur when attempting to access a key of the config
|
||||
file that does not exist. Note, however, that this only covers the first level
|
||||
data structions - C<$CFG-E<gt>{foo}-E<gt>{bar}> will not fatal if C<foo> is a
|
||||
hash ref, but C<bar> is not set in that hash reference. C<$CFG-E<gt>{foo}>
|
||||
(and C<$CFG-E<gt>{foo}-E<gt>{bar}>) will fatal if the key C<foo> does not exist
|
||||
in the config data.
|
||||
|
||||
=item debug
|
||||
|
||||
If provided, debugging information will be printed. This will also cause a
|
||||
warning to occur if L<"fatal"> is disabled and load fails.
|
||||
|
||||
Defaults to disabled. Should not be used in production code, except when
|
||||
debugging.
|
||||
|
||||
=item tmpfile
|
||||
|
||||
Instructs GT::Config to attempt to use a temporary file when saving. If used,
|
||||
the contents will be written to a temporary file, then, if successfully
|
||||
written, the temporary file will be moved to overwrite the real file. This
|
||||
solves a couple of problems. Firstly, a full disk will never result in a
|
||||
partial file as if the entire file is not written to the temporary file, it
|
||||
will not overwrite the file already stored on disk. Secondly, it avoids a
|
||||
potential problem with multiple processes attempting to write to the file at
|
||||
the same time.
|
||||
|
||||
The following values are accepted:
|
||||
|
||||
0 - Do not use a temporary file
|
||||
undef - Use a temporary file if the base directory is writable
|
||||
1 - Always use a temporary file
|
||||
|
||||
The default is C<undef>, which will attempt to use a temporary file is
|
||||
possible, but won't fail if the script has permission to modify existing files,
|
||||
but not to create new ones.
|
||||
|
||||
=item header
|
||||
|
||||
If provided, when saving a file this header will be written above the data.
|
||||
Keep in mind that the file must be Perl-compilable, so be careful if you are
|
||||
doing anything more than comments.
|
||||
|
||||
Note that the header may contain the string C<[localtime]>, which will be
|
||||
replaced with the return value of C<scalar localtime()> when saving, which is
|
||||
generally a value such as: C<Sun Jan 25 15:12:26 2004>.
|
||||
|
||||
=item tab
|
||||
|
||||
If provided, this will set what to use for tabs when calling save(). Defaults
|
||||
to an actual tab, since that cuts down the file size over using multiple
|
||||
spaces, while leaving the file readable.
|
||||
|
||||
=item compile_subs
|
||||
|
||||
If provided, any data starting with C<sub {> will be compiled into a
|
||||
subroutine. This compilation does not happen until the variable is accessed,
|
||||
at which point a fatal error will occur if the code could not be compiled. The
|
||||
code referenced will be cached (if using caching), but will be saved as the
|
||||
original string (starting with C<sub {>) when L<saving|"save">.
|
||||
|
||||
B<NOTE:> The argument to compile_subs must be a valid perl package; the code
|
||||
reference will be compiled in that package. For example,
|
||||
C<compile_subs =E<gt> 'GForum::Post'> will compile the code ref in the
|
||||
GForum::Post package. You need to do this to provide access to globals
|
||||
variables such as $DB, $IN, etc.
|
||||
|
||||
=item sort_order
|
||||
|
||||
If provided, the option will be passed through as the 'order' option of
|
||||
GT::Dumper for hash key ordering. See L<GT::Dumper>. GT::Config always sorts
|
||||
hash keys - this can be used when the default alphanumeric sort is not
|
||||
sufficient.
|
||||
|
||||
=back
|
||||
|
||||
=head2 save
|
||||
|
||||
To save a config file, simply call C<$object-E<gt>save()>. If the object uses
|
||||
inheritance, only those keys that were not inherited (or were modified from the
|
||||
inherited ones) will be saved.
|
||||
|
||||
$Config->save();
|
||||
|
||||
B<NOTE>: B<ALWAYS SAVE AFTER MAKING ANY CHANGES!!!>. If you do not save after
|
||||
making changes, the data retrieved from the cache may not be the same as the
|
||||
data stored in the configuration file on disk. After making ANY changes make
|
||||
absolutely sure that you either undo the change or save the configuration file.
|
||||
|
||||
=head2 cache_hit
|
||||
|
||||
Returns whether or not the current object was loaded from cache (1) or loaded
|
||||
from disk (undef).
|
||||
|
||||
=head2 inheritance
|
||||
|
||||
Returns the inheritance status (1 or 0) of the object.
|
||||
|
||||
=head2 create_ok
|
||||
|
||||
Returns the status (1 or 0) of the "create_ok" flag.
|
||||
|
||||
=head2 tmpfile
|
||||
|
||||
With no arguments, returns whether or not the object will attempt to use a
|
||||
temporary file when saving. Possible values are:
|
||||
|
||||
0 - Do not use a temporary file
|
||||
undef - Use a temporary file if the base directory is writable
|
||||
1 - Always use a temporary file
|
||||
|
||||
You can pass in a single argument of one of the above values to set whether or
|
||||
not the object will use a temporary file when saving.
|
||||
|
||||
=head2 cache
|
||||
|
||||
This method returns whether or not the object is cached. This cannot be
|
||||
enabled/disabled after loading a config file; you must specify it as an
|
||||
argument to C<load()> instead.
|
||||
|
||||
=head2 debug_level
|
||||
|
||||
This method returns the current debug level.
|
||||
|
||||
You may provide one argument which sets a new debug level.
|
||||
|
||||
0 means no debugging, 1 means basic debugging, 2 means heavy debugging.
|
||||
|
||||
If setting a new debug level, the old debug level is returned.
|
||||
|
||||
=head2 header
|
||||
|
||||
This method returns or sets the header that will be printed when saving.
|
||||
|
||||
With no arguments, returns the header.
|
||||
|
||||
You may provide one argument which sets a new header. Keep in mind that the
|
||||
file must be Perl-compilable, so take care if doing anything other than
|
||||
comments.
|
||||
|
||||
If providing a new header, the old header is returned.
|
||||
|
||||
Note that the header may contain the value C<[localtime]>, which will be
|
||||
replaced with the return value of C<scalar localtime()> when saving.
|
||||
|
||||
=head2 sort_order
|
||||
|
||||
This method returns or sets a code reference to be passed through as the
|
||||
'order' option of GT::Dumper for hash key ordering. See L<GT::Dumper>.
|
||||
GT::Config always sorts hash keys - this can be used when the default
|
||||
alphanumeric sort is not sufficient.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::Template::Inheritance>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
$Id: Config.pm,v 1.45 2005/03/21 05:49:39 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1128
site/glist/lib/GT/Date.pm
Normal file
1128
site/glist/lib/GT/Date.pm
Normal file
File diff suppressed because it is too large
Load Diff
180
site/glist/lib/GT/Delay.pm
Normal file
180
site/glist/lib/GT/Delay.pm
Normal file
@@ -0,0 +1,180 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Delay
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Delay.pm,v 1.4 2004/01/13 01:35:15 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Generic delayed-loading module wrapper.
|
||||
#
|
||||
|
||||
package GT::Delay;
|
||||
use strict;
|
||||
use Carp();
|
||||
|
||||
my %Delayed;
|
||||
|
||||
sub GT::Delay {
|
||||
# We don't define any subroutines in GT::Delay, since even ->new should be
|
||||
# allowed in some circumstances. Takes three arguments - the package to load
|
||||
# (i.e. 'GT::SQL'), the type of blessed reference used for that object ('HASH',
|
||||
# 'ARRAY', and 'SCALAR' are supported), and any number of arguments to pass
|
||||
# into the ->new method of the package.
|
||||
#
|
||||
my ($package, $type, @args) = @_;
|
||||
$type ||= 'HASH';
|
||||
$type eq 'HASH' || $type eq 'ARRAY' || $type eq 'SCALAR' or Carp::croak('Unknown bless type: ' . $type . '. See the GT::Delay manpage');
|
||||
|
||||
my $self = bless($type eq 'HASH' ? {} : $type eq 'ARRAY' ? [] : \my $foo);
|
||||
$Delayed{$self} = [$package, $type, \@args];
|
||||
$self;
|
||||
}
|
||||
|
||||
AUTOLOAD {
|
||||
# When a method is called we create a real object, copy it into $self, and
|
||||
# rebless $self into the package. This has to be done to get around a case
|
||||
# such as: my $foo = GT::Delay(...); my $bar = $foo; $bar->meth;
|
||||
# Even changing $_[0] would not affect $foo, and if $foo was used would result
|
||||
# in _two_ of the delayed modules.
|
||||
#
|
||||
my $self = $_[0];
|
||||
my ($package, $type, $args) = @{delete $Delayed{$self}};
|
||||
|
||||
(my $module = $package) =~ s|::|/|g;
|
||||
$module .= '.pm';
|
||||
require $module;
|
||||
|
||||
my $copy = $package->new(@$args);
|
||||
|
||||
eval {
|
||||
if ($type eq 'HASH') { %$self = %$copy }
|
||||
elsif ($type eq 'ARRAY') { @$self = @$copy }
|
||||
else { $$self = $$copy }
|
||||
};
|
||||
|
||||
$@ and Carp::croak("$package type does not appear to be $type. Delayed loading failed");
|
||||
|
||||
bless $self, ref $copy;
|
||||
|
||||
my $method = substr($GT::Delay::AUTOLOAD, rindex($GT::Delay::AUTOLOAD, ':') + 1);
|
||||
if (my $subref = $self->can($method)) {
|
||||
goto &$subref;
|
||||
}
|
||||
elsif ($self->can('AUTOLOAD')) {
|
||||
shift;
|
||||
$self->$method(@_);
|
||||
}
|
||||
else {
|
||||
Carp::croak(qq|Can't locate object method "$method" via package "| . ref($self) . '"');
|
||||
}
|
||||
}
|
||||
|
||||
DESTROY {
|
||||
delete $Delayed{$_[0]} if exists $Delayed{$_[0]};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Delay - Generic delayed module loading
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Delay;
|
||||
|
||||
my $obj = GT::Delay('GT::Foo', 'HASH', foo => "bar", bar => 12);
|
||||
|
||||
... # time passes without using $obj
|
||||
|
||||
$obj->method();
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a simple way to handle delayed module loading in a fairly
|
||||
generic way. Your object will only be a very lightweight GT::Delay object
|
||||
until you call a method on it, at which point the desired module will be loaded,
|
||||
your object will be changed into an object of the desired type.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
There is only one usable function provided by this module, GT::Delay() (not
|
||||
GT::Delay::Delay as this module attempts to leave the GT::Delay namespace as
|
||||
empty as possible).
|
||||
|
||||
=head2 GT::Delay
|
||||
|
||||
GT::Delay is used to create a new delayed object. It takes at least two
|
||||
arguments. The first is the package to load, such as 'GT::Foo' to require
|
||||
GT/Foo.pm and create a new GT::Foo object. The second is the type of blessed
|
||||
data structure a 'GT::Foo' object really is. This can be one of either 'HASH',
|
||||
'ARRAY', or 'SCALAR'. Any additional arguments are kept and passed in as
|
||||
arguments to the new() method of the object when created.
|
||||
|
||||
The object type ('HASH', 'ARRAY', or 'SCALAR') is needed is to get around a
|
||||
caveat of references - if $a and $b both point to the same reference, $b cannot
|
||||
be changed from $a - which makes it impossible to just get a new object and
|
||||
replace $_[0] with that object, because although that would change one of
|
||||
either $a or $b, it wouldn't change the other and you could easily end up with
|
||||
two separate objects. When a method is called, the new object is created, then
|
||||
copied into the original object which is then reblessed into the desired
|
||||
package. This doesn't change either $a or $b, but rather changes the reference
|
||||
they point to. You have to pass the object type because the reference must be
|
||||
reblessed, but the underlying data type cannot change. Unfortunately, this
|
||||
approach has a few caveats of its own, listed below.
|
||||
|
||||
=head1 CAVEATS and LIMITATIONS
|
||||
|
||||
Modules that are created by a method other than new() are not supported.
|
||||
|
||||
Modules that use a namespace different from the module location are not
|
||||
supported. For example, a package Foo::Bar::Blah located in Foo/Bar.pm. If
|
||||
you have such a module that would benefit from delayed loading, you need to
|
||||
rethink your package/filename naming scheme, or not use this module. It _is_
|
||||
possible to do this with a hack such as:
|
||||
C<$INC{'Foo/Bar/Blah.pm'} = './Foo/Bar.pm';> - but other than for testing,
|
||||
doing such a thing is strongly discouraged.
|
||||
|
||||
Objects cannot have their elements directly accessed - for example,
|
||||
C<$obj-E<gt>{foo}>. But, since that is bad practise anyway, it isn't that much
|
||||
of a limitation. That said, objects _can_ be accessed directly _after_ any
|
||||
method has been called.
|
||||
|
||||
Modules that store a string or integer form of $self (GT::Config does this to
|
||||
store object attributes) will not work, since the working object will not be
|
||||
the same object create a new(), but rather a copy.
|
||||
|
||||
Modules with DESTROY methods that do things to references in $self (for
|
||||
example, C<delete $self-E<gt>{foo}-E<gt>{bar}> - though C<delete
|
||||
$self-E<gt>{foo}> would be safe) will most likely not work properly as the copy
|
||||
is not deep - i.e. references are copied as-is.
|
||||
|
||||
Along the same lines as the previous point, the first object will be destroyed
|
||||
before the first method call goes through, so modules that do things (e.g.
|
||||
delete files, close filehandles, etc.) in DESTROY will most likely not work.
|
||||
|
||||
Any module that doesn't fall into any of the points above will be perfectly
|
||||
well supported by this module.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Delay.pm,v 1.4 2004/01/13 01:35:15 jagerman Exp $
|
||||
|
||||
=cut
|
||||
384
site/glist/lib/GT/Dumper.pm
Normal file
384
site/glist/lib/GT/Dumper.pm
Normal file
@@ -0,0 +1,384 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Dumper
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Dumper.pm,v 1.38 2005/02/18 04:44:33 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements a data dumper, useful for converting complex Perl
|
||||
# data structures to strings, which can then be eval()ed back to
|
||||
# the original value.
|
||||
#
|
||||
|
||||
package GT::Dumper;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw /$DEBUG $ATTRIBS $VERSION @EXPORT @ISA $EOL/;
|
||||
use GT::Base;
|
||||
use Exporter;
|
||||
|
||||
$EOL = "\n";
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.38 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
var => '$VAR',
|
||||
data => undef,
|
||||
sort => 1,
|
||||
order => undef,
|
||||
compress => undef,
|
||||
structure => undef,
|
||||
tab => ' '
|
||||
};
|
||||
@EXPORT = qw/Dumper/;
|
||||
@ISA = qw/Exporter GT::Base/;
|
||||
|
||||
sub Dumper {
|
||||
# -----------------------------------------------------------
|
||||
# Dumper acts similar to Dumper in Data::Dumper when called as a
|
||||
# class method. If called as a instance method it assumes you
|
||||
# have set the options for the dump and does not change them.
|
||||
# It only takes a single argument - the variable to dump.
|
||||
#
|
||||
my $self;
|
||||
if (@_ == 2 and UNIVERSAL::isa($_[0], __PACKAGE__)) {
|
||||
$self = shift;
|
||||
$self->{data} = shift;
|
||||
}
|
||||
elsif (@_ == 1) {
|
||||
$self = GT::Dumper->new(data => shift);
|
||||
}
|
||||
else {
|
||||
die "Bad args to Dumper()";
|
||||
}
|
||||
return $self->dump;
|
||||
}
|
||||
|
||||
sub dump {
|
||||
# -----------------------------------------------------------
|
||||
# my $dump = $class->dump(%opts);
|
||||
# --------------------------------
|
||||
# Returns the data structure specified in %opts flatened.
|
||||
# %opts is optional if you have created an object with the
|
||||
# options.
|
||||
#
|
||||
my $this = shift;
|
||||
|
||||
# See if options were passed in
|
||||
my $self;
|
||||
if (!ref $this) {
|
||||
$self = $this->new(@_);
|
||||
}
|
||||
else {
|
||||
$self = $this;
|
||||
if (@_) {
|
||||
my $data = $self->common_param(@_) or return $self->fatal(BADARGS => '$dumper->dump(%opts)');
|
||||
$self->set($data);
|
||||
}
|
||||
}
|
||||
|
||||
my $level = 0;
|
||||
my $ret = '';
|
||||
if ($self->{var} and not $self->{structure}) {
|
||||
$ret .= ($self->{compress} ? "$self->{var}=" : "$self->{var} = ");
|
||||
}
|
||||
$self->_dump_value($level + 1, $self->{data}, \$ret);
|
||||
$ret .= ';' unless $self->{structure};
|
||||
$ret .= $EOL unless $self->{structure} or $self->{compress};
|
||||
|
||||
return $ret ? $ret : 1;
|
||||
}
|
||||
|
||||
sub dump_structure {
|
||||
my ($self, $data) = @_;
|
||||
return $self->dump(structure => 1, data => $data);
|
||||
}
|
||||
|
||||
sub _dump_value {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to decide what to dump.
|
||||
#
|
||||
my ($self, $level, $val, $ret, $n) = @_;
|
||||
my $was;
|
||||
my $ref = ref $val;
|
||||
if ($ref and $val =~ /=/) { $self->_dump_obj( $level + 1, $val, $ret) }
|
||||
elsif ($ref eq 'HASH') { $self->_dump_hash( $level + 1, $val, $ret) }
|
||||
elsif ($ref eq 'ARRAY') { $self->_dump_array($level + 1, $val, $ret) }
|
||||
elsif ($ref eq 'SCALAR' or $ref eq 'REF' or $ref eq 'LVALUE') {
|
||||
$self->_dump_scalar($level, $val, $ret)
|
||||
}
|
||||
elsif ($ref eq 'CODE') { $$ret .= 'sub { () }' }
|
||||
else { $$ret .= _escape($val) }
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_scalar {
|
||||
# -----------------------------------------------------------
|
||||
# Dump a scalar reference.
|
||||
#
|
||||
my ($self, $level, $val, $ret, $n) = @_;
|
||||
my $v = $$val;
|
||||
$$ret .= '\\';
|
||||
$self->_dump_value($level, $v, $ret, 1);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_hash {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to for through a hash and dump it.
|
||||
#
|
||||
my ($self, $level, $hash_ref, $ret) = @_;
|
||||
$$ret .= '{';
|
||||
my $lines;
|
||||
if ($self->{sort}) {
|
||||
for (sort { ref($self->{order}) eq 'CODE' ? $self->{order}->($a, $b, $hash_ref->{$a}, $hash_ref->{$b}) : $a cmp $b } keys %{$hash_ref}) {
|
||||
$$ret .= "," if $lines++;
|
||||
$$ret .= $EOL . ($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
my $key = _escape($_);
|
||||
$$ret .= $self->{compress} ? "$key," : "$key => ";
|
||||
$self->_dump_value($level + 1, $hash_ref->{$_}, $ret, 1);
|
||||
}
|
||||
}
|
||||
else {
|
||||
for (keys %{$hash_ref}) {
|
||||
$$ret .= "," if $lines++;
|
||||
$$ret .= $EOL . ($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
my $key = _escape($_);
|
||||
$$ret .= $self->{compress} ? "$key," : "$key => ";
|
||||
$self->_dump_value($level + 1, $hash_ref->{$_}, $ret, 1);
|
||||
}
|
||||
}
|
||||
$$ret .= $EOL if $lines and not $self->{compress};
|
||||
$$ret .= ($lines and not $self->{compress}) ? (($self->{tab} x (($level - 1) / 2)) . "}") : "}";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_array {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to for through an array and dump it.
|
||||
#
|
||||
my ($self, $level, $array_ref, $ret) = @_;
|
||||
$$ret .= "[";
|
||||
my $lines;
|
||||
for (@{$array_ref}) {
|
||||
$$ret .= "," if $lines++;
|
||||
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
$self->_dump_value($level + 1, $_, $ret, 1);
|
||||
}
|
||||
$$ret .= ($lines and not $self->{compress}) ? $EOL.(($self->{tab} x (($level - 1) / 2)) . "]") : "]";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_obj {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to dump an object.
|
||||
#
|
||||
my ($self, $level, $obj, $ret) = @_;
|
||||
my $class = ref $obj;
|
||||
$$ret .= "bless(";
|
||||
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
if ($obj =~ /ARRAY\(/) { $self->_dump_array($level + 2, \@{$obj}, $ret) }
|
||||
elsif ($obj =~ /HASH\(/) { $self->_dump_hash( $level + 2, \%{$obj}, $ret) }
|
||||
elsif ($obj =~ /SCALAR\(/ or $obj =~ /REF\(/ or $obj =~ /LVALUE\(/)
|
||||
{ $self->_dump_value($level + 2, $$obj, $ret) }
|
||||
$$ret .= ",";
|
||||
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
$$ret .= _escape($class);
|
||||
$$ret .= $EOL.($self->{tab} x (($level - 1) / 2)) unless $self->{compress};
|
||||
$$ret .= ")";
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub _escape {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to escape a dumped value.
|
||||
my ($val) = @_;
|
||||
defined($val) or return 'undef';
|
||||
$val =~ s/('|\\(?=['\\]|$))/\\$1/g;
|
||||
return "'$val'";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Dumper - Convert Perl data structures into a string.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Dumper;
|
||||
print Dumper($complex_var);
|
||||
print GT::Dumper->dump ( var => '$MYVAR', data => $complex_var);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Dumper by default exports a method Dumper() which will
|
||||
behave similar to Data::Dumper's Dumper(). It differs in that
|
||||
it will only take a single argument, and the variable dumped
|
||||
will be $VAR instead of $VAR1. Also, to provide easier control
|
||||
to change the variable name that gets dumped, you can use:
|
||||
|
||||
GT::Dumper->dump ( var => string, data => yourdata );
|
||||
|
||||
and the dump will start with string = instead of $VAR = .
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
use GT::Dumper;
|
||||
my %foo;
|
||||
my @bar = (1, 2, 3);
|
||||
$foo{alpha} = \@bar;
|
||||
$foo{beta} = 'a string';
|
||||
print Dumper(\%foo);
|
||||
|
||||
This will print:
|
||||
|
||||
$VAR = {
|
||||
'beta' => 'a string',
|
||||
'alpha' => [
|
||||
'1',
|
||||
'2',
|
||||
'3',
|
||||
],
|
||||
};
|
||||
|
||||
=head1 METHODS/FUNCTIONS
|
||||
|
||||
=head2 Dumper
|
||||
|
||||
Dumper() is exported by default when using GT::Dumper. It takes a single
|
||||
variable and returns a string representation of the variable. The string can
|
||||
then be eval()'ed back into the same data structure.
|
||||
|
||||
It takes only one argument - the variable to dump. The return is a string of
|
||||
the form:
|
||||
|
||||
$VAR = DATA
|
||||
|
||||
where 'DATA' is the actual data structure of the variable. A more powerful and
|
||||
customizable dumping method is the L</"dump"> method.
|
||||
|
||||
=head2 dump
|
||||
|
||||
dump() provides a more customizable method to dumping a data structure. Through
|
||||
the various options available, listed below, the output of a data structure
|
||||
dump can be formatted in several different ways.
|
||||
|
||||
The options are as follows. Only the L</"data"> option is required.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * data
|
||||
|
||||
The data option takes a data structure to dump. It is required.
|
||||
|
||||
=item * var
|
||||
|
||||
By default, a dump is output as an assignment to C<$VAR>. For example, dumping
|
||||
the string C<foo> would return: C<$VAR = 'foo'>. You can change and even omit
|
||||
the assignment using the C<var> option. To specify a different variable, you
|
||||
simply specify it as the value here. To have 'foo' dump as just C<'foo'>
|
||||
instead of C<$VAR = 'foo'>, specify var as an empty string, or undef.
|
||||
|
||||
=item * tab
|
||||
|
||||
When indenting for complex data structures (array refs, hash refs, etc.) an
|
||||
indent is used. By default, the indent is 4 spaces, however you can change this
|
||||
by using the C<tab> option.
|
||||
|
||||
=item * sort
|
||||
|
||||
The C<sort> option enables hash key sorting. It is not on by default - to
|
||||
enable, simply specify the sort option with 1 as the value. The default sort
|
||||
method is case-sensitive alphabetical. See the L</"order"> option for
|
||||
specifying your own sort order.
|
||||
|
||||
=item * order
|
||||
|
||||
When sorting, it is sometimes desirable to use a custom sort order rather than
|
||||
the default case-sensitive alphabetical sort. The C<order> option takes a code
|
||||
reference and enables custom sort ordering. The code reference will be passed 4
|
||||
variables. The first and second are the two items being compared - $a and $b in
|
||||
Perl's sort mechanism. The third and fourth are the values in the hash being
|
||||
sorted. The code reference, like a Perl sort routine, should return -1 if $a
|
||||
should come before $b, 0 if $a and $b are equivelant in your sort order, and 1
|
||||
if $b should come before $a. Because of scoping and package issues in Perl, it
|
||||
is not possible to directly use $a and $b.
|
||||
|
||||
=item * compress
|
||||
|
||||
The default dump method is to use ' => ' between hash key and value, to use
|
||||
indenting, and to add a line break after each dumped element. You can turn all
|
||||
of these off by using the compress option.
|
||||
|
||||
Compression removes all non-essential characters from the output, thus reducing
|
||||
data size, however also generally making the dump very difficult to read. If
|
||||
enabled, the dumping behaviour is changed as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * assignment
|
||||
|
||||
If using a var (ie. C<$VAR = DATA>), the spaces around the = will be stripped.
|
||||
The output will look like: C<$VAR=DATA>
|
||||
|
||||
=item * hash keys
|
||||
|
||||
Instead of placing the 4 characters ' => ' between hash keys and values, a
|
||||
single ',' will be used.
|
||||
|
||||
=item * tabs
|
||||
|
||||
Tabs will not be used.
|
||||
|
||||
=item * newlines
|
||||
|
||||
Normally, a newline character is added after each dumped element. Compress
|
||||
turns this off.
|
||||
|
||||
=back
|
||||
|
||||
=item * structure
|
||||
|
||||
The structure option causes the dump to be a valid perl structure rather than a
|
||||
valid perl statement. This differs in two ways - for one, the C<var> option is
|
||||
ignored - it is treated as if a blank C<var> was entered, thereby not returning
|
||||
an assignment. The other difference is that an an ordinary dump adds a
|
||||
semicolon and newline at the end of the dump, but these are not added when the
|
||||
structure option is enabled.
|
||||
|
||||
=back
|
||||
|
||||
=head2 dump_structure
|
||||
|
||||
This is a quick method to do a structure dump. It takes one argument - the data
|
||||
to dump. Calling:
|
||||
$class->dump_structure($DATA);
|
||||
is identical to calling:
|
||||
$class->dump(data => $DATA, structure => 1);
|
||||
See the L</"structure"> option.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Data::Dumper>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Dumper.pm,v 1.38 2005/02/18 04:44:33 jagerman Exp $
|
||||
|
||||
=cut
|
||||
865
site/glist/lib/GT/File/Diff.pm
Normal file
865
site/glist/lib/GT/File/Diff.pm
Normal file
@@ -0,0 +1,865 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::File::Diff
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Diff.pm,v 1.2 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Generic diff module.
|
||||
# This module is based entirely on Algorithm::Diff v1.15.
|
||||
#
|
||||
package GT::File::Diff;
|
||||
|
||||
use vars qw($VERSION @EXPORT_OK @ISA @EXPORT);
|
||||
use integer; # see below in _replaceNextLargerWith() for mod to make
|
||||
# if you don't use this
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw();
|
||||
@EXPORT_OK = qw(LCS diff traverse_sequences traverse_balanced sdiff);
|
||||
$VERSION = sprintf('%d.%02d', (q$Revision: 1.2 $ =~ /\d+/g));
|
||||
|
||||
# McIlroy-Hunt diff algorithm
|
||||
# Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
|
||||
# by Ned Konz, perl@bike-nomad.com
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Algorithm::Diff - Compute `intelligent' differences between two files / lists
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::File::Diff qw(diff sdiff LCS traverse_sequences
|
||||
traverse_balanced);
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2 );
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
$lcsref = LCS( \@seq1, \@seq2 );
|
||||
|
||||
$lcsref = LCS( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
@diffs = diff( \@seq1, \@seq2 );
|
||||
|
||||
@diffs = diff( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
@sdiffs = sdiff( \@seq1, \@seq2 );
|
||||
|
||||
@sdiffs = sdiff( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback,
|
||||
DISCARD_A => $callback,
|
||||
DISCARD_B => $callback,
|
||||
} );
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback,
|
||||
DISCARD_A => $callback,
|
||||
DISCARD_B => $callback,
|
||||
},
|
||||
$key_generation_function );
|
||||
|
||||
traverse_balanced( \@seq1, \@seq2,
|
||||
{ MATCH => $callback,
|
||||
DISCARD_A => $callback,
|
||||
DISCARD_B => $callback,
|
||||
CHANGE => $callback,
|
||||
} );
|
||||
|
||||
=head1 INTRODUCTION
|
||||
|
||||
(by Mark-Jason Dominus)
|
||||
|
||||
I once read an article written by the authors of C<diff>; they said
|
||||
that they hard worked very hard on the algorithm until they found the
|
||||
right one.
|
||||
|
||||
I think what they ended up using (and I hope someone will correct me,
|
||||
because I am not very confident about this) was the `longest common
|
||||
subsequence' method. in the LCS problem, you have two sequences of
|
||||
items:
|
||||
|
||||
a b c d f g h j q z
|
||||
|
||||
a b c d e f g i j k r x y z
|
||||
|
||||
and you want to find the longest sequence of items that is present in
|
||||
both original sequences in the same order. That is, you want to find
|
||||
a new sequence I<S> which can be obtained from the first sequence by
|
||||
deleting some items, and from the secend sequence by deleting other
|
||||
items. You also want I<S> to be as long as possible. In this case
|
||||
I<S> is
|
||||
|
||||
a b c d f g j z
|
||||
|
||||
From there it's only a small step to get diff-like output:
|
||||
|
||||
e h i k q r x y
|
||||
+ - + + - + + +
|
||||
|
||||
This module solves the LCS problem. It also includes a canned
|
||||
function to generate C<diff>-like output.
|
||||
|
||||
It might seem from the example above that the LCS of two sequences is
|
||||
always pretty obvious, but that's not always the case, especially when
|
||||
the two sequences have many repeated elements. For example, consider
|
||||
|
||||
a x b y c z p d q
|
||||
a b c a x b y c z
|
||||
|
||||
A naive approach might start by matching up the C<a> and C<b> that
|
||||
appear at the beginning of each sequence, like this:
|
||||
|
||||
a x b y c z p d q
|
||||
a b c a b y c z
|
||||
|
||||
This finds the common subsequence C<a b c z>. But actually, the LCS
|
||||
is C<a x b y c z>:
|
||||
|
||||
a x b y c z p d q
|
||||
a b c a x b y c z
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
This module provides three exportable functions, which we'll deal with in
|
||||
ascending order of difficulty: C<LCS>,
|
||||
C<diff>, C<sdiff>, C<traverse_sequences>, and C<traverse_balanced>.
|
||||
|
||||
=head2 C<LCS>
|
||||
|
||||
Given references to two lists of items, LCS returns an array containing their
|
||||
longest common subsequence. In scalar context, it returns a reference to
|
||||
such a list.
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2 );
|
||||
$lcsref = LCS( \@seq1, \@seq2 );
|
||||
|
||||
C<LCS> may be passed an optional third parameter; this is a CODE
|
||||
reference to a key generation function. See L</KEY GENERATION
|
||||
FUNCTIONS>.
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2, $keyGen );
|
||||
$lcsref = LCS( \@seq1, \@seq2, $keyGen );
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation
|
||||
routine.
|
||||
|
||||
=head2 C<diff>
|
||||
|
||||
@diffs = diff( \@seq1, \@seq2 );
|
||||
$diffs_ref = diff( \@seq1, \@seq2 );
|
||||
|
||||
C<diff> computes the smallest set of additions and deletions necessary
|
||||
to turn the first sequence into the second, and returns a description
|
||||
of these changes. The description is a list of I<hunks>; each hunk
|
||||
represents a contiguous section of items which should be added,
|
||||
deleted, or replaced. The return value of C<diff> is a list of
|
||||
hunks, or, in scalar context, a reference to such a list.
|
||||
|
||||
Here is an example: The diff of the following two sequences:
|
||||
|
||||
a b c e h j l m n p
|
||||
b c d e f j k l m r s t
|
||||
|
||||
Result:
|
||||
|
||||
[
|
||||
[ [ '-', 0, 'a' ] ],
|
||||
|
||||
[ [ '+', 2, 'd' ] ],
|
||||
|
||||
[ [ '-', 4, 'h' ] ,
|
||||
[ '+', 4, 'f' ] ],
|
||||
|
||||
[ [ '+', 6, 'k' ] ],
|
||||
|
||||
[ [ '-', 8, 'n' ],
|
||||
[ '-', 9, 'p' ],
|
||||
[ '+', 9, 'r' ],
|
||||
[ '+', 10, 's' ],
|
||||
[ '+', 11, 't' ],
|
||||
]
|
||||
]
|
||||
|
||||
There are five hunks here. The first hunk says that the C<a> at
|
||||
position 0 of the first sequence should be deleted (C<->). The second
|
||||
hunk says that the C<d> at position 2 of the second sequence should
|
||||
be inserted (C<+>). The third hunk says that the C<h> at position 4
|
||||
of the first sequence should be removed and replaced with the C<f>
|
||||
from position 4 of the second sequence. The other two hunks similarly.
|
||||
|
||||
C<diff> may be passed an optional third parameter; this is a CODE
|
||||
reference to a key generation function. See L</KEY GENERATION
|
||||
FUNCTIONS>.
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation
|
||||
routine.
|
||||
|
||||
=head2 C<sdiff>
|
||||
|
||||
@sdiffs = sdiff( \@seq1, \@seq2 );
|
||||
$sdiffs_ref = sdiff( \@seq1, \@seq2 );
|
||||
|
||||
C<sdiff> computes all necessary components to show two sequences
|
||||
and their minimized differences side by side, just like the
|
||||
Unix-utility I<sdiff> does:
|
||||
|
||||
same same
|
||||
before | after
|
||||
old < -
|
||||
- > new
|
||||
|
||||
It returns a list of array refs, each pointing to an array of
|
||||
display instructions. In scalar context it returns a reference
|
||||
to such a list.
|
||||
|
||||
Display instructions consist of three elements: A modifier indicator
|
||||
(C<+>: Element added, C<->: Element removed, C<u>: Element unmodified,
|
||||
C<c>: Element changed) and the value of the old and new elements, to
|
||||
be displayed side by side.
|
||||
|
||||
An C<sdiff> of the following two sequences:
|
||||
|
||||
a b c e h j l m n p
|
||||
b c d e f j k l m r s t
|
||||
|
||||
results in
|
||||
|
||||
[ [ '-', 'a', '' ],
|
||||
[ 'u', 'b', 'b' ],
|
||||
[ 'u', 'c', 'c' ],
|
||||
[ '+', '', 'd' ],
|
||||
[ 'u', 'e', 'e' ],
|
||||
[ 'c', 'h', 'f' ],
|
||||
[ 'u', 'j', 'j' ],
|
||||
[ '+', '', 'k' ],
|
||||
[ 'u', 'l', 'l' ],
|
||||
[ 'u', 'm', 'm' ],
|
||||
[ 'c', 'n', 'r' ],
|
||||
[ 'c', 'p', 's' ],
|
||||
[ '+', '', 't' ] ]
|
||||
|
||||
C<sdiff> may be passed an optional third parameter; this is a CODE
|
||||
reference to a key generation function. See L</KEY GENERATION
|
||||
FUNCTIONS>.
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation
|
||||
routine.
|
||||
|
||||
=head2 C<traverse_sequences>
|
||||
|
||||
C<traverse_sequences> is the most general facility provided by this
|
||||
module; C<diff> and C<LCS> are implemented as calls to it.
|
||||
|
||||
Imagine that there are two arrows. Arrow A points to an element of sequence A,
|
||||
and arrow B points to an element of the sequence B. Initially, the arrows
|
||||
point to the first elements of the respective sequences. C<traverse_sequences>
|
||||
will advance the arrows through the sequences one element at a time, calling an
|
||||
appropriate user-specified callback function before each advance. It
|
||||
willadvance the arrows in such a way that if there are equal elements C<$A[$i]>
|
||||
and C<$B[$j]> which are equal and which are part of the LCS, there will be
|
||||
some moment during the execution of C<traverse_sequences> when arrow A is
|
||||
pointing to C<$A[$i]> and arrow B is pointing to C<$B[$j]>. When this happens,
|
||||
C<traverse_sequences> will call the C<MATCH> callback function and then it will
|
||||
advance both arrows.
|
||||
|
||||
Otherwise, one of the arrows is pointing to an element of its sequence that is
|
||||
not part of the LCS. C<traverse_sequences> will advance that arrow and will
|
||||
call the C<DISCARD_A> or the C<DISCARD_B> callback, depending on which arrow it
|
||||
advanced. If both arrows point to elements that are not part of the LCS, then
|
||||
C<traverse_sequences> will advance one of them and call the appropriate
|
||||
callback, but it is not specified which it will call.
|
||||
|
||||
The arguments to C<traverse_sequences> are the two sequences to traverse, and a
|
||||
hash which specifies the callback functions, like this:
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback_1,
|
||||
DISCARD_A => $callback_2,
|
||||
DISCARD_B => $callback_3,
|
||||
} );
|
||||
|
||||
Callbacks for MATCH, DISCARD_A, and DISCARD_B are invoked with at least the
|
||||
indices of the two arrows as their arguments. They are not expected to return
|
||||
any values. If a callback is omitted from the table, it is not called.
|
||||
|
||||
Callbacks for A_FINISHED and B_FINISHED are invoked with at least the
|
||||
corresponding index in A or B.
|
||||
|
||||
If arrow A reaches the end of its sequence, before arrow B does,
|
||||
C<traverse_sequences> will call the C<A_FINISHED> callback when it advances
|
||||
arrow B, if there is such a function; if not it will call C<DISCARD_B> instead.
|
||||
Similarly if arrow B finishes first. C<traverse_sequences> returns when both
|
||||
arrows are at the ends of their respective sequences. It returns true on
|
||||
success and false on failure. At present there is no way to fail.
|
||||
|
||||
C<traverse_sequences> may be passed an optional fourth parameter; this is a
|
||||
CODE reference to a key generation function. See L</KEY GENERATION FUNCTIONS>.
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation function.
|
||||
|
||||
=head2 C<traverse_balanced>
|
||||
|
||||
C<traverse_balanced> is an alternative to C<traverse_sequences>. It
|
||||
uses a different algorithm to iterate through the entries in the
|
||||
computed LCS. Instead of sticking to one side and showing element changes
|
||||
as insertions and deletions only, it will jump back and forth between
|
||||
the two sequences and report I<changes> occurring as deletions on one
|
||||
side followed immediatly by an insertion on the other side.
|
||||
|
||||
In addition to the
|
||||
C<DISCARD_A>,
|
||||
C<DISCARD_B>, and
|
||||
C<MATCH>
|
||||
callbacks supported by C<traverse_sequences>, C<traverse_balanced> supports
|
||||
a C<CHANGE> callback indicating that one element got C<replaced> by another:
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback_1,
|
||||
DISCARD_A => $callback_2,
|
||||
DISCARD_B => $callback_3,
|
||||
CHANGE => $callback_4,
|
||||
} );
|
||||
|
||||
If no C<CHANGE> callback is specified, C<traverse_balanced>
|
||||
will map C<CHANGE> events to C<DISCARD_A> and C<DISCARD_B> actions,
|
||||
therefore resulting in a similar behaviour as C<traverse_sequences>
|
||||
with different order of events.
|
||||
|
||||
C<traverse_balanced> might be a bit slower than C<traverse_sequences>,
|
||||
noticable only while processing huge amounts of data.
|
||||
|
||||
The C<sdiff> function of this module
|
||||
is implemented as call to C<traverse_balanced>.
|
||||
|
||||
=head1 KEY GENERATION FUNCTIONS
|
||||
|
||||
C<diff>, C<LCS>, and C<traverse_sequences> accept an optional last parameter.
|
||||
This is a CODE reference to a key generating (hashing) function that should
|
||||
return a string that uniquely identifies a given element. It should be the
|
||||
case that if two elements are to be considered equal, their keys should be the
|
||||
same (and the other way around). If no key generation function is provided,
|
||||
the key will be the element as a string.
|
||||
|
||||
By default, comparisons will use "eq" and elements will be turned into keys
|
||||
using the default stringizing operator '""'.
|
||||
|
||||
Where this is important is when you're comparing something other than strings.
|
||||
If it is the case that you have multiple different objects that should be
|
||||
considered to be equal, you should supply a key generation function. Otherwise,
|
||||
you have to make sure that your arrays contain unique references.
|
||||
|
||||
For instance, consider this example:
|
||||
|
||||
package Person;
|
||||
|
||||
sub new
|
||||
{
|
||||
my $package = shift;
|
||||
return bless { name => '', ssn => '', @_ }, $package;
|
||||
}
|
||||
|
||||
sub clone
|
||||
{
|
||||
my $old = shift;
|
||||
my $new = bless { %$old }, ref($old);
|
||||
}
|
||||
|
||||
sub hash
|
||||
{
|
||||
return shift()->{'ssn'};
|
||||
}
|
||||
|
||||
my $person1 = Person->new( name => 'Joe', ssn => '123-45-6789' );
|
||||
my $person2 = Person->new( name => 'Mary', ssn => '123-47-0000' );
|
||||
my $person3 = Person->new( name => 'Pete', ssn => '999-45-2222' );
|
||||
my $person4 = Person->new( name => 'Peggy', ssn => '123-45-9999' );
|
||||
my $person5 = Person->new( name => 'Frank', ssn => '000-45-9999' );
|
||||
|
||||
If you did this:
|
||||
|
||||
my $array1 = [ $person1, $person2, $person4 ];
|
||||
my $array2 = [ $person1, $person3, $person4, $person5 ];
|
||||
GT::File::Diff::diff( $array1, $array2 );
|
||||
|
||||
everything would work out OK (each of the objects would be converted
|
||||
into a string like "Person=HASH(0x82425b0)" for comparison).
|
||||
|
||||
But if you did this:
|
||||
|
||||
my $array1 = [ $person1, $person2, $person4 ];
|
||||
my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
|
||||
GT::File::Diff::diff( $array1, $array2 );
|
||||
|
||||
$person4 and $person4->clone() (which have the same name and SSN)
|
||||
would be seen as different objects. If you wanted them to be considered
|
||||
equivalent, you would have to pass in a key generation function:
|
||||
|
||||
my $array1 = [ $person1, $person2, $person4 ];
|
||||
my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
|
||||
GT::File::Diff::diff( $array1, $array2, \&Person::hash );
|
||||
|
||||
This would use the 'ssn' field in each Person as a comparison key, and
|
||||
so would consider $person4 and $person4->clone() as equal.
|
||||
|
||||
You may also pass additional parameters to the key generation function
|
||||
if you wish.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This version by Ned Konz, perl@bike-nomad.com
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (c) 2000-2002 Ned Konz. All rights reserved.
|
||||
This program is free software;
|
||||
you can redistribute it and/or modify it under the same terms
|
||||
as Perl itself.
|
||||
|
||||
=head1 CREDITS
|
||||
|
||||
Versions through 0.59 (and much of this documentation) were written by:
|
||||
|
||||
Mark-Jason Dominus, mjd-perl-diff@plover.com
|
||||
|
||||
This version borrows the documentation and names of the routines
|
||||
from Mark-Jason's, but has all new code in Diff.pm.
|
||||
|
||||
This code was adapted from the Smalltalk code of
|
||||
Mario Wolczko <mario@wolczko.com>, which is available at
|
||||
ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st
|
||||
|
||||
C<sdiff> and C<traverse_balanced> were written by Mike Schilli
|
||||
<m@perlmeister.com>.
|
||||
|
||||
The algorithm is that described in
|
||||
I<A Fast Algorithm for Computing Longest Common Subsequences>,
|
||||
CACM, vol.20, no.5, pp.350-353, May 1977, with a few
|
||||
minor improvements to improve the speed.
|
||||
|
||||
=cut
|
||||
|
||||
# Create a hash that maps each element of $aCollection to the set of positions
|
||||
# it occupies in $aCollection, restricted to the elements within the range of
|
||||
# indexes specified by $start and $end.
|
||||
# The fourth parameter is a subroutine reference that will be called to
|
||||
# generate a string to use as a key.
|
||||
# Additional parameters, if any, will be passed to this subroutine.
|
||||
#
|
||||
# my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );
|
||||
|
||||
sub _withPositionsOfInInterval
|
||||
{
|
||||
my $aCollection = shift; # array ref
|
||||
my $start = shift;
|
||||
my $end = shift;
|
||||
my $keyGen = shift;
|
||||
my %d;
|
||||
my $index;
|
||||
for ( $index = $start ; $index <= $end ; $index++ )
|
||||
{
|
||||
my $element = $aCollection->[$index];
|
||||
my $key = &$keyGen( $element, @_ );
|
||||
if ( exists( $d{$key} ) )
|
||||
{
|
||||
unshift ( @{ $d{$key} }, $index );
|
||||
}
|
||||
else
|
||||
{
|
||||
$d{$key} = [$index];
|
||||
}
|
||||
}
|
||||
return wantarray ? %d : \%d;
|
||||
}
|
||||
|
||||
# Find the place at which aValue would normally be inserted into the array. If
|
||||
# that place is already occupied by aValue, do nothing, and return undef. If
|
||||
# the place does not exist (i.e., it is off the end of the array), add it to
|
||||
# the end, otherwise replace the element at that point with aValue.
|
||||
# It is assumed that the array's values are numeric.
|
||||
# This is where the bulk (75%) of the time is spent in this module, so try to
|
||||
# make it fast!
|
||||
|
||||
sub _replaceNextLargerWith
|
||||
{
|
||||
my ( $array, $aValue, $high ) = @_;
|
||||
$high ||= $#$array;
|
||||
|
||||
# off the end?
|
||||
if ( $high == -1 || $aValue > $array->[-1] )
|
||||
{
|
||||
push ( @$array, $aValue );
|
||||
return $high + 1;
|
||||
}
|
||||
|
||||
# binary search for insertion point...
|
||||
my $low = 0;
|
||||
my $index;
|
||||
my $found;
|
||||
while ( $low <= $high )
|
||||
{
|
||||
$index = ( $high + $low ) / 2;
|
||||
|
||||
# $index = int(( $high + $low ) / 2); # without 'use integer'
|
||||
$found = $array->[$index];
|
||||
|
||||
if ( $aValue == $found )
|
||||
{
|
||||
return undef;
|
||||
}
|
||||
elsif ( $aValue > $found )
|
||||
{
|
||||
$low = $index + 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
$high = $index - 1;
|
||||
}
|
||||
}
|
||||
|
||||
# now insertion point is in $low.
|
||||
$array->[$low] = $aValue; # overwrite next larger
|
||||
return $low;
|
||||
}
|
||||
|
||||
# This method computes the longest common subsequence in $a and $b.
|
||||
|
||||
# Result is array or ref, whose contents is such that
|
||||
# $a->[ $i ] == $b->[ $result[ $i ] ]
|
||||
# foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined.
|
||||
|
||||
# An additional argument may be passed; this is a hash or key generating
|
||||
# function that should return a string that uniquely identifies the given
|
||||
# element. It should be the case that if the key is the same, the elements
|
||||
# will compare the same. If this parameter is undef or missing, the key
|
||||
# will be the element as a string.
|
||||
|
||||
# By default, comparisons will use "eq" and elements will be turned into keys
|
||||
# using the default stringizing operator '""'.
|
||||
|
||||
# Additional parameters, if any, will be passed to the key generation routine.
|
||||
|
||||
sub _longestCommonSubsequence
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $keyGen = shift; # code ref
|
||||
my $compare; # code ref
|
||||
|
||||
# set up code refs
|
||||
# Note that these are optimized.
|
||||
if ( !defined($keyGen) ) # optimize for strings
|
||||
{
|
||||
$keyGen = sub { $_[0] };
|
||||
$compare = sub { my ( $a, $b ) = @_; $a eq $b };
|
||||
}
|
||||
else
|
||||
{
|
||||
$compare = sub {
|
||||
my $a = shift;
|
||||
my $b = shift;
|
||||
&$keyGen( $a, @_ ) eq &$keyGen( $b, @_ );
|
||||
};
|
||||
}
|
||||
|
||||
my ( $aStart, $aFinish, $bStart, $bFinish, $matchVector ) =
|
||||
( 0, $#$a, 0, $#$b, [] );
|
||||
|
||||
# First we prune off any common elements at the beginning
|
||||
while ( $aStart <= $aFinish
|
||||
and $bStart <= $bFinish
|
||||
and &$compare( $a->[$aStart], $b->[$bStart], @_ ) )
|
||||
{
|
||||
$matchVector->[ $aStart++ ] = $bStart++;
|
||||
}
|
||||
|
||||
# now the end
|
||||
while ( $aStart <= $aFinish
|
||||
and $bStart <= $bFinish
|
||||
and &$compare( $a->[$aFinish], $b->[$bFinish], @_ ) )
|
||||
{
|
||||
$matchVector->[ $aFinish-- ] = $bFinish--;
|
||||
}
|
||||
|
||||
# Now compute the equivalence classes of positions of elements
|
||||
my $bMatches =
|
||||
_withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ );
|
||||
my $thresh = [];
|
||||
my $links = [];
|
||||
|
||||
my ( $i, $ai, $j, $k );
|
||||
for ( $i = $aStart ; $i <= $aFinish ; $i++ )
|
||||
{
|
||||
$ai = &$keyGen( $a->[$i], @_ );
|
||||
if ( exists( $bMatches->{$ai} ) )
|
||||
{
|
||||
$k = 0;
|
||||
for $j ( @{ $bMatches->{$ai} } )
|
||||
{
|
||||
|
||||
# optimization: most of the time this will be true
|
||||
if ( $k and $thresh->[$k] > $j and $thresh->[ $k - 1 ] < $j )
|
||||
{
|
||||
$thresh->[$k] = $j;
|
||||
}
|
||||
else
|
||||
{
|
||||
$k = _replaceNextLargerWith( $thresh, $j, $k );
|
||||
}
|
||||
|
||||
# oddly, it's faster to always test this (CPU cache?).
|
||||
if ( defined($k) )
|
||||
{
|
||||
$links->[$k] =
|
||||
[ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (@$thresh)
|
||||
{
|
||||
for ( my $link = $links->[$#$thresh] ; $link ; $link = $link->[0] )
|
||||
{
|
||||
$matchVector->[ $link->[1] ] = $link->[2];
|
||||
}
|
||||
}
|
||||
|
||||
return wantarray ? @$matchVector : $matchVector;
|
||||
}
|
||||
|
||||
sub traverse_sequences
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $callbacks = shift || {};
|
||||
my $keyGen = shift;
|
||||
my $matchCallback = $callbacks->{'MATCH'} || sub { };
|
||||
my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
|
||||
my $finishedACallback = $callbacks->{'A_FINISHED'};
|
||||
my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
|
||||
my $finishedBCallback = $callbacks->{'B_FINISHED'};
|
||||
my $matchVector = _longestCommonSubsequence( $a, $b, $keyGen, @_ );
|
||||
|
||||
# Process all the lines in @$matchVector
|
||||
my $lastA = $#$a;
|
||||
my $lastB = $#$b;
|
||||
my $bi = 0;
|
||||
my $ai;
|
||||
|
||||
for ( $ai = 0 ; $ai <= $#$matchVector ; $ai++ )
|
||||
{
|
||||
my $bLine = $matchVector->[$ai];
|
||||
if ( defined($bLine) ) # matched
|
||||
{
|
||||
&$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
|
||||
&$matchCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai, $bi, @_ );
|
||||
}
|
||||
}
|
||||
|
||||
# The last entry (if any) processed was a match.
|
||||
# $ai and $bi point just past the last matching lines in their sequences.
|
||||
|
||||
while ( $ai <= $lastA or $bi <= $lastB )
|
||||
{
|
||||
|
||||
# last A?
|
||||
if ( $ai == $lastA + 1 and $bi <= $lastB )
|
||||
{
|
||||
if ( defined($finishedACallback) )
|
||||
{
|
||||
&$finishedACallback( $lastA, @_ );
|
||||
$finishedACallback = undef;
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardBCallback( $ai, $bi++, @_ ) while $bi <= $lastB;
|
||||
}
|
||||
}
|
||||
|
||||
# last B?
|
||||
if ( $bi == $lastB + 1 and $ai <= $lastA )
|
||||
{
|
||||
if ( defined($finishedBCallback) )
|
||||
{
|
||||
&$finishedBCallback( $lastB, @_ );
|
||||
$finishedBCallback = undef;
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ ) while $ai <= $lastA;
|
||||
}
|
||||
}
|
||||
|
||||
&$discardACallback( $ai++, $bi, @_ ) if $ai <= $lastA;
|
||||
&$discardBCallback( $ai, $bi++, @_ ) if $bi <= $lastB;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub traverse_balanced
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $callbacks = shift || {};
|
||||
my $keyGen = shift;
|
||||
my $matchCallback = $callbacks->{'MATCH'} || sub { };
|
||||
my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
|
||||
my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
|
||||
my $changeCallback = $callbacks->{'CHANGE'};
|
||||
my $matchVector = _longestCommonSubsequence( $a, $b, $keyGen, @_ );
|
||||
|
||||
# Process all the lines in match vector
|
||||
my $lastA = $#$a;
|
||||
my $lastB = $#$b;
|
||||
my $bi = 0;
|
||||
my $ai = 0;
|
||||
my $ma = -1;
|
||||
my $mb;
|
||||
|
||||
while (1)
|
||||
{
|
||||
|
||||
# Find next match indices $ma and $mb
|
||||
do { $ma++ } while ( $ma <= $#$matchVector && !defined $matchVector->[$ma] );
|
||||
|
||||
last if $ma > $#$matchVector; # end of matchVector?
|
||||
$mb = $matchVector->[$ma];
|
||||
|
||||
# Proceed with discard a/b or change events until
|
||||
# next match
|
||||
while ( $ai < $ma || $bi < $mb )
|
||||
{
|
||||
|
||||
if ( $ai < $ma && $bi < $mb )
|
||||
{
|
||||
|
||||
# Change
|
||||
if ( defined $changeCallback )
|
||||
{
|
||||
&$changeCallback( $ai++, $bi++, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
elsif ( $ai < $ma )
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
|
||||
# $bi < $mb
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
|
||||
# Match
|
||||
&$matchCallback( $ai++, $bi++, @_ );
|
||||
}
|
||||
|
||||
while ( $ai <= $lastA || $bi <= $lastB )
|
||||
{
|
||||
if ( $ai <= $lastA && $bi <= $lastB )
|
||||
{
|
||||
|
||||
# Change
|
||||
if ( defined $changeCallback )
|
||||
{
|
||||
&$changeCallback( $ai++, $bi++, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
elsif ( $ai <= $lastA )
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
|
||||
# $bi <= $lastB
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub LCS
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $matchVector = _longestCommonSubsequence( $a, @_ );
|
||||
my @retval;
|
||||
my $i;
|
||||
for ( $i = 0 ; $i <= $#$matchVector ; $i++ )
|
||||
{
|
||||
if ( defined( $matchVector->[$i] ) )
|
||||
{
|
||||
push ( @retval, $a->[$i] );
|
||||
}
|
||||
}
|
||||
return wantarray ? @retval : \@retval;
|
||||
}
|
||||
|
||||
sub diff
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $retval = [];
|
||||
my $hunk = [];
|
||||
my $discard = sub { push ( @$hunk, [ '-', $_[0], $a->[ $_[0] ] ] ) };
|
||||
my $add = sub { push ( @$hunk, [ '+', $_[1], $b->[ $_[1] ] ] ) };
|
||||
my $match = sub { push ( @$retval, $hunk ) if scalar(@$hunk); $hunk = [] };
|
||||
traverse_sequences( $a, $b,
|
||||
{ MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add }, @_ );
|
||||
&$match();
|
||||
return wantarray ? @$retval : $retval;
|
||||
}
|
||||
|
||||
sub sdiff
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $retval = [];
|
||||
my $discard = sub { push ( @$retval, [ '-', $a->[ $_[0] ], "" ] ) };
|
||||
my $add = sub { push ( @$retval, [ '+', "", $b->[ $_[1] ] ] ) };
|
||||
my $change = sub {
|
||||
push ( @$retval, [ 'c', $a->[ $_[0] ], $b->[ $_[1] ] ] );
|
||||
};
|
||||
my $match = sub {
|
||||
push ( @$retval, [ 'u', $a->[ $_[0] ], $b->[ $_[1] ] ] );
|
||||
};
|
||||
traverse_balanced(
|
||||
$a,
|
||||
$b,
|
||||
{
|
||||
MATCH => $match,
|
||||
DISCARD_A => $discard,
|
||||
DISCARD_B => $add,
|
||||
CHANGE => $change,
|
||||
},
|
||||
@_
|
||||
);
|
||||
return wantarray ? @$retval : $retval;
|
||||
}
|
||||
|
||||
1;
|
||||
1507
site/glist/lib/GT/File/Tools.pm
Normal file
1507
site/glist/lib/GT/File/Tools.pm
Normal file
File diff suppressed because it is too large
Load Diff
285
site/glist/lib/GT/FileMan.pm
Normal file
285
site/glist/lib/GT/FileMan.pm
Normal file
@@ -0,0 +1,285 @@
|
||||
# ==================================================================
|
||||
# File manager - enhanced web based file management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: FileMan.pm,v 1.121 2005/04/11 17:24:03 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
package GT::FileMan;
|
||||
#--------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/@ISA $DEBUG $HAVE_GZIP $HAVE_AZIP $UNSAFE_PATH/;
|
||||
use GT::Base qw/:persist/;
|
||||
use GT::Template;
|
||||
use GT::FileMan::Commands;
|
||||
|
||||
# Check if Compress::Zlib is available
|
||||
$HAVE_GZIP = eval { local $SIG{__DIE__}; require Compress::Zlib; 1; } ? 1 : 0;
|
||||
|
||||
# Check if Archive::Zip is available
|
||||
$HAVE_AZIP = eval { local $SIG{__DIE__}; require Archive::Zip; 1; } ? 1 : 0;
|
||||
|
||||
$DEBUG = 0;
|
||||
|
||||
@ISA = qw/GT::FileMan::Commands GT::Base/;
|
||||
|
||||
$UNSAFE_PATH = $^O =~ /mswin/i ? '(^|[/\\\\])\.\.?($|[/\\\\])' : '(^|/)\.\.?($|/)';
|
||||
|
||||
sub new {
|
||||
# ------------------------------------------------------------------
|
||||
# Constructor
|
||||
#
|
||||
my ($class,%args) = @_;
|
||||
my $self = bless {%args}, ref $class || $class;
|
||||
|
||||
$self->{cfg} = $self->load_config() if (!$self->{cfg});
|
||||
$self->{cfg}->{winnt} = $^O eq 'MSWin32' ? 1 : 0;
|
||||
$self->{cfg}->{upload_chmod} ||= '644';
|
||||
$self->{cfg}->{template_root} or die('You must pass in your template root !');
|
||||
$self->{cfg}->{root_dir} or die('You must set your root dir !');
|
||||
|
||||
$self->{in} = new GT::CGI;
|
||||
$self->{cgi} = $self->{in}->get_hash;
|
||||
|
||||
my $passwd_dir = $self->{passwd_dir};
|
||||
if ($passwd_dir and !$self->{in}->cookie('def_passwd_dir')) { #store the password directory to cookie
|
||||
$passwd_dir = "$self->{cfg}->{root_dir}/$passwd_dir" if ($self->{cfg}->{passwd_dir_level}); # must be inside root directory
|
||||
|
||||
(-e $passwd_dir and -w _) or die("$passwd_dir does not exist or not writeable");
|
||||
print $self->{in}->header (-cookie => [ $self->{in}->cookie ( -name => 'def_passwd_dir', -value => $passwd_dir, -expires => '+5y') ]);
|
||||
}
|
||||
|
||||
# Set our default working directory.
|
||||
$self->{work_path} = $self->{cgi}->{work_path};
|
||||
if ($self->{cgi}->{def_load} and !$self->{cgi}->{work_path}) {
|
||||
$self->{work_path} = ($self->{in}->cookie('def_working_dir') eq '/') ? '' : $self->{in}->cookie('def_working_dir');
|
||||
(!$self->{work_path} or ($self->{work_path} =~ m,^([-\w/. ]+)$, and $self->{work_path} !~ /$UNSAFE_PATH/)) or ($self->{work_path} = '');
|
||||
}
|
||||
$self->{work_path} ||= '';
|
||||
(!$self->{work_path} or ($self->{work_path} =~ m,^([-\w/. ]+)$, and $self->{work_path} !~ /$UNSAFE_PATH/)) or die ("work_path has invalid characters : $self->{work_path} ");
|
||||
-e "$self->{cfg}->{root_dir}/$self->{work_path}" or ($self->{work_path} = '');
|
||||
|
||||
$self->{http_ref} = $self->{in}->url (absolute => 0, query_string => 0);
|
||||
$self->{results} = '';
|
||||
$self->{data} = {};
|
||||
$self->{status} = '';
|
||||
$self->{input} = '';
|
||||
$self->{debug} and ($DEBUG = $self->{debug});
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub process {
|
||||
# ------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $action = $self->{cgi}->{fdo} || $self->{cgi}->{cmd_do};
|
||||
|
||||
return $self->page("home.html") if (!$action or $action eq 'fileman');
|
||||
|
||||
my $command_enable = 1; # default is enable
|
||||
$command_enable = $self->{commands}->{$action} if (exists $self->{commands}->{$action});
|
||||
|
||||
# Determine what to do:
|
||||
if (exists $GT::FileMan::Commands::COMPILE{$action} and $command_enable) {
|
||||
$self->$action();
|
||||
}
|
||||
else {
|
||||
die "<font color=red>Invalid action or command is disable : $action !</font>";
|
||||
}
|
||||
}
|
||||
|
||||
sub page {
|
||||
# ------------------------------------------------------------------
|
||||
# Print out the requested template
|
||||
#
|
||||
my ($self, $file, $args) = @_;
|
||||
$file ||= $self->{cgi}->{page};
|
||||
print $self->{in}->header;
|
||||
|
||||
my $template_path = ($self->{cgi}->{t}) ? "$self->{cfg}->{template_root}/$self->{cgi}->{t}" : $self->{cfg}->{template_root};
|
||||
|
||||
# Check the file name requested.
|
||||
"$template_path/$file" =~ /\\/ and return die "Invalid template '$file' requested (Invalid name)";
|
||||
"$template_path/$file" =~ /$UNSAFE_PATH/ and return die "Invalid template '$file' requested (Invalid name)";
|
||||
$file =~ m,^\s*/, and return die "Invalid template '$file' requested (Invalid name)";
|
||||
-e "$template_path/$file" or return die "Invalid template '$template_path/$file' requested (File does not exist)";
|
||||
-r _ or return die "Invalid template '$file' requested (Permission denied)";
|
||||
|
||||
# Make data available.
|
||||
foreach my $key (keys % {$self->{data}}) {
|
||||
exists $args->{$key} or $args->{$key} = $self->{data}->{$key};
|
||||
}
|
||||
|
||||
# Make cgi input available.
|
||||
foreach my $key (keys % {$self->{cgi}}) {
|
||||
exists $args->{$key} or $args->{$key} = $self->{cgi}->{$key};
|
||||
}
|
||||
|
||||
# Make commands available.
|
||||
my $count = 0;
|
||||
if ($self->{commands}) { #activate or deactivate the commands
|
||||
foreach my $key (keys % {$self->{commands}}) {
|
||||
exists $args->{$key} or $args->{$key} = $self->{commands}->{$key};
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
|
||||
$args->{show_all} = '1' if ($count == 0);
|
||||
$args->{status} ||= $self->{status};
|
||||
$args->{input} = $self->{input};
|
||||
$args->{http_ref} = $self->{http_ref};
|
||||
$args->{url_opts} = $self->{url_opts};
|
||||
$args->{work_path} = $self->{work_path} || $self->{cgi}->{work_path};
|
||||
$args->{template_root} = $self->{cfg}->{template_root};
|
||||
|
||||
$args->{root_dir} = $self->{cfg}->{root_dir};
|
||||
$args->{html_url} = $self->{cfg}->{html_root_url};
|
||||
$args->{root_url} = $self->{cfg}->{root_url};
|
||||
$args->{root_select} = $self->{cfg}->{root_select} if ($self->{cfg}->{root_select});
|
||||
$args->{session_id} = $self->{cfg}->{session_id} if ($self->{cfg}->{session_id});
|
||||
$args->{user_sessions} = $self->{cfg}->{user_sessions} if ($self->{cfg}->{user_sessions});
|
||||
$args->{username} = $self->{cfg}->{username} if ($self->{cfg}->{username});
|
||||
$args->{multi} = $self->{cfg}->{multi} if ($self->{cfg}->{multi});
|
||||
$args->{single} = $self->{cfg}->{single} if ($self->{cfg}->{single});
|
||||
|
||||
$args->{have_gzip} = $HAVE_GZIP;
|
||||
$args->{have_azip} = $HAVE_AZIP;
|
||||
$args->{srv_soft} = ($ENV{SERVER_SOFTWARE} =~ /Apache|Unix/)? 0 : 1 if ($ENV{SERVER_SOFTWARE});
|
||||
$args->{position} = $self->{in}->cookie('readme_position') if ($args->{readme});
|
||||
|
||||
$args->{scheme} = $self->{in}->cookie('scheme') || 'fileman';
|
||||
$args->{font} = $self->{in}->cookie('font') || "<font face='Verdana, Arial, Helvetica, sans-serif' size=2>";
|
||||
$args->{font} =~ s/[\'\"]/\'/g;
|
||||
|
||||
# Used for HTML editor
|
||||
my $brws = $self->get_browser();
|
||||
|
||||
# Export home for using in auto generate HTML.
|
||||
GT::Template->parse ("$template_path/$file", { %$args, %$brws }, { print => 1 });
|
||||
}
|
||||
|
||||
sub get_browser {
|
||||
my ($self, $verify) = @_;
|
||||
my ($version, %brws);
|
||||
if ($ENV{HTTP_USER_AGENT} and $ENV{HTTP_USER_AGENT} =~ /MSIE (\d+(?:\.\d+)?)/i) {
|
||||
$version = $1;
|
||||
$brws{ie_version} = $version;
|
||||
}
|
||||
$brws{is_ie} = ($version and $version >= 5.5) ? 1 : 0;
|
||||
|
||||
if ($ENV{HTTP_USER_AGENT} and $ENV{HTTP_USER_AGENT} =~ m{Mozilla/(\d+\.\d+)\s+\([^)]*rv:(\d+\.\d+)\)}) {
|
||||
if ($1 >= 5.0) {
|
||||
$brws{is_mozilla} = 1;
|
||||
$brws{mozilla_version} = $2;
|
||||
}
|
||||
}
|
||||
if ( $verify ) {
|
||||
($brws{ie_version} >= 5.5 or $brws{mozilla_version} >= 1.4) ? return 1 : return 0;
|
||||
}
|
||||
else {
|
||||
return \%brws;
|
||||
}
|
||||
}
|
||||
|
||||
sub load_config {
|
||||
# --------------------------------------------------------------------
|
||||
# Load the config file into a hash.
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = $self->{cfg_path} || 'ConfigData.pm';
|
||||
my $cfg = do $file;
|
||||
if (ref $cfg ne 'HASH') {
|
||||
die "Invalid config file: $file. Got: '$cfg' instead of actual data. Error: $@ $!";
|
||||
}
|
||||
return $cfg;
|
||||
}
|
||||
|
||||
sub fatal {
|
||||
# --------------------------------------------------------------
|
||||
# Return a fatal error message to the browser.
|
||||
#
|
||||
die @_ if (GT::Base->in_eval()); # Don't do anything if we are in eval.
|
||||
|
||||
my $msg = shift;
|
||||
my $in = new GT::CGI;
|
||||
print $in->header;
|
||||
|
||||
my $work_path = $in->param('work_path') || '';
|
||||
|
||||
print qq!
|
||||
<font face='Tahoma,Arial,Helvetica' size=2>A fatal error has occured:</font></p><blockquote><pre>$msg</pre></blockquote><p><font face='Tahoma,Arial,Helvetica' size=2>Please enable debugging in setup for more details.</font></p>\n
|
||||
!;
|
||||
if ($DEBUG) {
|
||||
print base_env();
|
||||
}
|
||||
}
|
||||
|
||||
sub base_env {
|
||||
# --------------------------------------------------------------------
|
||||
# Return HTML formatted environment for error messages.
|
||||
#
|
||||
my $info = '<PRE>';
|
||||
|
||||
# Stack trace.
|
||||
my $i = 0;
|
||||
$info .= "<B>Stack Trace</B>\n======================================\n";
|
||||
$info .= GT::Base::stack_trace('FileMan', 1, 1);
|
||||
$info .= "\n\n";
|
||||
|
||||
$info .= "<B>System Information</B>\n======================================\n";
|
||||
$info .= "Perl Version: $]\n";
|
||||
$info .= "FileMan Version: $FileMan::VERSION\n" if ($FileMan::VERSION);
|
||||
$info .= "Persistant Env: mod_perl (" . (MOD_PERL ? 1 : 0) . ") SpeedyCGI (" . (SPEEDY ? 1 : 0) . ")\n";
|
||||
$info .= "Mod Perl Version: " . MOD_PERL . "\n" if MOD_PERL;
|
||||
$info .= "\@INC = \n\t" . join ("\n\t", @INC) . "\n";
|
||||
$info .= "\$\@: $@\n" if ($@);
|
||||
$info .= "\n";
|
||||
|
||||
# Environment info.
|
||||
$info .= "<B>ENVIRONMENT</B>\n======================================\n";
|
||||
foreach (sort keys %ENV) { $info .= "$_ => $ENV{$_}\n"; }
|
||||
$info .= "</PRE>";
|
||||
return $info;
|
||||
}
|
||||
|
||||
sub js_quote_include {
|
||||
# --------------------------------------------------------------------
|
||||
# This uses GT::Template to parse the passed in argument. The results are
|
||||
# javascript escaped, and then returned.
|
||||
#
|
||||
my $file = shift;
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my $in = new GT::CGI;
|
||||
my $css_file = $in->cookie('scheme') || 'fileman';
|
||||
my $color;
|
||||
CASE: {
|
||||
($css_file eq 'fileman') and $color = '#D6D6D6', last CASE;
|
||||
($css_file eq 'gt') and $color = '#d9e4f2', last CASE;
|
||||
($css_file eq 'maple') and $color = '#F0E8CE', last CASE;
|
||||
($css_file eq 'rainy') and $color = '#CFD8C2', last CASE;
|
||||
($css_file eq 'rose') and $color = '#DEC9CE', last CASE;
|
||||
}
|
||||
my $parsed = GT::Template->parse("$tags->{template_root}/common/$file",
|
||||
{
|
||||
html_url => $tags->{html_url},
|
||||
http_ref => $tags->{http_ref},
|
||||
filename => $tags->{filename},
|
||||
work_path => $tags->{work_path},
|
||||
scrollbar_arrow_color => 'black',
|
||||
scrollbar_base_color => $color,
|
||||
editor_base_color => $color,
|
||||
advanced_editor_background => 'white',
|
||||
advanced_editor_font => 'arial'
|
||||
});
|
||||
$parsed =~ s{([\\/'"<>])}{\\$1}g;
|
||||
$parsed =~ s/(?:\r\n|\r|\n)/\\n/g;
|
||||
return \$parsed;
|
||||
}
|
||||
|
||||
1;
|
||||
3115
site/glist/lib/GT/FileMan/Commands.pm
Normal file
3115
site/glist/lib/GT/FileMan/Commands.pm
Normal file
File diff suppressed because it is too large
Load Diff
442
site/glist/lib/GT/FileMan/Diff.pm
Normal file
442
site/glist/lib/GT/FileMan/Diff.pm
Normal file
@@ -0,0 +1,442 @@
|
||||
# ==================================================================
|
||||
# File manager - enhanced web based file management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Diff.pm,v 1.9 2004/02/17 01:33:07 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
package GT::FileMan::Diff;
|
||||
# ==================================================================
|
||||
# This module is based off the example scripts distributed with Algorthim::Diff
|
||||
#
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION %HTML_ESCAPE);
|
||||
use GT::File::Diff;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
|
||||
%HTML_ESCAPE = (
|
||||
'&' => '&',
|
||||
'<' => '<',
|
||||
'>' => '>',
|
||||
'"' => '"'
|
||||
);
|
||||
|
||||
my $File_Length_Difference = 0;
|
||||
|
||||
sub diff {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes two filenames, or two array refs, and returns a text diff. See also
|
||||
# html_diff. Optionally takes an additional number - if provided, you'll get
|
||||
# a unified context diff with however many lines of context as you passed in for
|
||||
# this value, otherwise you'll get a boring old <, >-type diff.
|
||||
# Returns 1 if the first file couldn't be opened, 2 if the second couldn't be
|
||||
# opened, and a scalar reference containing the diff otherwise.
|
||||
#
|
||||
my ($file1, $file2, $context_lines) = @_;
|
||||
my ($f1_mod, $f2_mod, $filename1, $filename2);
|
||||
|
||||
if (!ref $file1) {
|
||||
my $fh = \do { local *FH; *FH };
|
||||
open $fh, "<$file1" or return 1;
|
||||
chomp(my @f1 = <$fh>);
|
||||
$f1_mod = (stat $fh)[9];
|
||||
($filename1, $file1) = ($file1, \@f1);
|
||||
}
|
||||
if (!ref $file2) {
|
||||
my $fh = \do { local *FH; *FH };
|
||||
open $fh, "<$file2" or return 2;
|
||||
chomp(my @f2 = <$fh>);
|
||||
$f2_mod = (stat $fh)[9];
|
||||
($filename2, $file2) = ($file2, \@f2);
|
||||
}
|
||||
|
||||
my $ret = "";
|
||||
my $diff = GT::File::Diff::diff($file1, $file2, \&_hash);
|
||||
return \($ret = "Files are identical") if not @$diff;
|
||||
|
||||
if ($context_lines and $f1_mod and $f2_mod) {
|
||||
$ret .= "--- $filename1\t" . gmtime($f1_mod) . " -0000\n";
|
||||
$ret .= "+++ $filename2\t" . gmtime($f2_mod) . " -0000\n";
|
||||
}
|
||||
|
||||
$File_Length_Difference = 0;
|
||||
|
||||
my ($hunk, $oldhunk);
|
||||
for my $piece (@$diff) {
|
||||
$hunk = GT::FileMan::Diff::Hunk->new($file1, $file2, $piece, $context_lines);
|
||||
next unless $oldhunk;
|
||||
|
||||
if ($context_lines and $hunk->does_overlap($oldhunk)) {
|
||||
$hunk->prepend_hunk($oldhunk);
|
||||
}
|
||||
else {
|
||||
$ret .= $oldhunk->output_diff($file1, $file2, $context_lines);
|
||||
}
|
||||
} continue { $oldhunk = $hunk }
|
||||
|
||||
$ret .= $oldhunk->output_diff($file1, $file2, $context_lines);
|
||||
\$ret;
|
||||
}
|
||||
|
||||
# This generates a unique key for the line; we simply take the line and convert
|
||||
# all multiple spaces into a single space to effectively perform a "diff -b".
|
||||
sub _hash {
|
||||
my $str = shift;
|
||||
$str =~ s/^\s+//;
|
||||
$str =~ s/\s+$//;
|
||||
$str =~ s/\s{2,}/ /g;
|
||||
$str;
|
||||
}
|
||||
|
||||
sub html_diff {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Works exactly as the above, but also HTML escapes and colorizes the diff.
|
||||
# The first two or three arguments are the same as above, and the last argument
|
||||
# is a hash ref of (ID => html_color) pairs. The ID's available, and defaults,
|
||||
# are as follows (scalar refs make the text also bold):
|
||||
# { file => \"#2e8b57", linenum => \"#a52a2a", sep => "#6a5acd", removed => "#6a5acd", added => "#008b8b" }
|
||||
# - file is used only in unified context diffs to show the filename & last modified time
|
||||
# - linenum is used to indicate the line numbers the change applies to
|
||||
# - sep is used only in non-unified diffs to separate the removed/added lines
|
||||
# - removed is the colour for removed lines
|
||||
# - added is the colour for added lines
|
||||
# The return is the same scalar reference or error number as that of diff(),
|
||||
# but formatted for HTML with escaped HTML where necessary and the whole thing
|
||||
# wrapped in <pre>...</pre>. Note that no checking or HTML escaping is
|
||||
# performed on the colors passed in; it is your responsibility to make sure the
|
||||
# values of the colors hash are safe.
|
||||
#
|
||||
my (@args) = @_;
|
||||
my %colors;
|
||||
%colors = %{pop @args} if ref $args[-1];
|
||||
|
||||
$colors{file} ||= \"#2e8b57";
|
||||
$colors{linenum} ||= \"#a52a2a";
|
||||
$colors{added} ||= "#008b8b";
|
||||
$colors{removed} ||= "#6a5acd";
|
||||
$colors{sep} ||= "#6a5acd";
|
||||
|
||||
for (keys %colors) {
|
||||
if (ref $colors{$_}) {
|
||||
$colors{$_} = qq|<font color="${$colors{$_}}"><b>|;
|
||||
$colors{"${_}_close"} = qq|</b></font>|;
|
||||
}
|
||||
else {
|
||||
$colors{$_} = qq|<font color="$colors{$_}">|;
|
||||
$colors{"${_}_close"} = qq|</font>|;
|
||||
}
|
||||
}
|
||||
|
||||
my $ret = diff(@args);
|
||||
return $ret unless ref $ret;
|
||||
|
||||
$$ret =~ s/(["&<>])/$HTML_ESCAPE{$1}/g;
|
||||
$$ret =~ s{^([^ ].*)}{
|
||||
my $line = $1;
|
||||
if ($line eq '---') {
|
||||
qq{$colors{sep}$line$colors{sep_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 3) eq '---' or substr($line, 0, 3) eq '+++') {
|
||||
qq{$colors{file}$line$colors{file_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 2) eq '@@' or $line =~ /^[0-9]/) {
|
||||
qq{$colors{linenum}$line$colors{linenum_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 1) eq '+' or substr($line, 0, 4) eq '>') {
|
||||
qq{$colors{added}$line$colors{added_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 1) eq '-' or substr($line, 0, 4) eq '<') {
|
||||
qq{$colors{removed}$line$colors{removed_close}}
|
||||
}
|
||||
else {
|
||||
# A mistake? We should never get here, but silently ignore if we do
|
||||
$line
|
||||
}
|
||||
}egm;
|
||||
|
||||
substr($$ret, 0, 0) = '<pre>';
|
||||
$$ret .= '</pre>';
|
||||
|
||||
$ret;
|
||||
}
|
||||
|
||||
|
||||
# Package Hunk. A Hunk is a group of Blocks which overlap because of the
|
||||
# context surrounding each block. (So if we're not using context, every
|
||||
# hunk will contain one block.)
|
||||
package GT::FileMan::Diff::Hunk;
|
||||
|
||||
sub new {
|
||||
# Arg1 is output from &LCS::diff (which corresponds to one Block)
|
||||
# Arg2 is the number of items (lines, e.g.,) of context around each block
|
||||
#
|
||||
# This subroutine changes $File_Length_Difference
|
||||
#
|
||||
# Fields in a Hunk:
|
||||
# blocks - a list of Block objects
|
||||
# start - index in file 1 where first block of the hunk starts
|
||||
# end - index in file 1 where last block of the hunk ends
|
||||
#
|
||||
# Variables:
|
||||
# before_diff - how much longer file 2 is than file 1 due to all hunks
|
||||
# until but NOT including this one
|
||||
# after_diff - difference due to all hunks including this one
|
||||
my ($class, $f1, $f2, $piece, $context_items) = @_;
|
||||
|
||||
my $block = new GT::FileMan::Diff::Block ($piece); # this modifies $FLD!
|
||||
|
||||
my $before_diff = $File_Length_Difference; # BEFORE this hunk
|
||||
my $after_diff = $before_diff + $block->{"length_diff"};
|
||||
$File_Length_Difference += $block->{"length_diff"};
|
||||
|
||||
# @remove_array and @insert_array hold the items to insert and remove
|
||||
# Save the start & beginning of each array. If the array doesn't exist
|
||||
# though (e.g., we're only adding items in this block), then figure
|
||||
# out the line number based on the line number of the other file and
|
||||
# the current difference in file lenghts
|
||||
my @remove_array = $block->remove;
|
||||
my @insert_array = $block->insert;
|
||||
my ($a1, $a2, $b1, $b2, $start1, $start2, $end1, $end2);
|
||||
$a1 = @remove_array ? $remove_array[0 ]->{"item_no"} : -1;
|
||||
$a2 = @remove_array ? $remove_array[-1]->{"item_no"} : -1;
|
||||
$b1 = @insert_array ? $insert_array[0 ]->{"item_no"} : -1;
|
||||
$b2 = @insert_array ? $insert_array[-1]->{"item_no"} : -1;
|
||||
|
||||
$start1 = $a1 == -1 ? $b1 - $before_diff : $a1;
|
||||
$end1 = $a2 == -1 ? $b2 - $after_diff : $a2;
|
||||
$start2 = $b1 == -1 ? $a1 + $before_diff : $b1;
|
||||
$end2 = $b2 == -1 ? $a2 + $after_diff : $b2;
|
||||
|
||||
# At first, a hunk will have just one Block in it
|
||||
my $hunk = {
|
||||
"start1" => $start1,
|
||||
"start2" => $start2,
|
||||
"end1" => $end1,
|
||||
"end2" => $end2,
|
||||
"blocks" => [$block],
|
||||
"f1" => $f1,
|
||||
"f2" => $f2
|
||||
};
|
||||
bless $hunk, $class;
|
||||
|
||||
$hunk->flag_context($context_items);
|
||||
|
||||
return $hunk;
|
||||
}
|
||||
|
||||
# Change the "start" and "end" fields to note that context should be added
|
||||
# to this hunk
|
||||
sub flag_context {
|
||||
my ($hunk, $context_items) = @_;
|
||||
return unless $context_items; # no context
|
||||
|
||||
# add context before
|
||||
my $start1 = $hunk->{"start1"};
|
||||
my $num_added = $context_items > $start1 ? $start1 : $context_items;
|
||||
$hunk->{"start1"} -= $num_added;
|
||||
$hunk->{"start2"} -= $num_added;
|
||||
|
||||
# context after
|
||||
my $end1 = $hunk->{"end1"};
|
||||
$num_added = ($end1+$context_items > $#{$hunk->{f1}}) ?
|
||||
$#{$hunk->{f1}} - $end1 :
|
||||
$context_items;
|
||||
$hunk->{"end1"} += $num_added;
|
||||
$hunk->{"end2"} += $num_added;
|
||||
}
|
||||
|
||||
# Is there an overlap between hunk arg0 and old hunk arg1?
|
||||
# Note: if end of old hunk is one less than beginning of second, they overlap
|
||||
sub does_overlap {
|
||||
my ($hunk, $oldhunk) = @_;
|
||||
return "" unless $oldhunk; # first time through, $oldhunk is empty
|
||||
|
||||
# Do I actually need to test both?
|
||||
return ($hunk->{"start1"} - $oldhunk->{"end1"} <= 1 ||
|
||||
$hunk->{"start2"} - $oldhunk->{"end2"} <= 1);
|
||||
}
|
||||
|
||||
# Prepend hunk arg1 to hunk arg0
|
||||
# Note that arg1 isn't updated! Only arg0 is.
|
||||
sub prepend_hunk {
|
||||
my ($hunk, $oldhunk) = @_;
|
||||
|
||||
$hunk->{"start1"} = $oldhunk->{"start1"};
|
||||
$hunk->{"start2"} = $oldhunk->{"start2"};
|
||||
|
||||
unshift (@{$hunk->{"blocks"}}, @{$oldhunk->{"blocks"}});
|
||||
}
|
||||
|
||||
|
||||
# DIFF OUTPUT ROUTINES. THESE ROUTINES CONTAIN DIFF FORMATTING INFO...
|
||||
sub output_diff {
|
||||
my $context_diff = $_[3];
|
||||
if ($context_diff) { return &output_unified_diff }
|
||||
else { return &output_boring_diff }
|
||||
}
|
||||
|
||||
sub output_unified_diff {
|
||||
my ($hunk, $fileref1, $fileref2) = @_;
|
||||
my @blocklist;
|
||||
my $ret = "";
|
||||
|
||||
# Calculate item number range.
|
||||
my $range1 = $hunk->unified_range(1);
|
||||
my $range2 = $hunk->unified_range(2);
|
||||
$ret .= "@@ -$range1 +$range2 @@\n";
|
||||
|
||||
# Outlist starts containing the hunk of file 1.
|
||||
# Removing an item just means putting a '-' in front of it.
|
||||
# Inserting an item requires getting it from file2 and splicing it in.
|
||||
# We splice in $num_added items. Remove blocks use $num_added because
|
||||
# splicing changed the length of outlist.
|
||||
# We remove $num_removed items. Insert blocks use $num_removed because
|
||||
# their item numbers---corresponding to positions in file *2*--- don't take
|
||||
# removed items into account.
|
||||
my $low = $hunk->{"start1"};
|
||||
my $hi = $hunk->{"end1"};
|
||||
my ($num_added, $num_removed) = (0,0);
|
||||
my @outlist = @$fileref1[$low..$hi];
|
||||
for (@outlist) { s/^/ / } # assume it's just context
|
||||
|
||||
foreach my $block (@{$hunk->{"blocks"}}) {
|
||||
foreach my $item ($block->remove) {
|
||||
my $op = $item->{"sign"}; # -
|
||||
my $offset = $item->{"item_no"} - $low + $num_added;
|
||||
$outlist[$offset] =~ s/^ /$op/;
|
||||
$num_removed++;
|
||||
}
|
||||
foreach my $item ($block->insert) {
|
||||
my $op = $item->{"sign"}; # +
|
||||
my $i = $item->{"item_no"};
|
||||
my $offset = $i - $hunk->{"start2"} + $num_removed;
|
||||
splice(@outlist,$offset,0,"$op$$fileref2[$i]");
|
||||
$num_added++;
|
||||
}
|
||||
}
|
||||
|
||||
for (@outlist) { $ret .= "$_\n" } # add \n's
|
||||
$ret;
|
||||
}
|
||||
|
||||
sub output_boring_diff {
|
||||
# Note that an old diff can't have any context. Therefore, we know that
|
||||
# there's only one block in the hunk.
|
||||
my ($hunk, $fileref1, $fileref2) = @_;
|
||||
my %op_hash = ('+' => 'a', '-' => 'd', '!' => 'c');
|
||||
|
||||
my $ret = '';
|
||||
my @blocklist = @{$hunk->{"blocks"}};
|
||||
warn ("Expecting one block in an old diff hunk!") if scalar @blocklist != 1;
|
||||
my $block = $blocklist[0];
|
||||
my $op = $block->op; # +, -, or !
|
||||
|
||||
# Calculate item number range.
|
||||
# old diff range is just like a context diff range, except the ranges
|
||||
# are on one line with the action between them.
|
||||
my $range1 = $hunk->context_range(1);
|
||||
my $range2 = $hunk->context_range(2);
|
||||
my $action = $op_hash{$op} || warn "unknown op $op";
|
||||
$ret .= "$range1$action$range2\n";
|
||||
|
||||
# If removing anything, just print out all the remove lines in the hunk
|
||||
# which is just all the remove lines in the block
|
||||
if (my @foo = $block->remove) {
|
||||
my @outlist = @$fileref1[$hunk->{"start1"}..$hunk->{"end1"}];
|
||||
map {$_ = "< $_\n"} @outlist; # all lines will be '< text\n'
|
||||
$ret .= join '', @outlist;
|
||||
}
|
||||
|
||||
$ret .= "---\n" if $op eq '!'; # only if inserting and removing
|
||||
if ($block->insert) {
|
||||
my @outlist = @$fileref2[$hunk->{"start2"}..$hunk->{"end2"}];
|
||||
map {$_ = "> $_\n"} @outlist; # all lines will be '> text\n'
|
||||
$ret .= join "", @outlist;
|
||||
}
|
||||
}
|
||||
|
||||
sub context_range {
|
||||
# Generate a range of item numbers to print. Only print 1 number if the range
|
||||
# has only one item in it. Otherwise, it's 'start,end'
|
||||
my ($hunk, $flag) = @_;
|
||||
my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
|
||||
$start++; $end++; # index from 1, not zero
|
||||
my $range = ($start < $end) ? "$start,$end" : $end;
|
||||
return $range;
|
||||
}
|
||||
|
||||
sub unified_range {
|
||||
# Generate a range of item numbers to print for unified diff
|
||||
# Print number where block starts, followed by number of lines in the block
|
||||
# (don't print number of lines if it's 1)
|
||||
my ($hunk, $flag) = @_;
|
||||
my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
|
||||
$start++; $end++; # index from 1, not zero
|
||||
my $length = $end - $start + 1;
|
||||
my $first = $length < 2 ? $end : $start; # strange, but correct...
|
||||
my $range = $length== 1 ? $first : "$first,$length";
|
||||
return $range;
|
||||
}
|
||||
|
||||
package GT::FileMan::Diff::Block;
|
||||
# Package Block. A block is an operation removing, adding, or changing
|
||||
# a group of items. Basically, this is just a list of changes, where each
|
||||
# change adds or deletes a single item.
|
||||
# (Change could be a separate class, but it didn't seem worth it)
|
||||
|
||||
sub new {
|
||||
# Input is a chunk from &Algorithm::LCS::diff
|
||||
# Fields in a block:
|
||||
# length_diff - how much longer file 2 is than file 1 due to this block
|
||||
# Each change has:
|
||||
# sign - '+' for insert, '-' for remove
|
||||
# item_no - number of the item in the file (e.g., line number)
|
||||
# We don't bother storing the text of the item
|
||||
#
|
||||
my ($class,$chunk) = @_;
|
||||
my @changes = ();
|
||||
|
||||
# This just turns each change into a hash.
|
||||
foreach my $item (@$chunk) {
|
||||
my ($sign, $item_no, $text) = @$item;
|
||||
my $hashref = {"sign" => $sign, "item_no" => $item_no};
|
||||
push @changes, $hashref;
|
||||
}
|
||||
|
||||
my $block = { "changes" => \@changes };
|
||||
bless $block, $class;
|
||||
|
||||
$block->{"length_diff"} = $block->insert - $block->remove;
|
||||
return $block;
|
||||
}
|
||||
|
||||
|
||||
# LOW LEVEL FUNCTIONS
|
||||
sub op {
|
||||
# what kind of block is this?
|
||||
my $block = shift;
|
||||
my $insert = $block->insert;
|
||||
my $remove = $block->remove;
|
||||
|
||||
$remove && $insert and return '!';
|
||||
$remove and return '-';
|
||||
$insert and return '+';
|
||||
warn "unknown block type";
|
||||
return '^'; # context block
|
||||
}
|
||||
|
||||
# Returns a list of the changes in this block that remove items
|
||||
# (or the number of removals if called in scalar context)
|
||||
sub remove { return grep {$_->{"sign"} eq '-'} @{shift->{"changes"}}; }
|
||||
|
||||
# Returns a list of the changes in this block that insert items
|
||||
sub insert { return grep {$_->{"sign"} eq '+'} @{shift->{"changes"}}; }
|
||||
|
||||
1;
|
||||
520
site/glist/lib/GT/MD5.pm
Normal file
520
site/glist/lib/GT/MD5.pm
Normal file
@@ -0,0 +1,520 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::MD5
|
||||
# Author: Scott Beck (see pod for details)
|
||||
# CVS Info :
|
||||
# $Id: MD5.pm,v 1.19 2004/11/17 01:23:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# See bottom for addition Copyrights.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: This is an implementation of the MD5 algorithm in perl.
|
||||
#
|
||||
|
||||
package GT::MD5;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORTER @EXPORT_OK $DATA);
|
||||
|
||||
@EXPORT_OK = qw(md5 md5_hex md5_base64);
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.19 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
$DATA = <<'END_OF_CODE';
|
||||
use integer;
|
||||
|
||||
# I-Vektor
|
||||
sub A() { 0x67_45_23_01 }
|
||||
sub B() { 0xef_cd_ab_89 }
|
||||
sub C() { 0x98_ba_dc_fe }
|
||||
sub D() { 0x10_32_54_76 }
|
||||
|
||||
# for internal use
|
||||
sub MAX() { 0xFFFFFFFF }
|
||||
|
||||
@GT::MD5::DATA = split "\n", q|
|
||||
FF,$a,$b,$c,$d,$_[4],7,0xd76aa478,/* 1 */
|
||||
FF,$d,$a,$b,$c,$_[5],12,0xe8c7b756,/* 2 */
|
||||
FF,$c,$d,$a,$b,$_[6],17,0x242070db,/* 3 */
|
||||
FF,$b,$c,$d,$a,$_[7],22,0xc1bdceee,/* 4 */
|
||||
FF,$a,$b,$c,$d,$_[8],7,0xf57c0faf,/* 5 */
|
||||
FF,$d,$a,$b,$c,$_[9],12,0x4787c62a,/* 6 */
|
||||
FF,$c,$d,$a,$b,$_[10],17,0xa8304613,/* 7 */
|
||||
FF,$b,$c,$d,$a,$_[11],22,0xfd469501,/* 8 */
|
||||
FF,$a,$b,$c,$d,$_[12],7,0x698098d8,/* 9 */
|
||||
FF,$d,$a,$b,$c,$_[13],12,0x8b44f7af,/* 10 */
|
||||
FF,$c,$d,$a,$b,$_[14],17,0xffff5bb1,/* 11 */
|
||||
FF,$b,$c,$d,$a,$_[15],22,0x895cd7be,/* 12 */
|
||||
FF,$a,$b,$c,$d,$_[16],7,0x6b901122,/* 13 */
|
||||
FF,$d,$a,$b,$c,$_[17],12,0xfd987193,/* 14 */
|
||||
FF,$c,$d,$a,$b,$_[18],17,0xa679438e,/* 15 */
|
||||
FF,$b,$c,$d,$a,$_[19],22,0x49b40821,/* 16 */
|
||||
GG,$a,$b,$c,$d,$_[5],5,0xf61e2562,/* 17 */
|
||||
GG,$d,$a,$b,$c,$_[10],9,0xc040b340,/* 18 */
|
||||
GG,$c,$d,$a,$b,$_[15],14,0x265e5a51,/* 19 */
|
||||
GG,$b,$c,$d,$a,$_[4],20,0xe9b6c7aa,/* 20 */
|
||||
GG,$a,$b,$c,$d,$_[9],5,0xd62f105d,/* 21 */
|
||||
GG,$d,$a,$b,$c,$_[14],9,0x2441453,/* 22 */
|
||||
GG,$c,$d,$a,$b,$_[19],14,0xd8a1e681,/* 23 */
|
||||
GG,$b,$c,$d,$a,$_[8],20,0xe7d3fbc8,/* 24 */
|
||||
GG,$a,$b,$c,$d,$_[13],5,0x21e1cde6,/* 25 */
|
||||
GG,$d,$a,$b,$c,$_[18],9,0xc33707d6,/* 26 */
|
||||
GG,$c,$d,$a,$b,$_[7],14,0xf4d50d87,/* 27 */
|
||||
GG,$b,$c,$d,$a,$_[12],20,0x455a14ed,/* 28 */
|
||||
GG,$a,$b,$c,$d,$_[17],5,0xa9e3e905,/* 29 */
|
||||
GG,$d,$a,$b,$c,$_[6],9,0xfcefa3f8,/* 30 */
|
||||
GG,$c,$d,$a,$b,$_[11],14,0x676f02d9,/* 31 */
|
||||
GG,$b,$c,$d,$a,$_[16],20,0x8d2a4c8a,/* 32 */
|
||||
HH,$a,$b,$c,$d,$_[9],4,0xfffa3942,/* 33 */
|
||||
HH,$d,$a,$b,$c,$_[12],11,0x8771f681,/* 34 */
|
||||
HH,$c,$d,$a,$b,$_[15],16,0x6d9d6122,/* 35 */
|
||||
HH,$b,$c,$d,$a,$_[18],23,0xfde5380c,/* 36 */
|
||||
HH,$a,$b,$c,$d,$_[5],4,0xa4beea44,/* 37 */
|
||||
HH,$d,$a,$b,$c,$_[8],11,0x4bdecfa9,/* 38 */
|
||||
HH,$c,$d,$a,$b,$_[11],16,0xf6bb4b60,/* 39 */
|
||||
HH,$b,$c,$d,$a,$_[14],23,0xbebfbc70,/* 40 */
|
||||
HH,$a,$b,$c,$d,$_[17],4,0x289b7ec6,/* 41 */
|
||||
HH,$d,$a,$b,$c,$_[4],11,0xeaa127fa,/* 42 */
|
||||
HH,$c,$d,$a,$b,$_[7],16,0xd4ef3085,/* 43 */
|
||||
HH,$b,$c,$d,$a,$_[10],23,0x4881d05,/* 44 */
|
||||
HH,$a,$b,$c,$d,$_[13],4,0xd9d4d039,/* 45 */
|
||||
HH,$d,$a,$b,$c,$_[16],11,0xe6db99e5,/* 46 */
|
||||
HH,$c,$d,$a,$b,$_[19],16,0x1fa27cf8,/* 47 */
|
||||
HH,$b,$c,$d,$a,$_[6],23,0xc4ac5665,/* 48 */
|
||||
II,$a,$b,$c,$d,$_[4],6,0xf4292244,/* 49 */
|
||||
II,$d,$a,$b,$c,$_[11],10,0x432aff97,/* 50 */
|
||||
II,$c,$d,$a,$b,$_[18],15,0xab9423a7,/* 51 */
|
||||
II,$b,$c,$d,$a,$_[9],21,0xfc93a039,/* 52 */
|
||||
II,$a,$b,$c,$d,$_[16],6,0x655b59c3,/* 53 */
|
||||
II,$d,$a,$b,$c,$_[7],10,0x8f0ccc92,/* 54 */
|
||||
II,$c,$d,$a,$b,$_[14],15,0xffeff47d,/* 55 */
|
||||
II,$b,$c,$d,$a,$_[5],21,0x85845dd1,/* 56 */
|
||||
II,$a,$b,$c,$d,$_[12],6,0x6fa87e4f,/* 57 */
|
||||
II,$d,$a,$b,$c,$_[19],10,0xfe2ce6e0,/* 58 */
|
||||
II,$c,$d,$a,$b,$_[10],15,0xa3014314,/* 59 */
|
||||
II,$b,$c,$d,$a,$_[17],21,0x4e0811a1,/* 60 */
|
||||
II,$a,$b,$c,$d,$_[8],6,0xf7537e82,/* 61 */
|
||||
II,$d,$a,$b,$c,$_[15],10,0xbd3af235,/* 62 */
|
||||
II,$c,$d,$a,$b,$_[6],15,0x2ad7d2bb,/* 63 */
|
||||
II,$b,$c,$d,$a,$_[13],21,0xeb86d391,/* 64 */|;
|
||||
|
||||
|
||||
# padd a message to a multiple of 64
|
||||
sub padding {
|
||||
my $l = length (my $msg = shift() . chr(128));
|
||||
$msg .= "\0" x (($l%64<=56?56:120)-$l%64);
|
||||
$l = ($l-1)*8;
|
||||
$msg .= pack 'VV', $l & MAX , ($l >> 16 >> 16);
|
||||
}
|
||||
|
||||
|
||||
sub rotate_left($$) {
|
||||
#$_[0] << $_[1] | $_[0] >> (32 - $_[1]);
|
||||
#my $right = $_[0] >> (32 - $_[1]);
|
||||
#my $rmask = (1 << $_[1]) - 1;
|
||||
($_[0] << $_[1]) | (( $_[0] >> (32 - $_[1]) ) & ((1 << $_[1]) - 1));
|
||||
#$_[0] << $_[1] | (($_[0]>> (32 - $_[1])) & (1 << (32 - $_[1])) - 1);
|
||||
}
|
||||
|
||||
sub gen_code {
|
||||
# Discard upper 32 bits on 64 bit archs.
|
||||
my $MSK = ((1 << 16) << 16) ? ' & ' . MAX : '';
|
||||
# FF => "X0=rotate_left(((X1&X2)|(~X1&X3))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
# GG => "X0=rotate_left(((X1&X3)|(X2&(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
my %f = (
|
||||
FF => "X0=rotate_left((X3^(X1&(X2^X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
GG => "X0=rotate_left((X2^(X3&(X1^X2)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
HH => "X0=rotate_left((X1^X2^X3)+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
II => "X0=rotate_left((X2^(X1|(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
);
|
||||
#unless ( (1 << 16) << 16) { %f = %{$CODES{'32bit'}} }
|
||||
#else { %f = %{$CODES{'64bit'}} }
|
||||
|
||||
my %s = ( # shift lengths
|
||||
S11 => 7, S12 => 12, S13 => 17, S14 => 22, S21 => 5, S22 => 9, S23 => 14,
|
||||
S24 => 20, S31 => 4, S32 => 11, S33 => 16, S34 => 23, S41 => 6, S42 => 10,
|
||||
S43 => 15, S44 => 21
|
||||
);
|
||||
|
||||
my $insert = "\n";
|
||||
# while(<DATA>) {
|
||||
for (@GT::MD5::DATA) {
|
||||
# chomp;
|
||||
next unless /^[FGHI]/;
|
||||
my ($func,@x) = split /,/;
|
||||
my $c = $f{$func};
|
||||
$c =~ s/X(\d)/$x[$1]/g;
|
||||
$c =~ s/(S\d{2})/$s{$1}/;
|
||||
$c =~ s/^(.*)=rotate_left\((.*),(.*)\)\+(.*)$//;
|
||||
|
||||
my $su = 32 - $3;
|
||||
my $sh = (1 << $3) - 1;
|
||||
|
||||
$c = "$1=(((\$r=$2)<<$3)|((\$r>>$su)&$sh))+$4";
|
||||
|
||||
#my $rotate = "(($2 << $3) || (($2 >> (32 - $3)) & (1 << $2) - 1)))";
|
||||
# $c = "\$r = $2;
|
||||
# $1 = ((\$r << $3) | ((\$r >> (32 - $3)) & ((1 << $3) - 1))) + $4";
|
||||
$insert .= "\t$c\n";
|
||||
}
|
||||
# close DATA;
|
||||
|
||||
my $dump = '
|
||||
sub round {
|
||||
my ($a,$b,$c,$d) = @_[0 .. 3];
|
||||
my $r;' . $insert . '
|
||||
$_[0]+$a' . $MSK . ', $_[1]+$b ' . $MSK .
|
||||
', $_[2]+$c' . $MSK . ', $_[3]+$d' . $MSK . ';
|
||||
}';
|
||||
eval $dump;
|
||||
# print "$dump\n";
|
||||
# exit 0;
|
||||
}
|
||||
|
||||
gen_code();
|
||||
|
||||
#########################################
|
||||
# Private output converter functions:
|
||||
sub _encode_hex { unpack 'H*', $_[0] }
|
||||
sub _encode_base64 {
|
||||
my $res;
|
||||
while ($_[0] =~ /(.{1,45})/gs) {
|
||||
$res .= substr pack('u', $1), 1;
|
||||
chop $res;
|
||||
}
|
||||
$res =~ tr|` -_|AA-Za-z0-9+/|;#`
|
||||
chop $res; chop $res;
|
||||
$res
|
||||
}
|
||||
|
||||
#########################################
|
||||
# OOP interface:
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref $proto || $proto;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
$self->reset();
|
||||
$self
|
||||
}
|
||||
|
||||
sub reset {
|
||||
my $self = shift;
|
||||
delete $self->{_data};
|
||||
$self->{_state} = [A,B,C,D];
|
||||
$self->{_length} = 0;
|
||||
$self
|
||||
}
|
||||
|
||||
sub add {
|
||||
my $self = shift;
|
||||
$self->{_data} .= join '', @_ if @_;
|
||||
my ($i,$c);
|
||||
for $i (0 .. (length $self->{_data})/64-1) {
|
||||
my @X = unpack 'V16', substr $self->{_data}, $i*64, 64;
|
||||
@{$self->{_state}} = round(@{$self->{_state}},@X);
|
||||
++$c;
|
||||
}
|
||||
if ($c) {
|
||||
substr ($self->{_data}, 0, $c*64) = '';
|
||||
$self->{_length} += $c*64;
|
||||
}
|
||||
$self
|
||||
}
|
||||
|
||||
sub finalize {
|
||||
my $self = shift;
|
||||
$self->{_data} .= chr(128);
|
||||
my $l = $self->{_length} + length $self->{_data};
|
||||
$self->{_data} .= "\0" x (($l%64<=56?56:120)-$l%64);
|
||||
$l = ($l-1)*8;
|
||||
$self->{_data} .= pack 'VV', $l & MAX , ($l >> 16 >> 16);
|
||||
$self->add();
|
||||
$self
|
||||
}
|
||||
|
||||
sub addfile {
|
||||
my ($self,$fh) = @_;
|
||||
if (!ref($fh) && ref(\$fh) ne "GLOB") {
|
||||
require Symbol;
|
||||
$fh = Symbol::qualify($fh, scalar caller);
|
||||
}
|
||||
# $self->{_data} .= do{local$/;<$fh>};
|
||||
my $read = 0;
|
||||
my $buffer = '';
|
||||
$self->add($buffer) while $read = read $fh, $buffer, 8192;
|
||||
die "GT::MD5 read failed: $!" unless defined $read;
|
||||
$self
|
||||
}
|
||||
|
||||
sub add_bits {
|
||||
my $self = shift;
|
||||
return $self->add( pack 'B*', shift ) if @_ == 1;
|
||||
my ($b,$n) = @_;
|
||||
die "GT::MD5 Invalid number of bits\n" if $n%8;
|
||||
$self->add( substr $b, 0, $n/8 )
|
||||
}
|
||||
|
||||
sub digest {
|
||||
my $self = shift;
|
||||
$self->finalize();
|
||||
my $res = pack 'V4', @{$self->{_state}};
|
||||
$self->reset();
|
||||
$res
|
||||
}
|
||||
|
||||
sub hexdigest {
|
||||
_encode_hex($_[0]->digest)
|
||||
}
|
||||
|
||||
sub b64digest {
|
||||
_encode_base64($_[0]->digest)
|
||||
}
|
||||
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
my $clone = {
|
||||
_state => [@{$self->{_state}}],
|
||||
_length => $self->{_length},
|
||||
_data => $self->{_data}
|
||||
};
|
||||
bless $clone, ref $self || $self;
|
||||
}
|
||||
|
||||
#########################################
|
||||
# Procedural interface:
|
||||
sub md5 {
|
||||
my $message = padding(join'',@_);
|
||||
my ($a,$b,$c,$d) = (A,B,C,D);
|
||||
my $i;
|
||||
for $i (0 .. (length $message)/64-1) {
|
||||
my @X = unpack 'V16', substr $message,$i*64,64;
|
||||
($a,$b,$c,$d) = round($a,$b,$c,$d,@X);
|
||||
}
|
||||
pack 'V4',$a,$b,$c,$d;
|
||||
}
|
||||
sub md5_hex { _encode_hex &md5 }
|
||||
sub md5_base64 { _encode_base64 &md5 }
|
||||
END_OF_CODE
|
||||
|
||||
# Load either Digest::MD5 or GT::MD5 functions.
|
||||
eval {
|
||||
local $SIG{__DIE__};
|
||||
require Digest::MD5;
|
||||
foreach (@EXPORT_OK) { delete $GT::MD5::{$_}; } # Do not remove.
|
||||
import Digest::MD5 (@EXPORT_OK);
|
||||
*GT::MD5::md5_hex = sub { &Digest::MD5::md5_hex };
|
||||
*GT::MD5::md5 = sub { &Digest::MD5::md5 };
|
||||
*GT::MD5::md5_base64 = sub { &Digest::MD5::md5_base64 };
|
||||
@ISA = 'Digest::MD5';
|
||||
1;
|
||||
}
|
||||
or do {
|
||||
local $@;
|
||||
eval $DATA;
|
||||
$@ and die "GT::MD5 => can't compile: $@";
|
||||
};
|
||||
|
||||
require Exporter;
|
||||
import Exporter;
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::MD5 - Perl implementation of Ron Rivests MD5 Algorithm
|
||||
|
||||
=head1 DISCLAIMER
|
||||
|
||||
Majority of this module's code is borrowed from Digest::Perl::MD5 (Version 1.8).
|
||||
|
||||
This is B<not> an interface (like C<Digest::MD5>) but a Perl implementation of MD5.
|
||||
It is written in perl only and because of this it is slow but it works without C-Code.
|
||||
You should use C<Digest::MD5> instead of this module if it is available.
|
||||
This module is only usefull for
|
||||
|
||||
=over 4
|
||||
|
||||
=item
|
||||
|
||||
computers where you cannot install C<Digest::MD5> (e.g. lack of a C-Compiler)
|
||||
|
||||
=item
|
||||
|
||||
encrypting only small amounts of data (less than one million bytes). I use it to
|
||||
hash passwords.
|
||||
|
||||
=item
|
||||
|
||||
educational purposes
|
||||
|
||||
=back
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Functional style
|
||||
use Digest::MD5 qw(md5 md5_hex md5_base64);
|
||||
|
||||
$hash = md5 $data;
|
||||
$hash = md5_hex $data;
|
||||
$hash = md5_base64 $data;
|
||||
|
||||
|
||||
# OO style
|
||||
use Digest::MD5;
|
||||
|
||||
$ctx = Digest::MD5->new;
|
||||
|
||||
$ctx->add($data);
|
||||
$ctx->addfile(*FILE);
|
||||
|
||||
$digest = $ctx->digest;
|
||||
$digest = $ctx->hexdigest;
|
||||
$digest = $ctx->b64digest;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This modules has the same interface as the much faster C<Digest::MD5>. So you can
|
||||
easily exchange them, e.g.
|
||||
|
||||
BEGIN {
|
||||
eval {
|
||||
require Digest::MD5;
|
||||
import Digest::MD5 'md5_hex'
|
||||
};
|
||||
if ($@) { # ups, no Digest::MD5
|
||||
require Digest::Perl::MD5;
|
||||
import Digest::Perl::MD5 'md5_hex'
|
||||
}
|
||||
}
|
||||
|
||||
If the C<Digest::MD5> module is available it is used and if not you take
|
||||
C<Digest::Perl::MD5>.
|
||||
|
||||
You can also install the Perl part of Digest::MD5 together with Digest::Perl::MD5
|
||||
and use Digest::MD5 as normal, it falls back to Digest::Perl::MD5 if it
|
||||
cannot load its object files.
|
||||
|
||||
For a detailed Documentation see the C<Digest::MD5> module.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
The simplest way to use this library is to import the md5_hex()
|
||||
function (or one of its cousins):
|
||||
|
||||
use Digest::Perl::MD5 'md5_hex';
|
||||
print 'Digest is ', md5_hex('foobarbaz'), "\n";
|
||||
|
||||
The above example would print out the message
|
||||
|
||||
Digest is 6df23dc03f9b54cc38a0fc1483df6e21
|
||||
|
||||
provided that the implementation is working correctly. The same
|
||||
checksum can also be calculated in OO style:
|
||||
|
||||
use Digest::MD5;
|
||||
|
||||
$md5 = Digest::MD5->new;
|
||||
$md5->add('foo', 'bar');
|
||||
$md5->add('baz');
|
||||
$digest = $md5->hexdigest;
|
||||
|
||||
print "Digest is $digest\n";
|
||||
|
||||
The digest methods are destructive. That means you can only call them
|
||||
once and the $md5 objects is reset after use. You can make a copy with clone:
|
||||
|
||||
$md5->clone->hexdigest
|
||||
|
||||
=head1 LIMITATIONS
|
||||
|
||||
This implementation of the MD5 algorithm has some limitations:
|
||||
|
||||
=over 4
|
||||
|
||||
=item
|
||||
|
||||
It's slow, very slow. I've done my very best but Digest::MD5 is still about 100 times faster.
|
||||
You can only encrypt Data up to one million bytes in an acceptable time. But it's very usefull
|
||||
for encrypting small amounts of data like passwords.
|
||||
|
||||
=item
|
||||
|
||||
You can only encrypt up to 2^32 bits = 512 MB on 32bit archs. But You should
|
||||
use C<Digest::MD5> for those amounts of data anyway.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Digest::MD5>
|
||||
|
||||
L<md5(1)>
|
||||
|
||||
RFC 1321
|
||||
|
||||
tools/md5: a small BSD compatible md5 tool written in pure perl.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
Copyright 2000 Christian Lackas, Imperia Software Solutions
|
||||
Copyright 1998-1999 Gisle Aas.
|
||||
Copyright 1995-1996 Neil Winton.
|
||||
Copyright 1991-1992 RSA Data Security, Inc.
|
||||
|
||||
The MD5 algorithm is defined in RFC 1321. The basic C code
|
||||
implementing the algorithm is derived from that in the RFC and is
|
||||
covered by the following copyright:
|
||||
|
||||
=over 4
|
||||
|
||||
=item
|
||||
|
||||
Copyright (C) 1991-1992, RSA Data Security, Inc. Created 1991. All
|
||||
rights reserved.
|
||||
|
||||
License to copy and use this software is granted provided that it
|
||||
is identified as the "RSA Data Security, Inc. MD5 Message-Digest
|
||||
Algorithm" in all material mentioning or referencing this software
|
||||
or this function.
|
||||
|
||||
License is also granted to make and use derivative works provided
|
||||
that such works are identified as "derived from the RSA Data
|
||||
Security, Inc. MD5 Message-Digest Algorithm" in all material
|
||||
mentioning or referencing the derived work.
|
||||
|
||||
RSA Data Security, Inc. makes no representations concerning either
|
||||
the merchantability of this software or the suitability of this
|
||||
software for any particular purpose. It is provided "as is"
|
||||
without express or implied warranty of any kind.
|
||||
|
||||
These notices must be retained in any copies of any part of this
|
||||
documentation and/or software.
|
||||
|
||||
=back
|
||||
|
||||
This copyright does not prohibit distribution of any version of Perl
|
||||
containing this extension under the terms of the GNU or Artistic
|
||||
licenses.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
The original MD5 interface was written by Neil Winton
|
||||
(<N.Winton (at) axion.bt.co.uk>).
|
||||
|
||||
C<Digest::MD5> was made by Gisle Aas <gisle (at) aas.no> (I took his Interface
|
||||
and part of the documentation).
|
||||
|
||||
Thanks to Guido Flohr for his 'use integer'-hint.
|
||||
|
||||
This release was made by Christian Lackas <delta (at) lackas.net>.
|
||||
|
||||
=cut
|
||||
175
site/glist/lib/GT/MD5/Crypt.pm
Normal file
175
site/glist/lib/GT/MD5/Crypt.pm
Normal file
@@ -0,0 +1,175 @@
|
||||
# GT::MD5::Crypt - adapted from CPAN Crypt::PasswdMD5 for use in the
|
||||
# Gossamer Thread module library. gt_md5_crypt was added which uses
|
||||
# "$GT$" as the magic string instead of the unix "$1$" or apache "$apr1$"
|
||||
#
|
||||
# Crypt::PasswdMD5: Module to provide an interoperable crypt()
|
||||
# function for modern Unix O/S. This is based on the code for
|
||||
#
|
||||
# /usr/src/libcrypt/crypt.c
|
||||
#
|
||||
# on a FreeBSD 2.2.5-RELEASE system, which included the following
|
||||
# notice.
|
||||
#
|
||||
# ----------------------------------------------------------------------------
|
||||
# "THE BEER-WARE LICENSE" (Revision 42):
|
||||
# <phk@login.dknet.dk> wrote this file. As long as you retain this notice you
|
||||
# can do whatever you want with this stuff. If we meet some day, and you think
|
||||
# this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp
|
||||
# ----------------------------------------------------------------------------
|
||||
#
|
||||
# 19980710 lem@cantv.net: Initial release
|
||||
# 19990402 bryan@eai.com: Added apache_md5_crypt to create a valid hash
|
||||
# for use in .htpasswd files
|
||||
# 20001006 wrowe@lnd.com: Requested apache_md5_crypt to be
|
||||
# exported by default.
|
||||
#
|
||||
################
|
||||
|
||||
package GT::MD5::Crypt;
|
||||
$VERSION='1.1';
|
||||
require 5.000;
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(unix_md5_crypt apache_md5_crypt gt_md5_crypt);
|
||||
|
||||
|
||||
$Magic = '$1$'; # Magic string
|
||||
$itoa64 = "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
|
||||
|
||||
local $^W;
|
||||
|
||||
use GT::MD5;
|
||||
|
||||
sub to64 {
|
||||
my ($v, $n) = @_;
|
||||
my $ret = '';
|
||||
while (--$n >= 0) {
|
||||
$ret .= substr($itoa64, $v & 0x3f, 1);
|
||||
$v >>= 6;
|
||||
}
|
||||
$ret;
|
||||
}
|
||||
|
||||
sub apache_md5_crypt {
|
||||
# change the Magic string to match the one used by Apache
|
||||
local $Magic = '$apr1$';
|
||||
|
||||
unix_md5_crypt(@_);
|
||||
}
|
||||
|
||||
sub gt_md5_crypt {
|
||||
# change the Magic string to put our signature in the password
|
||||
local $Magic = '$GT$';
|
||||
|
||||
unix_md5_crypt(@_);
|
||||
}
|
||||
|
||||
sub unix_md5_crypt {
|
||||
my($pw, $salt) = @_;
|
||||
my $passwd;
|
||||
|
||||
$salt =~ s/^\Q$Magic//; # Take care of the magic string if
|
||||
# if present.
|
||||
|
||||
$salt =~ s/^(.*)\$.*$/$1/; # Salt can have up to 8 chars...
|
||||
$salt = substr($salt, 0, 8);
|
||||
|
||||
$ctx = new GT::MD5; # Here we start the calculation
|
||||
$ctx->add($pw); # Original password...
|
||||
$ctx->add($Magic); # ...our magic string...
|
||||
$ctx->add($salt); # ...the salt...
|
||||
|
||||
my ($final) = new GT::MD5;
|
||||
$final->add($pw);
|
||||
$final->add($salt);
|
||||
$final->add($pw);
|
||||
$final = $final->digest;
|
||||
|
||||
for ($pl = length($pw); $pl > 0; $pl -= 16) {
|
||||
$ctx->add(substr($final, 0, $pl > 16 ? 16 : $pl));
|
||||
}
|
||||
|
||||
# Now the 'weird' xform
|
||||
|
||||
for ($i = length($pw); $i; $i >>= 1) {
|
||||
if ($i & 1) { $ctx->add(pack("C", 0)); }
|
||||
# This comes from the original version,
|
||||
# where a memset() is done to $final
|
||||
# before this loop.
|
||||
else { $ctx->add(substr($pw, 0, 1)); }
|
||||
}
|
||||
|
||||
$final = $ctx->digest;
|
||||
# The following is supposed to make
|
||||
# things run slower. In perl, perhaps
|
||||
# it'll be *really* slow!
|
||||
|
||||
for ($i = 0; $i < 1000; $i++) {
|
||||
$ctx1 = new GT::MD5;
|
||||
if ($i & 1) { $ctx1->add($pw); }
|
||||
else { $ctx1->add(substr($final, 0, 16)); }
|
||||
if ($i % 3) { $ctx1->add($salt); }
|
||||
if ($i % 7) { $ctx1->add($pw); }
|
||||
if ($i & 1) { $ctx1->add(substr($final, 0, 16)); }
|
||||
else { $ctx1->add($pw); }
|
||||
$final = $ctx1->digest;
|
||||
}
|
||||
|
||||
# Final xform
|
||||
|
||||
$passwd = '';
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 0, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 6, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 12, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 1, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 7, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 13, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 2, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 8, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 14, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 3, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 9, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 15, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 4, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 10, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 5, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", substr($final, 11, 1))), 2);
|
||||
|
||||
$final = '';
|
||||
$Magic . $salt . '$' . $passwd;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
unix_md5_crypt - Provides interoperable MD5-based crypt() function
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::MD5::Crypt;
|
||||
|
||||
$cryptedpassword = unix_md5_crypt($password, $salt);
|
||||
|
||||
$valid = $cryptedpassword eq unix_md5_crypt($password, $cryptedpassword);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
the C<unix_md5_crypt()> provides a crypt()-compatible interface to the
|
||||
rather new MD5-based crypt() function found in modern operating systems.
|
||||
It's based on the implementation found on FreeBSD 2.2.[56]-RELEASE and
|
||||
contains the following license in it:
|
||||
|
||||
"THE BEER-WARE LICENSE" (Revision 42):
|
||||
<phk@login.dknet.dk> wrote this file. As long as you retain this notice you
|
||||
can do whatever you want with this stuff. If we meet some day, and you think
|
||||
this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp
|
||||
|
||||
C<apache_md5_crypt()> provides a function compatible with Apache's
|
||||
C<.htpasswd> files. This was contributed by Bryan Hart <bryan@eai.com>.
|
||||
As suggested by William A. Rowe, Jr. <wrowe@lnd.com>, it is
|
||||
exported by default.
|
||||
|
||||
=cut
|
||||
425
site/glist/lib/GT/MIMETypes.pm
Normal file
425
site/glist/lib/GT/MIMETypes.pm
Normal file
@@ -0,0 +1,425 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::MIMETypes
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: MIMETypes.pm,v 1.24 2005/04/02 08:08:46 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Provides methods to guess mime types.
|
||||
#
|
||||
|
||||
package GT::MIMETypes;
|
||||
# ===================================================================
|
||||
use strict;
|
||||
use vars qw/%CONTENT_EXT %MIME_EXT %MIME_TYPE/;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$COMPILE{guess_type} = __LINE__ . <<'END_OF_SUB';
|
||||
sub guess_type {
|
||||
# -------------------------------------------------------------------
|
||||
# Makes it's best guess based on input. Returns application/octet-stream
|
||||
# on failure to guess.
|
||||
# Possible arguments
|
||||
#{
|
||||
# filename => name of the file
|
||||
# filepath => full path to the file
|
||||
#}
|
||||
# No arguments are required but you will get application/octet-stream
|
||||
# with no arguments.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my $msg = shift;
|
||||
|
||||
if (!ref $msg) {
|
||||
defined(%CONTENT_EXT) or content_ext();
|
||||
if ($msg =~ /\.([^.]+)$/ and exists $CONTENT_EXT{lc $1}) {
|
||||
return $CONTENT_EXT{lc $1};
|
||||
}
|
||||
else {
|
||||
return 'application/octet-stream';
|
||||
}
|
||||
}
|
||||
|
||||
# If we have a filename with an extension use that
|
||||
if ($msg->{filename} or $msg->{filepath}) {
|
||||
my $f;
|
||||
if ($msg->{filename}) {
|
||||
$f = $msg->{filename};
|
||||
}
|
||||
else {
|
||||
$f = $msg->{filepath};
|
||||
}
|
||||
defined(%CONTENT_EXT) or content_ext();
|
||||
if ($f =~ /\.([^.]+)$/ and exists $CONTENT_EXT{lc $1}) {
|
||||
return $CONTENT_EXT{lc $1};
|
||||
}
|
||||
}
|
||||
return 'application/octet-stream';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{guess_image} = __LINE__ . <<'END_OF_SUB';
|
||||
sub guess_image {
|
||||
# -------------------------------------------------------------------
|
||||
# Makes it's best guess based on input. Returns unknown.gif
|
||||
# on failure to guess.
|
||||
# Possible arguments
|
||||
#{
|
||||
# filename => name of the file
|
||||
# filepath => full path to the file
|
||||
# type => mime type
|
||||
#}
|
||||
# No arguments are required but you will get unknown.gif
|
||||
# with no arguments.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my $msg = shift;
|
||||
my $image;
|
||||
|
||||
if (!ref $msg) {
|
||||
if ($msg =~ /\.([^.]+)$/) {
|
||||
defined(%MIME_EXT) or mime_ext();
|
||||
return $MIME_EXT{lc $1} || 'unknown.gif';
|
||||
}
|
||||
else {
|
||||
return 'unknown.gif';
|
||||
}
|
||||
}
|
||||
if ($msg->{filepath} and -d $msg->{filepath}) {
|
||||
return 'folder.gif';
|
||||
}
|
||||
|
||||
# If we have a filename with an extension use that
|
||||
my $f;
|
||||
if ($msg->{filename} or $msg->{filepath}) {
|
||||
if ($msg->{filename}) {
|
||||
$f = $msg->{filename};
|
||||
}
|
||||
else {
|
||||
$f = $msg->{filepath};
|
||||
}
|
||||
defined(%MIME_EXT) or mime_ext();
|
||||
if ($f =~ /\.([^.]+)$/ and exists $MIME_EXT{lc $1}) {
|
||||
return $MIME_EXT{lc $1};
|
||||
}
|
||||
}
|
||||
|
||||
# If a content type was passed in see if we know anything about it
|
||||
defined(%MIME_TYPE) or mime_type();
|
||||
if (exists $MIME_TYPE{$msg->{type} || $msg->{mime_type}}) {
|
||||
return $MIME_TYPE{$msg->{type} || $msg->{mime_type}};
|
||||
}
|
||||
|
||||
# No luck so far, resort to other means
|
||||
elsif ($msg->{filepath} and -B $msg->{filepath}) {
|
||||
return 'binary.gif';
|
||||
}
|
||||
elsif ($f and lc($f) =~ /readme/) {
|
||||
return 'readme.gif';
|
||||
}
|
||||
elsif ($msg->{filepath} and -T _) {
|
||||
return 'txt.gif';
|
||||
}
|
||||
|
||||
# Oops nothing
|
||||
return 'unknown.gif';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{mime_ext} = __LINE__ . <<'END_OF_SUB';
|
||||
sub mime_ext {
|
||||
# -------------------------------------------------------------------
|
||||
# Map file extension to image file
|
||||
#
|
||||
%MIME_EXT = (
|
||||
css => 'html.gif',
|
||||
htm => 'html.gif',
|
||||
html => 'html.gif',
|
||||
shtm => 'html.gif',
|
||||
shtml => 'html.gif',
|
||||
c => 'source.gif',
|
||||
cc => 'source.gif',
|
||||
'c++' => 'source.gif',
|
||||
cpp => 'source.gif',
|
||||
h => 'source.gif',
|
||||
pl => 'source.gif',
|
||||
pm => 'source.gif',
|
||||
cgi => 'source.gif',
|
||||
txt => 'txt.gif',
|
||||
text => 'txt.gif',
|
||||
eml => 'email.gif',
|
||||
email => 'email.gif',
|
||||
mime => 'email.gif',
|
||||
java => 'source.gif',
|
||||
el => 'source.gif',
|
||||
pdf => 'pdf.gif',
|
||||
dvi => 'dvi.gif',
|
||||
eds => 'postscript.gif',
|
||||
ai => 'postscript.gif',
|
||||
ps => 'postscript.gif',
|
||||
tex => 'tex.gif',
|
||||
texinfo => 'tex.gif',
|
||||
tar => 'tar.gif',
|
||||
ustar => 'tar.gif',
|
||||
tgz => 'tgz.gif',
|
||||
gz => 'tgz.gif',
|
||||
snd => 'sound.gif',
|
||||
au => 'sound.gif',
|
||||
aifc => 'sound.gif',
|
||||
aif => 'sound.gif',
|
||||
aiff => 'sound.gif',
|
||||
wav => 'sound.gif',
|
||||
mp3 => 'sound.gif',
|
||||
bmp => 'image.gif',
|
||||
gif => 'image.gif',
|
||||
ief => 'image.gif',
|
||||
jfif => 'image.gif',
|
||||
'jfif-tbnl' => 'image.gif',
|
||||
jpe => 'image.gif',
|
||||
jpg => 'image.gif',
|
||||
jpeg => 'image.gif',
|
||||
tif => 'image.gif',
|
||||
tiff => 'image.gif',
|
||||
fpx => 'image.gif',
|
||||
fpix => 'image.gif',
|
||||
ras => 'image.gif',
|
||||
pnm => 'image.gif',
|
||||
pbn => 'image.gif',
|
||||
pgm => 'image.gif',
|
||||
ppm => 'image.gif',
|
||||
rgb => 'image.gif',
|
||||
xbm => 'image.gif',
|
||||
xpm => 'image.gif',
|
||||
xwd => 'image.gif',
|
||||
png => 'image.gif',
|
||||
mpg => 'video.gif',
|
||||
mpe => 'video.gif',
|
||||
mpeg => 'video.gif',
|
||||
mov => 'video.gif',
|
||||
qt => 'video.gif',
|
||||
avi => 'video.gif',
|
||||
asf => 'video.gif',
|
||||
movie => 'video.gif',
|
||||
mv => 'video.gif',
|
||||
wmv => 'wvideo.gif',
|
||||
wma => 'wvideo.gif',
|
||||
sh => 'shellscript.gif',
|
||||
rpm => 'rpm.gif',
|
||||
ttf => 'font_true.gif',
|
||||
doc => 'doc.gif',
|
||||
xls => 'excel.gif',
|
||||
ppt => 'ppt.gif',
|
||||
zip => 'zip.gif'
|
||||
) unless keys %MIME_EXT;
|
||||
|
||||
%MIME_EXT;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{content_ext} = __LINE__ . <<'END_OF_SUB';
|
||||
sub content_ext {
|
||||
# -------------------------------------------------------------------
|
||||
# To guess the content-type for files by extension
|
||||
#
|
||||
%CONTENT_EXT = (
|
||||
doc => 'application/msword',
|
||||
ppt => 'application/mspowerpoint',
|
||||
xls => 'application/msexcel',
|
||||
oda => 'application/oda',
|
||||
pdf => 'application/pdf',
|
||||
eds => 'application/postscript',
|
||||
ai => 'application/postscript',
|
||||
ps => 'application/postscript',
|
||||
rtf => 'application/rtf',
|
||||
dvi => 'application/x-dvi',
|
||||
hdf => 'application/x-hdf',
|
||||
latex => 'application/x-latex',
|
||||
nc => 'application/x-netcdf',
|
||||
cdf => 'application/x-netcdf',
|
||||
tex => 'application/x-tex',
|
||||
texinfo => 'application/x-texinfo',
|
||||
texi => 'application/x-texinfo',
|
||||
t => 'application/x-troff',
|
||||
tr => 'application/x-troff',
|
||||
roff => 'application/x-troff',
|
||||
man => 'application/x-troff-man',
|
||||
me => 'application/x-troff-me',
|
||||
ms => 'application/x-troff-ms',
|
||||
src => 'application/x-wais-source',
|
||||
wsrc => 'application/x-wais-source',
|
||||
zip => 'application/zip',
|
||||
bcpio => 'application/x-bcpio',
|
||||
cpio => 'application/x-cpio',
|
||||
gtar => 'application/x-gtar',
|
||||
sh => 'application/x-shar',
|
||||
shar => 'application/x-shar',
|
||||
sv4cpio => 'application/x-sv4cpio',
|
||||
sv4crc => 'application/x-sv4crc',
|
||||
tar => 'application/x-tar',
|
||||
ustar => 'application/x-ustar',
|
||||
snd => 'audio/basic',
|
||||
au => 'audio/basic',
|
||||
aifc => 'audio/x-aiff',
|
||||
aif => 'audio/x-aiff',
|
||||
aiff => 'audio/x-aiff',
|
||||
wav => 'audio/x-wav',
|
||||
mp3 => 'audio/mpeg',
|
||||
bmp => 'image/bmp',
|
||||
gif => 'image/gif',
|
||||
ief => 'image/ief',
|
||||
jfif => 'image/jpeg',
|
||||
'jfif-tbnl' => 'image/jpeg',
|
||||
jpe => 'image/jpeg',
|
||||
jpg => 'image/jpeg',
|
||||
jpeg => 'image/jpeg',
|
||||
tif => 'image/tiff',
|
||||
tiff => 'image/tiff',
|
||||
fpx => 'image/vnd.fpx',
|
||||
fpix => 'image/vnd.fpx',
|
||||
ras => 'image/x-cmu-rast',
|
||||
pnm => 'image/x-portable-anymap',
|
||||
pbn => 'image/x-portable-bitmap',
|
||||
pgm => 'image/x-portable-graymap',
|
||||
ppm => 'image/x-portable-pixmap',
|
||||
rgb => 'image/x-rgb',
|
||||
xbm => 'image/x-xbitmap',
|
||||
xpm => 'image/x-xbitmap',
|
||||
xwd => 'image/x-xwindowdump',
|
||||
png => 'image/png',
|
||||
css => 'text/css',
|
||||
htm => 'text/html',
|
||||
html => 'text/html',
|
||||
shtml => 'text/html',
|
||||
text => 'text/plain',
|
||||
c => 'text/plain',
|
||||
cc => 'text/plain',
|
||||
'c++' => 'text/plain',
|
||||
h => 'text/plain',
|
||||
pl => 'text/plain',
|
||||
pm => 'text/plain',
|
||||
cgi => 'text/plain',
|
||||
txt => 'text/plain',
|
||||
java => 'text/plain',
|
||||
el => 'text/plain',
|
||||
tsv => 'text/tab-separated-values',
|
||||
etx => 'text/x-setext',
|
||||
mpg => 'video/mpeg',
|
||||
mpe => 'video/mpeg',
|
||||
mpeg => 'video/mpeg',
|
||||
mov => 'video/quicktime',
|
||||
qt => 'video/quicktime',
|
||||
avi => 'application/x-troff-msvideo',
|
||||
asf => 'video/x-ms-asf',
|
||||
movie => 'video/x-sgi-movie',
|
||||
mv => 'video/x-sgi-movie',
|
||||
wmv => 'video/x-ms-wmv',
|
||||
wma => 'video/x-ms-wma',
|
||||
mime => 'message/rfc822',
|
||||
eml => 'message/rfc822',
|
||||
xml => 'application/xml'
|
||||
) unless keys %CONTENT_EXT;
|
||||
|
||||
%CONTENT_EXT;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{mime_type} = __LINE__ . <<'END_OF_SUB';
|
||||
sub mime_type {
|
||||
# -------------------------------------------------------------------
|
||||
# Map content-type to image file
|
||||
#
|
||||
%MIME_TYPE = (
|
||||
'text/css' => 'html.gif',
|
||||
'text/html' => 'html.gif',
|
||||
'text/plain' => 'txt.gif',
|
||||
'application/pdf' => 'pdf.gif',
|
||||
'application/dvi' => 'dvi.gif',
|
||||
'application/postscript' => 'postscript.gif',
|
||||
'application/x-tex' => 'tex.gif',
|
||||
'application/x-texinfo' => 'tex.gif',
|
||||
'application/gtar' => 'tar.gif',
|
||||
'application/x-tar' => 'tar.gif',
|
||||
'application/x-ustar' => 'tar.gif',
|
||||
'application/zip' => 'zip.gif',
|
||||
'application/mspowerpoint' => 'ppt.gif',
|
||||
'application/msword' => 'word.gif',
|
||||
'application/msexcel' => 'excel.gif',
|
||||
'message/rfc822' => 'email.gif',
|
||||
'message/external-body' => 'email.gif',
|
||||
'multipart/alternative' => 'email.gif',
|
||||
'multipart/appledouble' => 'email.gif',
|
||||
'multipart/digest' => 'email.gif',
|
||||
'multipart/mixed' => 'email.gif',
|
||||
'multipart/voice-message' => 'sound.gif',
|
||||
'audio/basic' => 'sound.gif',
|
||||
'audio/x-aiff' => 'sound.gif',
|
||||
'audio/x-wav' => 'sound.gif',
|
||||
'audio/mpeg' => 'sound.gif',
|
||||
'image/gif' => 'image.gif',
|
||||
'image/ief' => 'image.gif',
|
||||
'image/jpeg' => 'image.gif',
|
||||
'image/tiff' => 'image.gif',
|
||||
'image/vnd.fpx' => 'image.gif',
|
||||
'image/x-cmu-rast' => 'image.gif',
|
||||
'image/x-portable-anymap' => 'image.gif',
|
||||
'image/x-portable-bitmap' => 'image.gif',
|
||||
'image/x-portable-graymap' => 'image.gif',
|
||||
'image/x-portable-pixmap' => 'image.gif',
|
||||
'image/x-rgb' => 'image.gif',
|
||||
'image/x-xbitmap' => 'image.gif',
|
||||
'image/x-xwindowdump' => 'image.gif',
|
||||
'image/png' => 'image.gif',
|
||||
'image/bmp' => 'image.gif',
|
||||
'video/mpeg' => 'video.gif',
|
||||
'video/quicktime' => 'video.gif',
|
||||
'video/x-ms-asf' => 'video.gif',
|
||||
'application/x-troff-msvideo' => 'video.gif',
|
||||
'video/x-sgi-movie' => 'video.gif',
|
||||
'video/x-ms-wmv' => 'wvideo.gif',
|
||||
'video/x-ms-wma' => 'wvideo.gif',
|
||||
) unless keys %MIME_TYPE;
|
||||
|
||||
%MIME_TYPE;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::MIMETypes - Methods to guess MIME Types of files.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::MIMETypes;
|
||||
|
||||
my $file = '/foo/bar/abc.doc';
|
||||
my $mime = GT::MIMETypes::guess_type($file);
|
||||
my $img = GT::MIMETypes::guess_image($file);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::MIMETypes provides two simple methods C<guess_type> and C<guess_image>.
|
||||
They take either a filename or a hash reference.
|
||||
|
||||
C<guess_type> returns the MIME type of the file, and guess_image returns an
|
||||
image name that represents the file.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: MIMETypes.pm,v 1.24 2005/04/02 08:08:46 jagerman Exp $
|
||||
|
||||
=cut
|
||||
|
||||
979
site/glist/lib/GT/Mail.pm
Normal file
979
site/glist/lib/GT/Mail.pm
Normal file
@@ -0,0 +1,979 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Mail.pm,v 1.70 2004/11/04 20:23:09 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface to sending, creating, and
|
||||
# parsing emails.
|
||||
#
|
||||
|
||||
package GT::Mail;
|
||||
# ==================================================================
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw/$DEBUG @ISA $ERRORS $CRLF @HEADER $VERSION %CONTENT $CONTENT/;
|
||||
|
||||
# Internal modules
|
||||
use GT::Base;
|
||||
use GT::MIMETypes;
|
||||
use GT::Mail::Encoder;
|
||||
use GT::Mail::Parts;
|
||||
use GT::Mail::Send;
|
||||
|
||||
# Damn warnings
|
||||
$GT::Mail::error = '' if 0;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.70 $ =~ /(\d+)\.(\d+)/;
|
||||
@ISA = qw(GT::Base);
|
||||
$DEBUG = 0;
|
||||
$CRLF = "\012";
|
||||
$| = 1;
|
||||
|
||||
$ERRORS = {
|
||||
PARSE => "Unable to parse message: %s",
|
||||
SEND => "Unable to send email: %s",
|
||||
NOIO => "No input to parse!",
|
||||
NOBOUND => "Multipart message has not boundary",
|
||||
NOEMAIL => "No message head was specified",
|
||||
NOBODY => "No body was found in message",
|
||||
};
|
||||
|
||||
# To guess the content-type for files by extension
|
||||
%CONTENT = GT::MIMETypes->content_ext;
|
||||
$CONTENT = \%CONTENT; # Other programs still access this as a hash reference.
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
# CLASS->new(
|
||||
# debug => 1,
|
||||
# to => 'user1@domain',
|
||||
# from => 'user2@domain',
|
||||
# subject => 'Hi Alex',
|
||||
# type => 'multipart/mixed',
|
||||
# ...
|
||||
# );
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returm a new mail object. If you pass in the header information the new
|
||||
# mail's header will be initialized with those fields.
|
||||
my $this = shift;
|
||||
my $self;
|
||||
|
||||
# Calling this as an object method does not create a new object.
|
||||
if (ref $this) { $self = $this }
|
||||
else { $self = bless {}, $this }
|
||||
|
||||
$self->args(@_) if @_;
|
||||
exists($self->{_debug}) or $self->{_debug} = $DEBUG;
|
||||
|
||||
$self->debug("Created new object ($self).") if ($self->{_debug} > 1);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub args {
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
elsif (ref $_[0] eq 'HASH') { $opt = shift }
|
||||
|
||||
$self->{_debug} = exists($opt->{debug}) ? delete $opt->{debug} : $DEBUG;
|
||||
$self->{smtp} = delete $opt->{smtp} || '';
|
||||
$self->{smtp_port} = delete $opt->{smtp_port} || '';
|
||||
$self->{smtp_ssl} = delete $opt->{smtp_ssl} || '';
|
||||
$self->{smtp_user} = delete $opt->{smtp_user} || '';
|
||||
$self->{smtp_pass} = delete $opt->{smtp_pass} || '';
|
||||
$self->{pbs_user} = delete $opt->{pbs_user} || '';
|
||||
$self->{pbs_pass} = delete $opt->{pbs_pass} || '';
|
||||
$self->{pbs_host} = delete $opt->{pbs_host} || '';
|
||||
$self->{pbs_port} = delete $opt->{pbs_port} || '';
|
||||
$self->{pbs_auth_mode} = delete $opt->{pbs_auth_mode} || 'PASS';
|
||||
$self->{pbs_ssl} = delete $opt->{pbs_ssl} || '';
|
||||
$self->{flags} = delete $opt->{flags} || '';
|
||||
$self->{sendmail} = delete $opt->{sendmail} || '';
|
||||
$self->{header_charset} = delete $opt->{header_charset} || 'ISO-8859-1';
|
||||
|
||||
if (keys %{$opt} and !$self->{head}) {
|
||||
$self->{head} = $self->new_part($opt);
|
||||
}
|
||||
elsif (keys %{$opt} and $self->{head}) {
|
||||
$self->header($self->{head}, $opt);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->parse(\*FH);
|
||||
# ------------------
|
||||
# $obj->parse('/path/to/file');
|
||||
# -----------------------------
|
||||
# $obj->parse($SCALAR_REF -or- $SCALAR);
|
||||
# --------------------------------------
|
||||
# Takes either a path to a file for a file handle. Returns 1 on success and
|
||||
# undef on failure. If a filehandle is specified this will attempt to seek back
|
||||
# to 0, 0 on exit.
|
||||
#
|
||||
my ($self, $io) = @_;
|
||||
|
||||
# Require our parser
|
||||
require GT::Mail::Parse;
|
||||
|
||||
# Get a new parser object
|
||||
$self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
|
||||
$self->_set_io($io) or return;
|
||||
$self->debug("\n\t--------------> Parsing email.") if $self->{_debug};
|
||||
$self->{head} = $self->{parser}->parse or return $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
|
||||
$self->debug("\n\t<-------------- Email parsed.") if $self->{_debug};
|
||||
return $self->{head};
|
||||
}
|
||||
|
||||
sub parse_head {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->parse_head (\*FH);
|
||||
# ------------------------
|
||||
# $obj->parse_head ('/path/to/file');
|
||||
# -----------------------------------
|
||||
# This method does the exact same thing as the parse method except it will only
|
||||
# parse the header of the file or filehandle. This is a nice way to save
|
||||
# overhead when all you need is the header parsed and do not care about the
|
||||
# rest of the email.
|
||||
# NOTE: The top level part is returned from this and not stored.
|
||||
#
|
||||
my ($self, $io) = @_;
|
||||
|
||||
# Require our parser
|
||||
require GT::Mail::Parse;
|
||||
|
||||
# Get a new parser object
|
||||
$self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
|
||||
$self->_set_io($io) or return;
|
||||
$self->debug("\n\t--------------> Parsing head") if $self->{_debug};
|
||||
my $part = $self->{parser}->parse_head or $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
|
||||
$self->debug("\n\t<-------------- Head parsed") if $self->{_debug};
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub parser {
|
||||
# -----------------------------------------------------------------------------
|
||||
# my $parser = $mail->parser;
|
||||
# ---------------------------
|
||||
# $mail->parser($parser);
|
||||
# -----------------------
|
||||
# Set or get method for the parser object that is used when you call
|
||||
# parse_head() or parse(). This object must conform to the method parse and
|
||||
# parse_head. If no object is passed to this method a GT::Mail::Parse object is
|
||||
# created when needed.
|
||||
#
|
||||
my ($self, $parser) = @_;
|
||||
if (defined $parser) {
|
||||
$self->{parser} = $parser;
|
||||
$self->{head} = $parser->top_part;
|
||||
}
|
||||
return $self->{parser};
|
||||
}
|
||||
|
||||
sub send {
|
||||
# -----------------------------------------------------------------------------
|
||||
# CLASS->send(smtp => 'host.com', smtp_ssl => 1, smtp_port => 4650, To => '...', ...);
|
||||
# ------------------------------------------------------------------------------------
|
||||
# $obj->send(smtp => 'host.com', smtp_ssl => 1, smtp_port => 4560);
|
||||
# -----------------------------------------------------------------
|
||||
# $obj->send(sendmail => '/path/to/sendmail', flags => $additional_flags);
|
||||
# ------------------------------------------------------------------------
|
||||
# Sends the current email through either smtp or sendmail. The sendmail send
|
||||
# takes additional arguments as flags that get passed to sendmail (e.g.
|
||||
# "-t -oi -oem"). If these flags are specified they override the default which
|
||||
# is "-t -oi -oem". The smtp send also looks for smtp_port and smtp_ssl, but
|
||||
# these are optional and default to port 110, non-encrypted. Note that using
|
||||
# an SSL encrypted connection requires Net::SSLeay. Also not that attempting
|
||||
# to establish an SSL connection when Net::SSLeay (at least version 1.06) is
|
||||
# not available will cause a fatal error to occur.
|
||||
#
|
||||
my $self = shift;
|
||||
unless (ref $self) {
|
||||
$self = $self->new(@_);
|
||||
}
|
||||
elsif (@_) {
|
||||
$self->args(@_);
|
||||
}
|
||||
$self->{head} or return $self->error("NOEMAIL", "FATAL");
|
||||
|
||||
# Set a Message-Id if we don't have one set already
|
||||
my $host = $self->{smtp} && $self->{smtp} ne 'localhost' && $self->{smtp} !~ /^\s*127\.\d+\.\d+\.\d+\s*$/ ? $self->{smtp} : $ENV{SERVER_NAME} && $ENV{SERVER_NAME} ne 'localhost' ? $ENV{SERVER_NAME} : '';
|
||||
if (not defined $self->{head}->get('Message-Id') and $host) {
|
||||
$self->{head}->set('Message-Id' => '<' . time . '.' . $$ . rand(10000) . '@' . $host . '>');
|
||||
}
|
||||
|
||||
if ($self->{sendmail} and -e $self->{sendmail} and -x _) {
|
||||
$self->debug("\n\t--------------> Sending email through Sendmail path: ($self->{sendmail})") if $self->{_debug};
|
||||
my @flags = exists($self->{flags}) ? (flags => $self->{flags}) : ();
|
||||
my $return = ($self->parse_address($self->{head}->get('Reply-To') || $self->{head}->get('From')))[1];
|
||||
$self->{head}->set('Return-Path' => "<$return>") unless $self->{head}->get('Return-Path');
|
||||
GT::Mail::Send->sendmail(
|
||||
debug => $self->{_debug},
|
||||
path => $self->{sendmail},
|
||||
mail => $self,
|
||||
@flags
|
||||
) or return $self->error("SEND", "WARN", $GT::Mail::Send::error);
|
||||
$self->debug("\n\t<-------------- Email sent through Sendmail") if $self->{_debug};
|
||||
}
|
||||
elsif ($self->{smtp} and $self->{smtp} =~ /\S/) {
|
||||
# SMTP requires \r\n
|
||||
local $CRLF = "\015\012";
|
||||
local $GT::Mail::Parts::CRLF = "\015\012";
|
||||
local $GT::Mail::Encoder::CRLF = "\015\012";
|
||||
$self->{head}->set(date => $self->date_stamp) unless ($self->{head}->get('date'));
|
||||
$self->debug("\n\t--------------> Sending email through SMTP host: ($self->{smtp}:$self->{smtp_port})") if $self->{_debug};
|
||||
GT::Mail::Send->smtp(
|
||||
debug => $self->{_debug},
|
||||
host => $self->{smtp},
|
||||
port => $self->{smtp_port}, # Optional; GT::Mail::Send will set a default if not present
|
||||
ssl => $self->{smtp_ssl}, # Make sure Net::SSLeay is available if you use this
|
||||
user => $self->{smtp_user}, # Optional; Used for SMTP AUTH (CRAM-MD5, PLAIN, LOGIN)
|
||||
pass => $self->{smtp_pass},
|
||||
pbs_host => $self->{pbs_host}, # Optional; Perform a POP3 login before sending mail
|
||||
pbs_port => $self->{pbs_port},
|
||||
pbs_user => $self->{pbs_user},
|
||||
pbs_pass => $self->{pbs_pass},
|
||||
pbs_auth_mode => $self->{pbs_auth_mode},
|
||||
pbs_ssl => $self->{pbs_ssl},
|
||||
mail => $self
|
||||
) or return $self->error("SEND", "WARN", $GT::Mail::Send::error);
|
||||
$self->debug("\n\t<-------------- Email sent through SMTP") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
return $self->error("BADARGS", "FATAL", '$obj->send (%opts); smtp or sendmail and a head part must exist at this point.');
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub top_part {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->top_part ($part);
|
||||
# -----------------------
|
||||
# This allows you to set the top level part directly.
|
||||
# This is used to produce the email when sending or writing to file.
|
||||
#
|
||||
# my $top = $obj->top_part;
|
||||
# -------------------------
|
||||
# Returns the current top level part.
|
||||
#
|
||||
|
||||
my ($self, $part) = @_;
|
||||
if ($part and ref $part) {
|
||||
$self->{head} = $part;
|
||||
}
|
||||
return $self->{head};
|
||||
}
|
||||
|
||||
sub new_part {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->new_part;
|
||||
# ---------------
|
||||
# $obj->new_part(
|
||||
# to => 'user1@domain',
|
||||
# from => 'user2@domain',
|
||||
# subject => 'Hi Alex',
|
||||
# type => 'multipart/mixed',
|
||||
# ...
|
||||
# );
|
||||
# ---------------------------------
|
||||
# Returns a new part. If arguments a given they are passed to the header method
|
||||
# in the parts module. See the parts module for details.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my $part = new GT::Mail::Parts (debug => $self->{_debug}, header_charset => $self->{header_charset});
|
||||
$self->header($part, @_) if @_;
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub header {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->header(%header);
|
||||
# ----------------------
|
||||
# Mostly private method to set the arguments for the emails header.
|
||||
# This is called by new and new_part.
|
||||
# The options are:
|
||||
#
|
||||
# disposition => Sets the Content-Disposition.
|
||||
# filename => Sets the Content-Disposition to attachment and the
|
||||
# file name to what to specify.
|
||||
# encoding => Sets the Content-Transfer-Encoding (You really
|
||||
# should not set this).
|
||||
# header_charset => The header encoding charset.
|
||||
# type => Sets the Content-Type.
|
||||
# body_data => Sets the top level body data to the in memory string
|
||||
# specified.
|
||||
# msg => Same as body_data.
|
||||
# body_handle => Sets the top level body to the File Handle.
|
||||
# body_path => Sets the top level body path.
|
||||
#
|
||||
|
||||
my $self = shift;
|
||||
my $part = shift;
|
||||
|
||||
my $opt;
|
||||
if (!@_) { return $self->error("BADARGS", "FATAL", '$obj->header(to => \'someone@somedomain\', from => \'someone@somedomain\');') }
|
||||
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
elsif (ref $_[0] and ref $_[0] eq 'HASH') { $opt = shift }
|
||||
else { return $self->error("BADARGS", "FATAL", '$obj->header(to => \'someone@somedomain\', from => \'someone@somedomain\');') }
|
||||
|
||||
for my $tag (keys %{$opt}) {
|
||||
next unless defined $opt->{$tag};
|
||||
my $key = $tag;
|
||||
if ($tag eq 'disposition') { $tag = 'Content-Disposition' }
|
||||
elsif ($tag eq 'filename') { $tag = 'Content-Disposition'; $opt->{$key} = 'attachment; filename="' . $opt->{$key} . '"' }
|
||||
elsif ($tag eq 'encoding') { $tag = 'Content-Transfer-Encoding' }
|
||||
elsif ($tag eq 'type') { $part->mime_type($opt->{$tag}); next }
|
||||
elsif ($tag eq 'body_data') { $part->body_data($opt->{$tag}); next }
|
||||
elsif ($tag eq 'header_charset') { $part->header_charset($opt->{$tag}); next }
|
||||
|
||||
# For Alex :)
|
||||
elsif ($tag eq 'msg') { $part->body_data($opt->{$tag}); next }
|
||||
elsif ($tag eq 'body_handle') { $part->body_handle($opt->{$tag}); next }
|
||||
elsif ($tag eq 'body_path') { $part->body_path($opt->{$tag}); next }
|
||||
$self->debug("Setting ($tag) to ($opt->{$key})") if ($self->{_debug} > 1);
|
||||
$part->set($tag => $opt->{$key});
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub attach {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->attach($mail_object);
|
||||
# ---------------------------
|
||||
# Attaches an rfc/822 to the current email. $mail_object is a GT::Mail object.
|
||||
#
|
||||
# $obj->attach(
|
||||
# disposition => 'inline',
|
||||
# type => 'text/plain',
|
||||
# body_data => 'Hello how are ya'
|
||||
# );
|
||||
# --------------------------------------
|
||||
# Attaches the given data to the email. See header for a list of the options.
|
||||
#
|
||||
my $self = shift;
|
||||
if (!$self->{head}) { return $self->error("NOEMAIL", "FATAL") }
|
||||
|
||||
my $attach;
|
||||
if (ref $_[0] eq ref $self) {
|
||||
$self->debug("Adding rfc/822 email attachment.") if $self->{_debug};
|
||||
push @{$self->{mail_attach}}, @_;
|
||||
return 1;
|
||||
}
|
||||
elsif (ref $_[0] eq 'GT::Mail::Parts') {
|
||||
$attach = $_[0];
|
||||
}
|
||||
else {
|
||||
$attach = $self->new_part(@_);
|
||||
}
|
||||
$self->debug("Adding attachment.") if $self->{_debug};
|
||||
|
||||
# Guess the content-type if none was specified
|
||||
if (!$attach->mime_type and $attach->body_path) {
|
||||
(my $ext = $attach->body_path) =~ s/^.*\.//;
|
||||
$attach->mime_type(exists($CONTENT{$ext}) ? $CONTENT{$ext} : 'application/octet-stream');
|
||||
}
|
||||
$self->{head}->parts($attach);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub to_string { shift->as_string }
|
||||
|
||||
sub as_string {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->as_string;
|
||||
# ----------------
|
||||
# Returns the entire email as a sting. The parts will be encoded for sending at
|
||||
# this point.
|
||||
# NOTE: Not a recommended method for emails with binary attachments.
|
||||
my $self = shift;
|
||||
my $ret = '';
|
||||
$self->build_email(sub { $ret .= $_[0] });
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub build_email {
|
||||
my ($self, $code) = @_;
|
||||
$GT::Mail::Encoder::CRLF = $CRLF;
|
||||
# Need a code ref to continue.
|
||||
ref($code) eq 'CODE' or return $self->error("BADARGS", "FATAL", '$obj->build_email(sub {do something });');
|
||||
|
||||
$self->debug("\n\t--------------> Creating email") if $self->{_debug};
|
||||
# Need the head to contiue
|
||||
$self->{head} or return $self->error("NOEMAIL", "FATAL");
|
||||
unless ($self->{head}->get('MIME-Version')) { $self->{head}->set('MIME-Version', '1.0') }
|
||||
|
||||
my $io = $self->_get_body_handle($self->{head});
|
||||
my $bound = $self->{head}->multipart_boundary;
|
||||
|
||||
# If the message has parts
|
||||
|
||||
if (@{$self->{head}->{parts}} > 0) {
|
||||
$self->debug("Creating multipart email.") if $self->{_debug};
|
||||
$self->_build_multipart_head($code, $io);
|
||||
}
|
||||
|
||||
# Else we are single part and have either a body IO handle or the body is in memory
|
||||
elsif (defined $io) {
|
||||
$self->debug("Creating singlepart email.") if $self->{_debug};
|
||||
$self->_build_singlepart_head($code, $io);
|
||||
}
|
||||
else {
|
||||
$self->error("NOBODY", "WARN");
|
||||
$code->($self->{head}->header_as_string . $CRLF . $CRLF . $GT::Mail::Parse::ENCODED);
|
||||
}
|
||||
|
||||
# If we have parts go through all of them and add them.
|
||||
if (@{$self->{head}->{parts}} > 0) {
|
||||
my $num_parts = $#{$self->{head}->{parts}};
|
||||
for my $num (0 .. $num_parts) {
|
||||
next unless $self->{head}->{parts}->[$num];
|
||||
$self->debug("Creating part ($num).") if $self->{_debug};
|
||||
$self->_build_parts($code, $self->{head}->{parts}->[$num]);
|
||||
if ($num_parts == $num) {
|
||||
$self->debug("Boundary\n\t--$bound--") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . '--' . $CRLF);
|
||||
}
|
||||
else {
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . $CRLF);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Add the epilogue if we are multipart
|
||||
if (@{$self->{head}->{parts}} > 0) {
|
||||
my $epilogue = join('', @{ $self->{head}->epilogue || [] }) || '';
|
||||
$epilogue =~ s/\015?\012//g;
|
||||
$self->debug("Setting epilogue to ($epilogue)") if $self->{_debug};
|
||||
$code->($epilogue . $CRLF . $CRLF) if $epilogue;
|
||||
}
|
||||
$self->debug("\n\t<-------------- Email created.") if $self->{_debug};
|
||||
return $self->{head};
|
||||
}
|
||||
|
||||
sub write {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->write ('/path/to/file');
|
||||
# ------------------------------
|
||||
# $obj->write (*FH);
|
||||
# ------------------
|
||||
# Writes the email to the specified file or file handle. The email will be
|
||||
# encoded properly. This is nice for writing to an mbox file. If a file path
|
||||
# is specified this will attempt to open it >. Returns 1 on success and undef
|
||||
# on failure.
|
||||
#
|
||||
my ($self, $file) = @_;
|
||||
my $io;
|
||||
if (ref($file) and (ref($file) eq 'GLOB') and fileno($file)) {
|
||||
$self->debug("Filehandle passed to write: fileno (" . fileno($file) . ").") if $self->{_debug};
|
||||
$io = $file;
|
||||
}
|
||||
elsif (open FH, ">$file") {
|
||||
$io = \*FH;
|
||||
$self->debug("Opening ($file) for reading.") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
return $self->error("BADARGS", "FATAL", '$obj->write ("/path/to/file"); -or- $obj->write (\*FH);');
|
||||
}
|
||||
$self->build_email(sub { print $io @_ }) or return;
|
||||
$self->debug("Email written to fileno (" . fileno($io) . ")") if $self->{_debug};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _set_io {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private function to decide what to do with the arguments passed into parse
|
||||
# and parse_head.
|
||||
#
|
||||
my ($self, $io) = @_;
|
||||
|
||||
CASE: {
|
||||
ref($io) eq 'SCALAR' and do { $self->{parser}->in_string($io); last CASE };
|
||||
ref($io) and ref($io) =~ /^GLOB|FileHandle$/ and do { $self->{parser}->in_handle($io); last CASE };
|
||||
-f $io and do { $self->{parser}->in_file($io); last CASE };
|
||||
ref $io or do { $self->{parser}->in_string($io); last CASE };
|
||||
return $self->error("NOIO", "FATAL");
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _encoding {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to guess the encoding type.
|
||||
#
|
||||
my ($self, $part) = @_;
|
||||
my $encoding;
|
||||
$encoding = $part->mime_attr('content-transfer-encoding');
|
||||
if ($encoding and lc($encoding) ne '-guess') {
|
||||
return $encoding;
|
||||
}
|
||||
else {
|
||||
return $part->suggest_encoding;
|
||||
}
|
||||
}
|
||||
|
||||
sub date_stamp {
|
||||
# --------------------------------------------------------------------------
|
||||
# Set an RFC date, e.g.: Mon, 08 Apr 2002 13:56:22 -0700
|
||||
#
|
||||
my $self = shift;
|
||||
require GT::Date;
|
||||
local @GT::Date::MONTHS_SH = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
|
||||
local @GT::Date::DAYS_SH = qw/Sun Mon Tue Wed Thu Fri Sat/;
|
||||
return GT::Date::date_get(time, '%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o%');
|
||||
}
|
||||
|
||||
sub parse_address {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Parses out the name and e-mail address of a given "address". For example,
|
||||
# from: "Jason Rhinelander" <jason@gossamer-threads.com>, this will return
|
||||
# ('Jason Rhinelander', 'jason@gossamer-threads.com'). It handes escapes as
|
||||
# well - "Jason \(\"jagerman\"\) Rhinelander" <jason@gossamer-threads.com>
|
||||
# returns 'Jason ("jagerman") Rhinelander' for the name.
|
||||
#
|
||||
my ($self, $email_from) = @_;
|
||||
|
||||
my ($name, $email) = ('', '');
|
||||
if ($email_from =~ /"?((?:[^<"\\]|\\.)+?)"?\s*<([^>]*)>/) {
|
||||
($name, $email) = ($1, $2);
|
||||
$name =~ s/\\(.)/$1/g;
|
||||
$name =~ s/^\s*$//;
|
||||
}
|
||||
elsif ($email_from =~ /<([^>]*)>/) {
|
||||
$email = $1;
|
||||
}
|
||||
else {
|
||||
$email = $email_from || '';
|
||||
$email =~ s/\([^)]+\)//g;
|
||||
}
|
||||
return ($name, $email);
|
||||
}
|
||||
|
||||
sub _get_body_handle {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to get a body handle on a given part.
|
||||
#
|
||||
my ($self, $part) = @_;
|
||||
my $in = $part->body_in || 'NONE';
|
||||
my $io;
|
||||
if ($in eq 'MEMORY') {
|
||||
$self->debug("Body is in MEMORY.") if $self->{_debug};
|
||||
return $part->body_data;
|
||||
}
|
||||
elsif ($in eq 'FILE') {
|
||||
$self->debug("Body is in FILE: " . $part->body_path) if $self->{_debug};
|
||||
$io = $part->open('r');
|
||||
}
|
||||
elsif ($in eq 'HANDLE') {
|
||||
$self->debug("Body is in HANDLE.") if $self->{_debug};
|
||||
$io = $part->body_handle;
|
||||
binmode($io);
|
||||
}
|
||||
return $io;
|
||||
}
|
||||
|
||||
sub _build_multipart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a multipart header.
|
||||
#
|
||||
my ($self, $code, $io) = @_;
|
||||
my $bound = $self->{head}->multipart_boundary;
|
||||
my $encoding = $self->_encoding($self->{head});
|
||||
$self->debug("Setting encoding to ($encoding).") if $self->{_debug};
|
||||
$self->{head}->set(
|
||||
'Content-Transfer-Encoding' => $encoding
|
||||
);
|
||||
if (defined $io) {
|
||||
my $mime = 'text/plain';
|
||||
my ($type, $subtype) = split '/' => $self->{head}->mime_type;
|
||||
if ($type and lc($type) ne 'multipart') {
|
||||
$subtype ||= 'mixed';
|
||||
$mime = "$type/$subtype";
|
||||
}
|
||||
my %new = (
|
||||
type => $mime,
|
||||
encoding => $encoding,
|
||||
disposition => "inline"
|
||||
);
|
||||
|
||||
# Body is in a handle
|
||||
if (ref $io) { $new{body_handle} = $io }
|
||||
|
||||
# Body is in memory
|
||||
else { $new{body_data} = $io }
|
||||
|
||||
my $new = $self->new_part(%new);
|
||||
$self->{head}->{body_in} = 'NONE';
|
||||
unshift @{$self->{head}->{parts}}, $new;
|
||||
}
|
||||
$bound ||= "---------=_" . time . "-$$-" . int(rand(time)/2);
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $self->{head}->get('Content-Type');
|
||||
if ($c !~ /\Q$bound/i) {
|
||||
if ($c and lc($c) !~ /boundary=/) {
|
||||
$c =~ /multipart/ or $c = 'multipart/mixed';
|
||||
$self->debug(qq|Setting content type to ($c; boundary="$bound")|) if $self->{_debug};
|
||||
$self->{head}->set('Content-Type' => $c . qq|; boundary="$bound"|);
|
||||
}
|
||||
else {
|
||||
$self->debug("Setting multipart boundary to ($bound).") if $self->{_debug};
|
||||
$self->{head}->set('Content-Type' => qq!multipart/mixed; boundary="$bound"!);
|
||||
}
|
||||
}
|
||||
|
||||
my $preamble = join('', @{$self->{head}->preamble || []})
|
||||
|| "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug("Setting preamble to ($preamble).") if $self->{_debug};
|
||||
(my $head = $self->{head}->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($head . $CRLF . $preamble . $CRLF . $CRLF . '--' . $bound . $CRLF);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_singlepart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a single part header.
|
||||
#
|
||||
my ($self, $code, $io) = @_;
|
||||
my $encoding = $self->_encoding($self->{head});
|
||||
$self->debug("Setting encoding to ($encoding).") if $self->{_debug};
|
||||
$self->{head}->set('Content-Transfer-Encoding' => $encoding);
|
||||
(my $head = $self->{head}->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$code->($head . $CRLF);
|
||||
$self->debug("Encoding body with ($encoding).") if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode(
|
||||
debug => $self->{_debug},
|
||||
encoding => $encoding,
|
||||
in => $io,
|
||||
out => $code
|
||||
) or return $self->error("ENCODE", "WARN", $GT::Mail::Encoder::error);
|
||||
|
||||
# Must seek to the beginning for additional calls
|
||||
seek($io, 0, 0) if ref $io;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method that builds the parts for the email.
|
||||
#
|
||||
my ($self, $code, $part) = @_;
|
||||
|
||||
# Need a code ref to continue.
|
||||
ref($code) eq 'CODE' or return $self->error("BADARGS", "FATAL", '$obj->build_email(sub { do something });');
|
||||
|
||||
# Need the head to contiue
|
||||
$self->{head} or return $self->error("NOEMAIL", "FATAL");
|
||||
|
||||
my ($body, $io, $encoding, $bound);
|
||||
|
||||
# Get the io handle for the body
|
||||
$io = $self->_get_body_handle($part);
|
||||
$bound = $part->multipart_boundary;
|
||||
|
||||
# The body is in an io stream.
|
||||
if (defined $io) {
|
||||
|
||||
# Find the encoding for the part and set it.
|
||||
$encoding = $self->_encoding($part);
|
||||
$self->debug("Setting encoding to ($encoding).") if $self->{_debug};
|
||||
$part->set('Content-Transfer-Encoding' => $encoding);
|
||||
}
|
||||
|
||||
# If the message has parts and has a multipart boundary
|
||||
if ((@{$part->{parts}} > 0) and ($bound)) {
|
||||
$self->debug("Part is multpart.") if $self->{_debug};
|
||||
|
||||
# Set the multipart boundary
|
||||
$self->debug("Setting boundary to ($bound).") if $self->{_debug};
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $part->get('Content-Type');
|
||||
if ($c) {
|
||||
$self->debug(qq|Setting content type to ($c; boundary="$bound")|) if $self->{_debug};
|
||||
$part->set('Content-Type' => $c . qq|; boundary="$bound"|);
|
||||
}
|
||||
else {
|
||||
$self->debug("Setting multipart boundary to ($bound).") if $self->{_debug};
|
||||
$part->set('Content-Type' => qq!multipart/mixed; boundary="$bound"!);
|
||||
}
|
||||
|
||||
my $preamble = join('', @{$part->preamble || []})
|
||||
|| "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug("Setting preamble to ($preamble).") if $self->{_debug};
|
||||
(my $head = $part->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($head . $CRLF . $preamble . $CRLF . '--' . $bound . $CRLF);
|
||||
}
|
||||
else {
|
||||
$self->debug("Part is single part.") if $self->{_debug};
|
||||
(my $head = $part->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$code->($head . $CRLF);
|
||||
}
|
||||
|
||||
# Set the body only if we have one. We would not have one on the head an multipart
|
||||
if ($io) {
|
||||
$self->debug("Encoding body with ($encoding).") if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode(
|
||||
encoding => $encoding,
|
||||
debug => $self->{_debug},
|
||||
in => $io,
|
||||
out => $code
|
||||
) or return $self->error("ENCODE", "WARN", $GT::Mail::Encoder);
|
||||
|
||||
# Must reseek IO for multiple calls.
|
||||
seek($io, 0, 0) if ref $io;
|
||||
}
|
||||
else {
|
||||
$self->debug("Part has no body!") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Add the rest of the parts
|
||||
if (@{$part->{parts}} > 0) {
|
||||
$self->debug("Part has parts.") if $self->{_debug};
|
||||
my $num_parts = $#{$part->{parts}};
|
||||
for my $num (0 .. $num_parts) {
|
||||
next unless $part->{parts}->[$num];
|
||||
$self->debug("Creating part ($num).") if $self->{_debug};
|
||||
$self->_build_parts($code, $part->{parts}->[$num]) or return;
|
||||
if ($bound) {
|
||||
if ($num_parts == $num) {
|
||||
$self->debug("Boundary\n\t--$bound--") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . '--' . $CRLF);
|
||||
}
|
||||
else {
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . $CRLF);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
undef $io;
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail - A simple interface to parsing, sending, and creating email.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail;
|
||||
|
||||
# Create and Sending
|
||||
GT::Mail->send(
|
||||
smtp => 'gossamer-threads.com',
|
||||
smtp_port => 110, # optional; 110/465 (normal/SSL) will be used for the default
|
||||
smtp_ssl => 1, # establish an SSL connection. Requires Net::SSLeay 1.06 or newer.
|
||||
to => 'scott@gossamer-threads.com',
|
||||
from => 'scott@gossamer-threads.com',
|
||||
subject => 'Hello!!',
|
||||
msg => 'I am a text email'
|
||||
) or die "Error: $GT::Mail::error";
|
||||
|
||||
# Parsing and sending
|
||||
my $mail = GT::Mail->new(debug => 1);
|
||||
|
||||
# Parse an email that is in a file called mail.test
|
||||
my $parser = $mail->parse('mail.test') or die "Error: $GT::Mail::error";
|
||||
|
||||
# Change who it is to
|
||||
$parser->set("to", 'scott@gossamer-threads.com');
|
||||
|
||||
# Add an attachment to it
|
||||
$mail->attach (
|
||||
type => 'text/plain',
|
||||
encoding => '-guess',
|
||||
body_path => 'Mail.pm',
|
||||
filename => 'Mail.pm'
|
||||
);
|
||||
|
||||
# Send the email we just parsed and modified
|
||||
$mail->send(sendmail => '/usr/sbin/sendmail') or die "Error: $GT::Mail::error";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail is a simple interface for parsing, creating, and sending email. It
|
||||
uses GT::Mail::Send to send email and GT::Mail::Parse to parse and store email
|
||||
data structurs. All the creation work is done from within GT::Mail.
|
||||
|
||||
=head2 Creating a new GT::Mail object
|
||||
|
||||
The arguments to new() in GT::Mail are mostly the same for all the class
|
||||
methods in GT::Mail so I will be refering back to these further down. Mostly
|
||||
these arguments are used to set parts of the header for creating an email. The
|
||||
arguments can be passed in as either a hash or a hash ref. Any arguments aside
|
||||
from these will be added to the content header as raw header fields. The
|
||||
following is a list of the keys and a brief description.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debug level for this object. Anything but zero will produce ouput on
|
||||
STDERR.
|
||||
|
||||
=item disposition
|
||||
|
||||
Sets the Content-Disposition.
|
||||
|
||||
=item filename
|
||||
|
||||
Sets the Content-Disposition to attachment and the file name to what to
|
||||
specify.
|
||||
|
||||
=item encoding
|
||||
|
||||
Sets the Content-Transfer-Encoding (You really should not set this).
|
||||
|
||||
=item type
|
||||
|
||||
Sets the Content-Type.
|
||||
|
||||
=item body_data
|
||||
|
||||
Sets the top level body data to the in memory string specified.
|
||||
|
||||
=item msg
|
||||
|
||||
Same as body_data.
|
||||
|
||||
=item body_handle
|
||||
|
||||
Sets the top level body to the File Handle.
|
||||
|
||||
=item body_path
|
||||
|
||||
Sets the top level body path.
|
||||
|
||||
=back
|
||||
|
||||
=head2 parser - Set or get the parse object.
|
||||
|
||||
my $parser = $mail->parser;
|
||||
$mail->parser($parser);
|
||||
|
||||
Set or get method for the parser object that is used when you call parse_head()
|
||||
or parse(). This object must conform to the method parse and parse_head. If no
|
||||
object is passed to this method a L<GT::Mail::Parse> object is created when
|
||||
needed.
|
||||
|
||||
=head2 parse - Parsing an email.
|
||||
|
||||
Instance method that returns a parts object. Emails are stored recursivly in
|
||||
parts object. That is emails can have parts within parts within parts etc.. See
|
||||
L<GT::Mail::Parts> for details on the methods supported by the parts object
|
||||
that is returned.
|
||||
|
||||
The parse() method takes only one argument. It can be a GLOB ref to a file
|
||||
handle, a FileHandle object, or the path to a file. In any case the IO must
|
||||
contain a valid formated email.
|
||||
|
||||
Once an email is parsed, you can make changes to it as you need and call the
|
||||
send method to send it or call the write method to write it to file, etc.
|
||||
|
||||
This method will return false if an error occurs when parsing. The error
|
||||
message will be set in $GT::Mail::error.
|
||||
|
||||
=head2 parse_head - Parsing just the head.
|
||||
|
||||
This method does the exact same thing as the parse method but it will only
|
||||
parse the top level header of the email. Any IO's will be reset after the
|
||||
parsing.
|
||||
|
||||
Use this method if whether you want to parse and decode the body of the email
|
||||
depends on what is in the header of the email or if you only need access to the
|
||||
header. None of the parts will contain a body.
|
||||
|
||||
=head2 send - Sending an email.
|
||||
|
||||
Class/Instance method for sending email. It sends the currently in memory
|
||||
email. This means, if you parse an email, that email is in memory, if you
|
||||
specify params for an email to new(), that is the email that gets sent. You can
|
||||
also specify the params for the email to this method.
|
||||
|
||||
=head2 top_part - Getting a Parts object.
|
||||
|
||||
Instance method to set or get the top level part. If you are setting this, the
|
||||
object must be from L<GT::Mail::Parts>. You can use this to retrieve the part
|
||||
object after you specify params to create an email. This object will contain
|
||||
all the other parts for the email. e.g. attachments and emails that are
|
||||
attached. See L<GT::Mail::Parts> for more details on this object.
|
||||
|
||||
=head2 new_part - Creating a Parts object.
|
||||
|
||||
Instance method to get a new part object. This method takes the same arguments
|
||||
as the new() constructor. Returns the new part object. The part object is
|
||||
added to the current email only if arguments are given otherwize just returns
|
||||
an empty part.
|
||||
|
||||
=head2 attach - Attaching to an email.
|
||||
|
||||
Instance method to attach to the in memory email. You can pass in a GT::Mail
|
||||
object or you can pass the same arguments you would pass to new() to specify
|
||||
all the information about the attachment. In addition if you specify a file
|
||||
path and do not specify a mime type, this will attempt to guess the mime type
|
||||
from the file extention.
|
||||
|
||||
=head2 to_string - Getting the email as a string.
|
||||
|
||||
Returns the entire email as a string. Do not use this function if you have
|
||||
attachments and are worried about memory ussage.
|
||||
|
||||
=head2 as_string - Getting the email as a string.
|
||||
|
||||
Same as to_string.
|
||||
|
||||
=head2 build_email - Building an email.
|
||||
|
||||
Instance method that builds the currently in memory email. This method takes
|
||||
one argument, a code ref. It calles the code ref with one argument. The code
|
||||
ref is called for each section of the email that is created. A good example of
|
||||
how to use this is what the as_string method does:
|
||||
|
||||
my $ret = '';
|
||||
$obj->build_email(sub { $ret .= $_[0] });
|
||||
|
||||
This puts the entire created email into the string $ret. You can use this, for
|
||||
example to print the email to a filehandle (which is what the write() method
|
||||
does).
|
||||
|
||||
=head2 write - Writing an email to a file handle.
|
||||
|
||||
Instance mothod that writes the currently in memory email to a file or file
|
||||
handle. The only arguments this method takes is a file or a reference to a glob
|
||||
that is a filehandle or FileHandle object.
|
||||
|
||||
=head2 naming - Setting the naming scheme.
|
||||
|
||||
Instance method to specify a naming scheme for parsing emails. Calling this
|
||||
after the email is parsed has no effect. This method just wraps to the one in
|
||||
L<GT::Mail::Parse>.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Mail.pm,v 1.70 2004/11/04 20:23:09 brewt Exp $
|
||||
|
||||
=cut
|
||||
1282
site/glist/lib/GT/Mail/BulkMail.pm
Normal file
1282
site/glist/lib/GT/Mail/BulkMail.pm
Normal file
File diff suppressed because it is too large
Load Diff
524
site/glist/lib/GT/Mail/Editor.pm
Normal file
524
site/glist/lib/GT/Mail/Editor.pm
Normal file
@@ -0,0 +1,524 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Editor
|
||||
#
|
||||
# Author: Jason Rhinelander
|
||||
# Revision: $Id: Editor.pm,v 1.24 2005/01/18 23:06:40 bao Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# The backend to a web-based e-mail template editor. See the pod for
|
||||
# instructions. This is designed the be used primarily from templates.
|
||||
# This module respects local directories on saving, and both local and
|
||||
# inheritance directories when loading.
|
||||
#
|
||||
# Also, any subclasses must be (something)::Editor
|
||||
#
|
||||
|
||||
package GT::Mail::Editor;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION $DEBUG $ERRORS @ISA $ATTRIBS);
|
||||
|
||||
use GT::Base;
|
||||
use GT::Template;
|
||||
|
||||
@ISA = 'GT::Base';
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
$ERRORS = {
|
||||
PARSE => "An error occured while parsing: %s",
|
||||
NODIR => "Template directory not specified",
|
||||
BADDIR => "Template directory '%s' does not exist or has the permissions set incorrectly",
|
||||
NOFILE => "No template filename specified",
|
||||
CANT_CREATE_DIR => "Unable to create directory '%s': %s",
|
||||
BADFILE => "Template '%s' does not exist or is not readable",
|
||||
SAVEERROR => "Unable to open '%s' for writing: %s",
|
||||
LOADERROR => "Unable to open '%s' for reading: %s",
|
||||
RECURSION => "Recursive inheritance detected and interrupted: '%s'",
|
||||
INVALIDDIR => "Invalid template directory %s",
|
||||
INVALIDTPL => "Invalid template %s",
|
||||
};
|
||||
|
||||
$ATTRIBS = {
|
||||
dir => '',
|
||||
template => '',
|
||||
file => '',
|
||||
headers => undef,
|
||||
extra_headers => '',
|
||||
body => ''
|
||||
};
|
||||
|
||||
# GT::Mail::Editor::tpl_save(header => To => $header_to, header => From => $header_from, ..., extra_headers => $extra_headers)
|
||||
# ($extra_headers will be parsed). Everything is optional, but you should give something to build headers from.
|
||||
# It is not necessary to use To, From, etc. - you can enter them directly in the "extra_headers" field.
|
||||
sub tpl_save {
|
||||
# Have to extract the three-argument arguments BEFORE getting $self
|
||||
my @headers;
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if ($_[$i] eq 'header') {
|
||||
push @headers, (splice @_, $i, 3)[1,2];
|
||||
redo;
|
||||
}
|
||||
}
|
||||
my $self = &_get_self;
|
||||
for (my $i = 0; $i < @headers; $i += 2) {
|
||||
$self->{headers}->{$headers[$i]} = $headers[$i+1];
|
||||
}
|
||||
if ($self->{extra_headers}) {
|
||||
for (split /\s*\n\s*/, $self->{extra_headers}) { # This will weed out any blank lines
|
||||
my ($key, $value) = split /\s*:\s*/, $_, 2;
|
||||
$self->{headers}->{$key} = $value if $key and $value;
|
||||
}
|
||||
}
|
||||
my $dir;
|
||||
if ($self->{dir} and $self->{template}) {
|
||||
$dir = "$self->{dir}/$self->{template}/local";
|
||||
if (!-d $dir) {
|
||||
# Attempt to create the "local" subdirectory
|
||||
mkdir($dir, 0777) or return $self->error(CANT_CREATE_DIR => 'FATAL' => $dir => "$!");
|
||||
chmod(0777, $dir);
|
||||
}
|
||||
}
|
||||
elsif ($self->{dir}) {
|
||||
$dir = $self->{dir};
|
||||
}
|
||||
|
||||
local *FILE;
|
||||
$self->{_error} = [];
|
||||
if (not $dir) {
|
||||
$self->error(NODIR => 'WARN');
|
||||
}
|
||||
elsif (not -d $dir or not -w $dir) {
|
||||
$self->error(BADDIR => WARN => $dir);
|
||||
}
|
||||
elsif (not $self->{file}) {
|
||||
$self->error(NOFILE => 'WARN');
|
||||
}
|
||||
elsif (-f "$dir/$self->{file}" and not -w _) {
|
||||
$self->error(BADFILE => WARN => "$dir/$self->{file}");
|
||||
}
|
||||
elsif (not open FILE, "> $dir/$self->{file}") {
|
||||
$self->error(SAVEERROR => WARN => "$dir/$self->{file}", "$!");
|
||||
}
|
||||
else { # Everything is good, now we have FILE open to the file.
|
||||
$self->debug("Saving $dir/$self->{file}");
|
||||
my $headers;
|
||||
while (my ($key, $val) = each %{$self->{headers}}) {
|
||||
next unless $key and $val;
|
||||
$key =~ s/\r?\n//g; $val =~ s/\r?\n//g; # Just in case...
|
||||
$headers .= "$key: $val\n";
|
||||
}
|
||||
print FILE $headers;
|
||||
print FILE "" . "\n"; # Blank line
|
||||
$self->{body} =~ s/\r\n/\n/g;
|
||||
print FILE $self->{body};
|
||||
close FILE;
|
||||
}
|
||||
|
||||
if (@{$self->{_error}}) {
|
||||
return { error => join("<br>\n", @{$self->{_error}}) };
|
||||
}
|
||||
else {
|
||||
return { success => 1, error => '' };
|
||||
}
|
||||
}
|
||||
|
||||
# GT::Mail::Editor::tpl_load(header => To, header => From, header => Subject)
|
||||
# In this case, "To", "From" and "Subject" will come to you as header_To,
|
||||
# header_From, and header_Subject.
|
||||
# What you get back is a hash reference, with either "error" set to an error
|
||||
# if something bad happened, or "success" set to 1, and the following template
|
||||
# variables:
|
||||
#
|
||||
# header_To, header_From, header_Subject, header_...
|
||||
# => The value of the To, From, Subject, etc. field.
|
||||
# -> Only present for individual headers that are requested with "header"
|
||||
# extra_headers => A loop of all the other headers with { name => To, From, etc., value => value }
|
||||
# body => The body of the e-mail. This will eventually change as this module
|
||||
# -> becomes capable of creating e-mails with multiple parts.
|
||||
sub tpl_load {
|
||||
my $self = &_get_self;
|
||||
my %sep_headers;
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if (lc $_[$i] eq 'header') {
|
||||
$sep_headers{$_[++$i]} = 1;
|
||||
}
|
||||
}
|
||||
my $dir;
|
||||
if ($self->{dir} and $self->{template} and $self->{file}
|
||||
and $self->{template} !~ m[[\\/\x00-\x1f]] and $self->{template} ne '..'
|
||||
and $self->{file} !~ m[[\\/\x00-\x1f]]) {
|
||||
$dir = "$self->{dir}/$self->{template}";
|
||||
if (-f "$dir/local/$self->{file}") {
|
||||
$dir .= "/local";
|
||||
}
|
||||
elsif (!-f "$dir/$self->{file}") {
|
||||
my ($tplinfo, %tplinfo);
|
||||
while ($tplinfo = GT::Template->load_tplinfo($dir) and my $inherit = $tplinfo->{inheritance}) {
|
||||
if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
|
||||
$dir = $inherit;
|
||||
}
|
||||
else {
|
||||
$dir .= "/$inherit";
|
||||
}
|
||||
if (-f "$dir/local/$self->{file}") {
|
||||
$dir .= "/local";
|
||||
last;
|
||||
}
|
||||
elsif (-f "$dir/$self->{file}") {
|
||||
last;
|
||||
}
|
||||
if (length $dir > 150 or $tplinfo{$dir}++) { # We've already looked at that directory, or we just have too many relative paths tacked on the end
|
||||
$self->error(RECURSION => WARN => $dir);
|
||||
last; # End the loop - there is no more inheritance since we would just be recursing over what we already have
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $fh = \do { local *FILE; *FILE };
|
||||
$self->{_error} = [];
|
||||
my $return = { success => 0, error => '' };
|
||||
if ($self->{template} =~ m[[\\/\x00-\x1f]] or $self->{template} eq '..') {
|
||||
$self->error(INVALIDDIR => WARN => $self->{template});
|
||||
}
|
||||
elsif ($self->{file} =~ m[[\\/\x00-\x1f]]) {
|
||||
$self->error(INVALIDTPL => WARN => $self->{file});
|
||||
}
|
||||
elsif (not $dir) {
|
||||
$self->error(NODIR => 'WARN');
|
||||
}
|
||||
elsif (not -d $dir) {
|
||||
$self->error(BADDIR => WARN => $dir);
|
||||
}
|
||||
elsif (not $self->{file}) {
|
||||
$self->error(NOFILE => 'WARN');
|
||||
}
|
||||
elsif (not -r "$dir/$self->{file}") {
|
||||
$self->error(BADFILE => WARN => "$dir/$self->{file}");
|
||||
}
|
||||
elsif (not open $fh, "< $dir/$self->{file}") {
|
||||
$self->error(LOADERROR => WARN => "$dir/$self->{file}");
|
||||
}
|
||||
else { # Everything is good, now we have $fh open to the file.
|
||||
$return->{success} = 1;
|
||||
$self->load($fh);
|
||||
while (my ($name, $val) = each %{$self->{headers}}) {
|
||||
if ($sep_headers{$name}) {
|
||||
$return->{"header_$name"} = $val;
|
||||
}
|
||||
else {
|
||||
push @{$return->{extra_headers}}, { name => $name, value => $val };
|
||||
}
|
||||
}
|
||||
$return->{body} = $self->{body};
|
||||
}
|
||||
if ($self->{_error}) {
|
||||
$return->{error} = join "<br>\n", @{$self->{_error}};
|
||||
}
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub tpl_delete {
|
||||
my $self = &_get_self;
|
||||
|
||||
if ($self->{dir} and $self->{template} and $self->{file}
|
||||
and $self->{template} !~ m[[\\/\x00-\x1f]] and $self->{template} ne '..'
|
||||
and $self->{file} !~ m[[\\/\x00-\x1f]]) {
|
||||
my $tpl = "$self->{dir}/$self->{template}/local/$self->{file}";
|
||||
if (-f $tpl and not unlink $tpl) {
|
||||
return { error => "Unable to remove $tpl: $!" };
|
||||
}
|
||||
}
|
||||
return { success => 1, error => '' };
|
||||
}
|
||||
|
||||
# Loads a template from a filehandle or a file.
|
||||
# You must pass in a GLOB reference as a filehandle to be read from.
|
||||
# Otherwise, this method will attempt to open the file passed in and then read from it.
|
||||
# (the file opened will have directory and template prepended to it).
|
||||
sub load {
|
||||
my $self = shift;
|
||||
my $fh;
|
||||
my $file = shift;
|
||||
if (ref $file eq 'GLOB' or ref $file eq 'SCALAR' or ref $file eq 'LVALUE') {
|
||||
$fh = $file;
|
||||
}
|
||||
else {
|
||||
$fh = \do { local *FILE; *FILE };
|
||||
my $dir;
|
||||
if ($self->{template}) {
|
||||
$dir = "$self->{dir}/$self->{template}";
|
||||
if (-f "$dir/local/$file") {
|
||||
$dir .= "/local";
|
||||
}
|
||||
elsif (!-f "$dir/$file") {
|
||||
my ($tplinfo, %tplinfo);
|
||||
while ($tplinfo = GT::Template->load_tplinfo($dir) and my $inherit = $tplinfo->{inheritance}) {
|
||||
if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
|
||||
$dir = $inherit;
|
||||
}
|
||||
else {
|
||||
$dir .= "/$inherit";
|
||||
}
|
||||
if (-f "$dir/local/$file") {
|
||||
$dir .= "/local";
|
||||
last;
|
||||
}
|
||||
elsif (-f "$dir/$file") {
|
||||
last;
|
||||
}
|
||||
if (length $dir > 150 or $tplinfo{$dir}++) { # We've already looked at that directory, or we just have too many relative paths tacked on the end
|
||||
$self->error(RECURSION => WARN => $dir);
|
||||
last; # End the loop - there is no more inheritance since we would just be recursing over what we already have
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
$file = "$dir/$file";
|
||||
|
||||
open $fh, "< $file" or return $self->error(BADFILE => WARN => $file);
|
||||
}
|
||||
if (ref $fh eq 'GLOB') {
|
||||
while (<$fh>) { # The header
|
||||
s/\r?\n$//;
|
||||
last if not $_; # An empty line is the end of the headers
|
||||
my ($field, $value) = split /:\s*/, $_, 2;
|
||||
$self->{headers}->{$field} = $value;
|
||||
}
|
||||
while (<$fh>) { # The body
|
||||
$self->{body} .= $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
(my $header, $self->{body}) = split /\r?\n\r?\n/, $$fh, 2;
|
||||
my @h = split /\r?\n/, $header;
|
||||
for (@h) {
|
||||
my ($field, $value) = split /:\s*/, $_, 2;
|
||||
$self->{headers}->{$field} = $value;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Creates and returns a $self object. Looks at $_[0] to see if it is already
|
||||
# an editor object, and if so uses that. Otherwise it calls new() with @_.
|
||||
# Should be called as &_get_self; If called as a class method, the first
|
||||
# argument will be removed. So, instead of: 'my $self = shift;' you should
|
||||
# use: 'my $self = &_get_self;'
|
||||
sub _get_self {
|
||||
my $self;
|
||||
if (ref $_[0] and substr(ref $_[0], -8) eq '::Editor') { # This will allow any subclass as long as it is something::Editor
|
||||
$self = shift;
|
||||
}
|
||||
elsif (@_ and substr($_[0], -8) eq '::Editor') { # Class methods
|
||||
my $class = shift;
|
||||
$self = $class->new(@_);
|
||||
}
|
||||
else {
|
||||
$self = __PACKAGE__->new(@_);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->set(@_);
|
||||
tie %{$self->{headers}}, __PACKAGE__ . '::Ordered';
|
||||
}
|
||||
|
||||
|
||||
package GT::Mail::Editor::Ordered;
|
||||
# Implements a hash that retains the order elements are inserted into it.
|
||||
|
||||
sub TIEHASH { bless { o => [], h => {}, p => 0 }, $_[0] }
|
||||
|
||||
sub STORE {
|
||||
my ($self, $key, $val) = @_;
|
||||
$self->DELETE($key) if exists $self->{h}->{$key};
|
||||
$self->{h}->{$key} = $val;
|
||||
push @{$self->{o}}, $key;
|
||||
}
|
||||
|
||||
sub FETCH { $_[0]->{h}->{$_[1]} }
|
||||
|
||||
sub FIRSTKEY {
|
||||
my $self = shift;
|
||||
$self->{p} = 0;
|
||||
$self->{o}->[$self->{p}++]
|
||||
}
|
||||
|
||||
sub NEXTKEY { $_[0]->{o}->[$_[0]->{p}++] }
|
||||
|
||||
sub EXISTS { exists $_[0]->{h}->{$_[1]} }
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $key) = @_;
|
||||
for (0 .. $#{$self->{o}}) {
|
||||
if ($self->{o}->[$_] eq $key) {
|
||||
splice @{$self->{o}}, $_, 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
delete $self->{h}->{$key};
|
||||
}
|
||||
sub CLEAR { $_[0] = { o => [], h => {}, p => 0 }; () }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Editor - E-mail template editor
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Generally used from templates:
|
||||
|
||||
<%GT::Mail::Editor::tpl_load(
|
||||
dir => $template_root,
|
||||
template => $template_set,
|
||||
file => $filename,
|
||||
header => From,
|
||||
header => To,
|
||||
header => Subject
|
||||
)%>
|
||||
|
||||
<%if error%>
|
||||
Unable to load e-mail template: <%error%>
|
||||
<%else%>
|
||||
From: <input type=text name=header_From value="<%header_From%>">
|
||||
To: <input type=text name=header_To value="<%header_To%>">
|
||||
Subject: <input type=text name=header_Subject value="<%header_Subject%>">
|
||||
Other headers:<br>
|
||||
<textarea name=extra_headers>
|
||||
<%loop extra_headers%><%name%>: <%value%>
|
||||
<%endloop%>
|
||||
<%endif%>
|
||||
|
||||
|
||||
- or -
|
||||
|
||||
|
||||
<%GT::Mail::Editor::save(
|
||||
dir => $template_root,
|
||||
template => $template_set,
|
||||
file => $filename,
|
||||
header => To => $header_To,
|
||||
header => From => $header_From,
|
||||
header => Subject => $header_Subject,
|
||||
extra_headers => $extra_headers
|
||||
)%>
|
||||
<%if error%>Unable to save e-mail template: <%error%>
|
||||
... Display the above form in here ...
|
||||
<%endif%>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Editor is designed to provide a template interface to creating and
|
||||
editing a wide variety of e-mail templates. Although not currently supported,
|
||||
eventually attachments, HTML, etc. will be supported.
|
||||
|
||||
=head2 tpl_load - Loads a template (from the templates)
|
||||
|
||||
Calling GT::Mail::Editor::tpl_load from a template returns variables required to
|
||||
display a form to edit the template passed in.
|
||||
|
||||
=over 4
|
||||
|
||||
=item dir
|
||||
|
||||
Defines the base directory of templates.
|
||||
|
||||
=item template
|
||||
|
||||
This defines a template set. This is optional. If present, this directory will
|
||||
be tacked onto the end of 'dir'. This is simply to provide a more flexible way
|
||||
to specify the template directory. For example, if you have 'dir' set to '/a/b'
|
||||
and template set to 'c', then the directory '/a/b/c' will be used to save and
|
||||
load e-mail templates.
|
||||
|
||||
=item file
|
||||
|
||||
Specify the filename of the template inside the directory already specified with
|
||||
'dir' and 'template'
|
||||
|
||||
=item header
|
||||
|
||||
Multiple "special" headers can be requested with this. The argument following
|
||||
each 'header' should be the name of a header, such as "To". Then, in the
|
||||
variables returned from tpl_load(), you will have a variable such as 'header_To'
|
||||
available, containing the value of the To: field.
|
||||
|
||||
=back
|
||||
|
||||
=head2 tpl_save - Save a template
|
||||
|
||||
=over 4
|
||||
|
||||
=item dir template file
|
||||
|
||||
See the entries in L<"tpl_load">
|
||||
|
||||
=item header
|
||||
|
||||
Specifies that the two following arguments are the field and value of a header
|
||||
field. For example, header => To => "abc@example.com" would specify that the To
|
||||
field should be "abc@example.com" (To: abc@example.com).
|
||||
|
||||
=item extra_headers
|
||||
|
||||
The value to extra_headers should be a newline-delimited list of headers other
|
||||
than those specified with header. These will be parsed, and blank lines skipped.
|
||||
|
||||
=item body
|
||||
|
||||
The body of the message. Need I say more? MIME messages are possible by
|
||||
inserting them directly into the body, however currently MIME messages cannot
|
||||
be created using this editor.
|
||||
|
||||
=back
|
||||
|
||||
=head2 load
|
||||
|
||||
Attempts to load a GT::Mail::Editor object with data passed in. This can take
|
||||
either a file handle or a filename. If passing a filename, dir and template
|
||||
will be used (if available). You should construct an object with new() prior
|
||||
to calling this method.
|
||||
|
||||
=head2 new
|
||||
|
||||
Constructs a new GT::Mail::Editor object. This will be done automatically when
|
||||
using the template methods L<"tpl_load"> and L<"tpl_save">. Takes the following
|
||||
arguments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item dir
|
||||
|
||||
Defines the base directory of templates.
|
||||
|
||||
=item template
|
||||
|
||||
This defines a template set. This is optional. If present, this directory will
|
||||
be tacked onto the end of 'dir'. This is simply to provide a more flexible way
|
||||
to specify the template directory. For example, if you have 'dir' set to '/a/b'
|
||||
and template set to 'c', then the directory '/a/b/c' will be used to save and
|
||||
load e-mail templates.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Editor.pm,v 1.24 2005/01/18 23:06:40 bao Exp $
|
||||
|
||||
267
site/glist/lib/GT/Mail/Editor/HTML.pm
Normal file
267
site/glist/lib/GT/Mail/Editor/HTML.pm
Normal file
@@ -0,0 +1,267 @@
|
||||
|
||||
package GT::Mail::Editor::HTML;
|
||||
|
||||
use vars qw/$ERROR_MESSAGE/;
|
||||
use strict;
|
||||
use bases 'GT::Mail::Editor' => '';
|
||||
|
||||
$ERROR_MESSAGE = 'GT::Mail::Editor';
|
||||
|
||||
|
||||
sub display {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $tags ) = @_;
|
||||
my $page = $self->{html_tpl_name};
|
||||
|
||||
if ( $self->{fields}{page} and $self->{fields}{page} =~ /^(?:editor|email)_/ ) {
|
||||
$page = $self->{fields}{page};
|
||||
}
|
||||
my $ret = $self->print_page( $page, $tags );
|
||||
$self->{displayed} = 1;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub message_from_input {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
$self->set_headers;
|
||||
|
||||
# If we have a part ID, this isn't a new text part
|
||||
my ( $part, $id );
|
||||
$part = $self->{part};
|
||||
$part->set( 'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"' );
|
||||
if ( exists( $self->{fields}{msg} ) ) {
|
||||
my $msg = $self->{fields}{msg};
|
||||
$self->urls_to_inlines( $self->{part}, \$msg );
|
||||
$part->body_data( $msg );
|
||||
}
|
||||
}
|
||||
|
||||
sub munge_message {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
|
||||
|
||||
my $root_part = $self->{message}->root_part;
|
||||
|
||||
# Simple case if the message is not multipart
|
||||
if ( !$root_part->is_multipart ) {
|
||||
$self->munge_non_multipart( $root_part );
|
||||
}
|
||||
|
||||
# We have a multipart. First thing we do is look for an alternative part
|
||||
# to use.
|
||||
elsif ( my ( $alt ) = $self->{message}->find_multipart( 'alternative' ) ) {
|
||||
$self->munge_alternative( $alt );
|
||||
}
|
||||
else {
|
||||
$self->munge_other;
|
||||
}
|
||||
$self->fix_alt_parts;
|
||||
$self->fix_related_parts;
|
||||
$self->delete_empty_multiparts;
|
||||
my ( $alt_part ) = $self->{message}->find_multipart( 'alternative' );
|
||||
my @skip = $alt_part->parts;
|
||||
$self->find_attachments( @skip );
|
||||
$self->{alt_part} = $alt_part;
|
||||
$self->{part} = $skip[1];
|
||||
}
|
||||
|
||||
sub html_part {
|
||||
# ----------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{alt_part}->parts->[1];
|
||||
}
|
||||
|
||||
sub text_part {
|
||||
# ----------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{alt_part}->parts->[0];
|
||||
}
|
||||
|
||||
sub munge_non_multipart {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $root_part ) = @_;
|
||||
|
||||
# We need to munge the message into a multipart
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $root_part,
|
||||
charset => $root_part->mime_attr( 'content-type.charset' ),
|
||||
headers_part => $root_part
|
||||
);
|
||||
$root_part->set( 'content-type' => 'multipart/mixed' );
|
||||
$root_part->parts( $new_alt );
|
||||
}
|
||||
|
||||
sub munge_alternative {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $alt_part ) = @_;
|
||||
my $root_part = $self->{message}->root_part;
|
||||
|
||||
# Make anything we can not view an attachment
|
||||
$self->{message}->move_parts_last(
|
||||
$root_part,
|
||||
grep {
|
||||
$_->content_type ne 'text/plain' and $_->content_type ne 'text/html'
|
||||
} $alt_part->parts
|
||||
);
|
||||
|
||||
# Anything left is either text or html
|
||||
my ( $html_part, $text_part );
|
||||
for ( $alt_part->parts ) {
|
||||
if ( $_->content_type eq 'text/html' ) {
|
||||
$html_part = $_;
|
||||
}
|
||||
else {
|
||||
$text_part = $_;
|
||||
}
|
||||
}
|
||||
# If we do not have an editble part we need to make an empty html one
|
||||
if ( !defined( $text_part ) and !defined( $html_part ) ) {
|
||||
$html_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"',
|
||||
-body_data => '<html><body></body></html>'
|
||||
);
|
||||
}
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $html_part,
|
||||
text => $text_part,
|
||||
charset => $self->{fields}{charset}
|
||||
);
|
||||
if ( $alt_part == $root_part ) {
|
||||
$root_part->set( 'content-type' => 'multipart/mixed' );
|
||||
$self->{message}->delete_parts( $root_part->parts );
|
||||
$root_part->parts( $new_alt );
|
||||
}
|
||||
else {
|
||||
$self->{message}->replace_part( $alt_part, $new_alt );
|
||||
}
|
||||
}
|
||||
|
||||
sub munge_other {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
|
||||
# Else we need to search through the parts to find the displayable parts
|
||||
my ( $html_part, $text_part );
|
||||
for my $part ( $self->{message}->all_parts ) {
|
||||
if ( !$html_part and $part->content_type eq 'text/html' and $part->mime_attr( 'content-disposition' ) ne 'attachment' ) {
|
||||
$html_part = $part;
|
||||
}
|
||||
elsif ( !$text_part and $part->content_type eq 'text/plain' and $part->mime_attr( 'content-disposition' ) ne 'attachment' ) {
|
||||
$text_part = $part;
|
||||
}
|
||||
last if $html_part and $text_part;
|
||||
}
|
||||
# If we do not have an editble part we need to make an empty html one
|
||||
if ( !defined( $text_part ) and !defined( $html_part ) ) {
|
||||
$html_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"',
|
||||
-body_data => '<html><body></body></html>'
|
||||
);
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $html_part,
|
||||
text => $text_part,
|
||||
charset => $self->{fields}{charset}
|
||||
);
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $new_alt );
|
||||
my $parent = $self->{message}->parent_part( $new_alt );
|
||||
if ( $parent and $parent->content_type eq 'multipart/related' ) {
|
||||
$parent->set( 'content-type' => 'multipart/mixed' );
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $html_part,
|
||||
text => $text_part,
|
||||
charset => $self->{fields}{charset}
|
||||
);
|
||||
my $parent_part = $self->{message}->parent_part( $html_part );
|
||||
if ( !$parent_part ) { $parent_part = $self->{message}->parent_part( $text_part ) }
|
||||
if ( $parent_part and $parent_part->content_type eq 'multipart/related' ) {
|
||||
if ( !$html_part ) {
|
||||
$parent_part->set( 'content-type' => 'multipart/mixed' );
|
||||
$self->{message}->add_parts_start( $parent_part, $new_alt );
|
||||
if ( $text_part ) {
|
||||
$self->{message}->delete_part( $text_part );
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{message}->replace_part( $parent_part->parts->[0], $new_alt );
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ( $text_part ) {
|
||||
$self->{message}->delete_part( $text_part );
|
||||
}
|
||||
if ( $html_part ) {
|
||||
$self->{message}->delete_part( $html_part );
|
||||
}
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $new_alt );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub alt_part {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, %opts ) = @_;
|
||||
my ( $text, $html, $header_from, $charset ) = @opts{qw/text html headers_part charset/};
|
||||
|
||||
my $text_type = 'text/plain; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"';
|
||||
my $html_type = 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"';
|
||||
|
||||
if ( defined( $text ) ) {
|
||||
$text = $self->new_part_from( $text, $text_type );
|
||||
}
|
||||
elsif ( defined( $html ) ) {
|
||||
$text = $self->{message}->new_part(
|
||||
'content-type' => $text_type,
|
||||
-body_data => $self->html_to_text( ref( $html ) ? $html->body_data : $html )
|
||||
);
|
||||
}
|
||||
else {
|
||||
$self->fatal( BADARGS => "Either text or html must be defined" );
|
||||
}
|
||||
if ( defined( $html ) ) {
|
||||
$html = $self->new_part_from( $html, $html_type );
|
||||
}
|
||||
elsif ( defined( $text ) ) {
|
||||
$html = $self->{message}->new_part(
|
||||
'content-type' => $html_type,
|
||||
-body_data => $self->text_to_html( $text->body_data )
|
||||
);
|
||||
}
|
||||
# logic error, one must be defined
|
||||
else {
|
||||
$self->fatal( BADARGS => "Either text or html must be defined" );
|
||||
}
|
||||
my @header = ();
|
||||
if ( $header_from ) {
|
||||
@header = map { $_ => [$header_from->get( $_ )] } $header_from->get;
|
||||
}
|
||||
return $self->{message}->new_part(
|
||||
@header,
|
||||
'content-type' => 'multipart/alternative',
|
||||
-parts => [$text, $html]
|
||||
);
|
||||
}
|
||||
|
||||
sub new_part_from {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $from, $type ) = @_;
|
||||
if ( !ref( $from ) ) {
|
||||
return $self->{message}->new_part(
|
||||
'content-type' => $type,
|
||||
-body_data => $from
|
||||
);
|
||||
}
|
||||
elsif ( ref( $from ) ) {
|
||||
return $self->{message}->new_part(
|
||||
'content-type' => $type,
|
||||
-body_data => $from->body_data
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
147
site/glist/lib/GT/Mail/Editor/Text.pm
Normal file
147
site/glist/lib/GT/Mail/Editor/Text.pm
Normal file
@@ -0,0 +1,147 @@
|
||||
|
||||
package GT::Mail::Editor::Text;
|
||||
|
||||
use vars qw/$ERROR_MESSAGE/;
|
||||
use strict;
|
||||
use bases 'GT::Mail::Editor' => '';
|
||||
|
||||
$ERROR_MESSAGE = 'GT::Mail::Editor';
|
||||
|
||||
sub display {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $tags ) = @_;
|
||||
my $page = $self->{text_tpl_name};
|
||||
|
||||
if ( $self->{fields}{page} and $self->{fields}{page} =~ /^(?:editor|email)_/ ) {
|
||||
$page = $self->{fields}{page};
|
||||
}
|
||||
my $ret = $self->print_page( $page, $tags );
|
||||
$self->{displayed} = 1;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub message_from_input {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
$self->set_headers;
|
||||
|
||||
# If we have a part ID, this isn't a new text part
|
||||
my ( $part, $id );
|
||||
$part = $self->{part};
|
||||
$part->set( 'content-type' => 'text/plain; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"' );
|
||||
if ( exists( $self->{fields}{msg} ) ) {
|
||||
$part->body_data( $self->{fields}{msg} );
|
||||
}
|
||||
}
|
||||
|
||||
sub munge_message {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $root_part = $self->{message}->root_part;
|
||||
|
||||
# Simple case if the message is not multipart
|
||||
my ( $text_part, $html_part, $related_part, $alt_part );
|
||||
if ( !$root_part->is_multipart ) {
|
||||
$text_part = $root_part;
|
||||
}
|
||||
|
||||
# We have a multipart. First thing we do is look for an alternative part
|
||||
# to use.
|
||||
else {
|
||||
|
||||
# First we look for the proper alternative mime parts
|
||||
$alt_part = ($self->{message}->find_multipart( 'alternative' ))[0];
|
||||
if ( $alt_part ) {
|
||||
my @alt_parts = $alt_part->parts;
|
||||
for ( @alt_parts ) {
|
||||
if ( $_->content_type eq 'text/plain' ) {
|
||||
$text_part = $self->{message}->delete_part( $_ );
|
||||
}
|
||||
elsif ( $_->content_type eq 'text/html' ) {
|
||||
$html_part = $self->{message}->delete_part( $_ );
|
||||
}
|
||||
}
|
||||
if ( !$text_part and $html_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => $self->html_to_text( $html_part->body_data )
|
||||
);
|
||||
}
|
||||
elsif ( !$text_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => ''
|
||||
);
|
||||
}
|
||||
|
||||
# Make anything we can not view an attachment
|
||||
$self->{message}->move_parts_last(
|
||||
$root_part,
|
||||
map {
|
||||
unless ( $_->is_multipart ) {
|
||||
$_->set( 'content-disposition' => 'attachment' );
|
||||
}
|
||||
$_;
|
||||
} $alt_part->parts
|
||||
);
|
||||
|
||||
if ( $alt_part == $root_part ) {
|
||||
$alt_part->set( 'content-type' => 'multipart/mixed' );
|
||||
}
|
||||
else {
|
||||
$self->{message}->delete_part( $alt_part );
|
||||
}
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $text_part );
|
||||
}
|
||||
else {
|
||||
|
||||
# Else we can just stick the text part at the beginning
|
||||
for my $part ( $self->{message}->all_parts ) {
|
||||
my $disp = $part->mime_attr( 'content-disposition' );
|
||||
next if $disp and $disp eq 'attachment';
|
||||
if ( $part->content_type eq 'text/plain' ) {
|
||||
$text_part = $self->{message}->delete_part( $part );
|
||||
}
|
||||
elsif ( $part->content_type eq 'text/html' ) {
|
||||
$html_part = $self->{message}->delete_part( $part );
|
||||
}
|
||||
}
|
||||
if ( !$text_part and $html_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => $self->html_to_text( $html_part->body_data )
|
||||
);
|
||||
}
|
||||
elsif ( !$text_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => ''
|
||||
);
|
||||
}
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $text_part );
|
||||
}
|
||||
}
|
||||
my $parent = $self->{message}->parent_part( $text_part );
|
||||
if ( $parent and $parent->content_type eq 'multipart/related' ) {
|
||||
$parent->set( 'content-type' => 'multipart/mixed' );
|
||||
}
|
||||
$self->fix_alt_parts;
|
||||
$self->fix_related_parts;
|
||||
$self->delete_empty_multiparts;
|
||||
$self->find_attachments( $text_part );
|
||||
|
||||
if ( @{[$self->{message}->all_parts]} == 1 and $self->{message}->root_part->is_multipart ) {
|
||||
$self->{message}->delete_part( $text_part );
|
||||
my $root_part = $self->{message}->root_part;
|
||||
$root_part->set( 'content-type' => 'text/plain' );
|
||||
$root_part->body_data( $text_part->body_data );
|
||||
}
|
||||
$self->{part} = $text_part;
|
||||
}
|
||||
|
||||
sub html_part { return }
|
||||
sub text_part { return shift()->{part} }
|
||||
|
||||
1;
|
||||
|
||||
429
site/glist/lib/GT/Mail/Encoder.pm
Normal file
429
site/glist/lib/GT/Mail/Encoder.pm
Normal file
@@ -0,0 +1,429 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Encoder
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Encoder.pm,v 1.40 2004/01/13 01:35:17 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface for encoding data.
|
||||
#
|
||||
|
||||
package GT::Mail::Encoder;
|
||||
# ==================================================================
|
||||
# If MIME::Base64 is installed use it - must eval before hand or 5.004_04
|
||||
# wipes our ISA.
|
||||
my $have_b64 = eval {
|
||||
local $SIG{__DIE__};
|
||||
require MIME::Base64;
|
||||
import MIME::Base64;
|
||||
if ($] < 5.005) { local $^W; encode_base64('brok'); }
|
||||
1;
|
||||
};
|
||||
$have_b64 or *encode_base64 = \>_old_encode_base64;
|
||||
my $use_encode_qp;
|
||||
if ($have_b64 and
|
||||
$MIME::Base64::VERSION >= 2.16 and
|
||||
defined &MIME::QuotedPrint::encode_qp and (
|
||||
not defined &MIME::QuotedPrint::old_encode_qp or
|
||||
\&MIME::QuotedPrint::encode_qp != \&MIME::QuotedPrint::old_encode_qp
|
||||
)
|
||||
) {
|
||||
$use_encode_qp = 1;
|
||||
}
|
||||
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw($VERSION $DEBUG @ISA %EncodeFor $CRLF);
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.40 $ =~ /(\d+)\.(\d+)/;
|
||||
$CRLF = "\015\012";
|
||||
$DEBUG = 0;
|
||||
@ISA = qw(GT::Base);
|
||||
|
||||
my %EncoderFor = (
|
||||
# Standard...
|
||||
'7bit' => sub { NBit('7bit', @_) },
|
||||
'8bit' => sub { NBit('8bit', @_) },
|
||||
'base64' => \&Base64,
|
||||
'binary' => \&Binary,
|
||||
'none' => \&Binary,
|
||||
'quoted-printable' => \&QuotedPrint,
|
||||
|
||||
# Non-standard...
|
||||
'x-uu' => \&UU,
|
||||
'x-uuencode' => \&UU,
|
||||
);
|
||||
|
||||
sub new {
|
||||
# --------------------------------------------------------------------------
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {}, $class;
|
||||
$self->init(@_);
|
||||
my $encoding = lc($self->{encoding} || '');
|
||||
defined $EncoderFor{$encoding} or return or return $self->error("NOENCODING", "FATAL");
|
||||
$self->debug("Set encoding to $encoding") if ($self->{_debug});
|
||||
$self->{encoding} = $EncoderFor{$encoding};
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->init (%opts);
|
||||
# -------------------
|
||||
# Sets the options for the current object.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift }
|
||||
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
else { return $self->error("BADARGS", "FATAL", "init") }
|
||||
|
||||
$self->{_debug} = exists($opt->{debug}) ? $opt->{debug} : $DEBUG;
|
||||
for my $m (qw(encoding in out)) {
|
||||
$self->{$m} = $opt->{$m} if defined $opt->{$m};
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub gt_encode {
|
||||
# --------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (!ref $self or ref $self ne 'GT::Mail::Encoder') {
|
||||
$self = GT::Mail::Encoder->new(@_) or return;
|
||||
}
|
||||
$self->{encoding} or return $self->error("NOENCODING", "FATAL");;
|
||||
return $self->{encoding}->($self->{in}, $self->{out});
|
||||
}
|
||||
|
||||
sub supported { return exists $EncoderFor{pop()} }
|
||||
|
||||
|
||||
sub Base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out) = @_;
|
||||
my $encoded;
|
||||
|
||||
my $nread;
|
||||
my $buf = '';
|
||||
|
||||
# Reading multiples of 57 bytes is recommended by MIME::Base64 as it comes out
|
||||
# to a line of exactly 76 characters (the max). We use 2299*57 (131043 bytes)
|
||||
# because it comes out to about 128KB (131072 bytes). Admittedly, this number
|
||||
# is fairly arbitrary, but should work well for both large and small files, and
|
||||
# shouldn't be too memory intensive.
|
||||
my $read_size = 2299 * 57;
|
||||
|
||||
if (not ref $in) {
|
||||
while (1) {
|
||||
last unless length $in;
|
||||
$buf = substr($in, 0, $read_size);
|
||||
substr($in, 0, $read_size) = '';
|
||||
|
||||
$encoded = encode_base64($buf, $CRLF);
|
||||
|
||||
# Encoding to send over SMTP
|
||||
$encoded .= $CRLF unless $encoded =~ /$CRLF\Z/; # ensure newline!
|
||||
$out->($encoded);
|
||||
}
|
||||
}
|
||||
elsif (fileno $in) {
|
||||
while ($nread = read($in, $buf, $read_size)) {
|
||||
$encoded = encode_base64($buf, $CRLF);
|
||||
|
||||
$encoded .= $CRLF unless $encoded =~ /$CRLF\Z/; # ensure newline!
|
||||
$out->($encoded);
|
||||
}
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to Base64, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub Binary {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out) = @_;
|
||||
|
||||
if (not ref $in) {
|
||||
$in =~ s/\015?\012/$CRLF/g;
|
||||
$out->($in);
|
||||
}
|
||||
elsif (fileno $in) {
|
||||
my ($buf, $nread) = ('', 0);
|
||||
while ($nread = read($in, $buf, 4096)) {
|
||||
$buf =~ s/\015?\012/$CRLF/g;
|
||||
$out->($buf);
|
||||
}
|
||||
defined ($nread) or return; # check for error
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to Binary, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub UU {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out, $file) = @_;
|
||||
|
||||
my $buf = '';
|
||||
my $fname = ($file || '');
|
||||
$out->("begin 644 $fname\n");
|
||||
if (not ref $in) {
|
||||
while (1) {
|
||||
last unless length $in;
|
||||
$buf = substr($in, 0, 45);
|
||||
substr($in, 0, 45) = '';
|
||||
$out->(pack('u', $buf));
|
||||
}
|
||||
}
|
||||
elsif (fileno $in) {
|
||||
while (read($in, $buf, 45)) {
|
||||
$buf =~ s/\015?\012/$CRLF/g;
|
||||
$out->(pack('u', $buf))
|
||||
}
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to UU, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
$out->("end\n");
|
||||
1;
|
||||
}
|
||||
|
||||
sub NBit {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($enc, $in, $out) = @_;
|
||||
|
||||
if (not ref $in) {
|
||||
$in =~ s/\015?\012/$CRLF/g;
|
||||
$out->($in);
|
||||
}
|
||||
elsif (fileno $in) {
|
||||
while (<$in>) {
|
||||
s/\015?\012/$CRLF/g;
|
||||
$out->($_);
|
||||
}
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to NBit, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub QuotedPrint {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out) = @_;
|
||||
|
||||
local $_;
|
||||
my $ref = ref $in;
|
||||
if ($ref and !fileno($in)) {
|
||||
if ($ref eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to QuotedPrint, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
}
|
||||
$in =~ s/\015?\012/\n/g unless $ref;
|
||||
|
||||
while () {
|
||||
local $_;
|
||||
if ($ref) {
|
||||
# Try to get around 32KB at once. This could end up being much larger than
|
||||
# 32KB if there is a very very long line - up to the length of the line + 32700
|
||||
# bytes.
|
||||
$_ = <$in>;
|
||||
while (my $line = <$in>) {
|
||||
$_ .= $line;
|
||||
last if length > 32_700; # Not exactly 32KB, but close enough.
|
||||
}
|
||||
last unless defined;
|
||||
}
|
||||
else {
|
||||
# Grab up to just shy of 32KB of the string, plus the following line. As
|
||||
# above, this could be much longer than 32KB if there is one or more very long
|
||||
# lines involved.
|
||||
$in =~ s/^(.{0,32700}.*?(?:\n|\Z))//ms; # Encode somewhere around 32KB at a time
|
||||
$_ = $1;
|
||||
last unless defined and length;
|
||||
}
|
||||
|
||||
if ($use_encode_qp) {
|
||||
$_ = MIME::QuotedPrint::encode_qp($_, $CRLF);
|
||||
}
|
||||
else {
|
||||
s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3
|
||||
s/([ \t]+)$/
|
||||
join('', map { sprintf("=%02X", ord($_)) }
|
||||
split('', $1)
|
||||
)/egm; # rule #3 (encode whitespace at eol)
|
||||
|
||||
# rule #5 (lines must be shorter than 76 chars, but we are not allowed
|
||||
# to break =XX escapes. This makes things complicated :-( )
|
||||
my $brokenlines = "";
|
||||
$brokenlines .= "$1=\n"
|
||||
while s/(.*?^[^\n]{73} (?:
|
||||
[^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
|
||||
|[^=\n] (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
|
||||
| (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
|
||||
))//xsm;
|
||||
|
||||
$_ = "$brokenlines$_";
|
||||
|
||||
s/\015?\012/$CRLF/g;
|
||||
}
|
||||
|
||||
# Escape 'From ' at the beginning of the line. This is fairly easy - if the
|
||||
# line is currently 73 or fewer characters, we simply change the F to =46,
|
||||
# making the line 75 characters long (the max). If the line is longer than 73,
|
||||
# we escape the F, follow it with "=$CRLF", and put the 'rom ' and the rest of
|
||||
# the line on the next line - meaning one line of 4 characters, and one of 73
|
||||
# or 74.
|
||||
s/^From (.*)/
|
||||
length($1) <= 68 ? "=46rom $1" : "=46=${CRLF}rom $1"
|
||||
/emg; # Escape 'From' at the beginning of a line
|
||||
# The '.' at the beginning of the line is more difficult. The easy case is
|
||||
# when the line is 73 or fewer characters - just escape the initial . and we're
|
||||
# done. If the line is longer, the fun starts. First, we escape the initial .
|
||||
# to =2E. Then we look for the first = in the line; if it is found within the
|
||||
# first 3 characters, we split two characters after it (to catch the "12" in
|
||||
# "=12") otherwise we split after the third character. We then add "=$CRLF" to
|
||||
# the current line, and look at the next line; if it starts with 'From ' or a
|
||||
# ., we escape it - and since the second line will always be less than 73
|
||||
# characters long (since we remove at least three for the first line), we can
|
||||
# just escape it without worrying about splitting the line up again.
|
||||
s/^\.([^$CRLF]*)/
|
||||
if (length($1) <= 72) {
|
||||
"=2E$1"
|
||||
}
|
||||
else {
|
||||
my $ret = "=2E";
|
||||
my $match = $1;
|
||||
my $index = index($match, '=');
|
||||
my $len = $index >= 2 ? 2 : $index + 3;
|
||||
$ret .= substr($match, 0, $len);
|
||||
substr($match, 0, $len) = '';
|
||||
$ret .= "=$CRLF";
|
||||
substr($match, 0, 1) = "=46" if substr($match, 0, 5) eq 'From ';
|
||||
substr($match, 0, 1) = "=2E" if substr($match, 0, 1) eq '.';
|
||||
$ret .= $match;
|
||||
$ret
|
||||
}
|
||||
/emg;
|
||||
|
||||
$out->($_);
|
||||
|
||||
last unless $ref or length $in;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub gt_old_encode_base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my $eol = $_[1];
|
||||
$eol = "\n" unless defined $eol;
|
||||
|
||||
my $res = pack("u", $_[0]);
|
||||
$res =~ s/^.//mg; # Remove first character of each line
|
||||
$res =~ tr/\n//d; # Remove newlines
|
||||
|
||||
$res =~ tr|` -_|AA-Za-z0-9+/|;
|
||||
|
||||
# Fix padding at the end
|
||||
my $padding = (3 - length($_[0]) % 3) % 3;
|
||||
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
|
||||
|
||||
# Break encoded string into lines of no more than 76 characters each
|
||||
if (length $eol) {
|
||||
$res =~ s/(.{1,76})/$1$eol/g;
|
||||
}
|
||||
$res;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Encoder - MIME Encoder
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
open IN, 'decoded.txt' or die $!;
|
||||
open OUT, '>encoded.txt' or die $!;
|
||||
if (GT::Mail::Encoder->supported ('7bit')) {
|
||||
GT::Mail::Encoder->decode (
|
||||
debug => 1,
|
||||
encoding => '7bit',
|
||||
in => \*IN,
|
||||
out => sub { print OUT $_[0] }
|
||||
) or die $GT::Mail::Encoder::error;
|
||||
}
|
||||
else {
|
||||
die "Unsupported encoding";
|
||||
}
|
||||
close IN;
|
||||
close OUT;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Encoder is a MIME Encoder implemented in perl. It will try to use
|
||||
the C extension for encoding Base64. If the extension is not there
|
||||
it will do it in perl (slow!).
|
||||
|
||||
=head2 Encoding a stream
|
||||
|
||||
The new() constructor and the supported() class method are the only methods that
|
||||
are public in the interface. The new() constructor takes a hash of params.
|
||||
The supported() method takes a single string, the name of the encoding you want
|
||||
to encode and returns true if the encoding is supported and false otherwise.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Set debugging level. 1 or 0.
|
||||
|
||||
=item encoding
|
||||
|
||||
Sets the encoding used to encode.
|
||||
|
||||
=item in
|
||||
|
||||
Set to a file handle or IO handle.
|
||||
|
||||
=item out
|
||||
|
||||
Set to a code reference, the decoded stream will be passed in at the first
|
||||
argument for each chunk encoded.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Encoder.pm,v 1.40 2004/01/13 01:35:17 jagerman Exp $
|
||||
|
||||
|
||||
672
site/glist/lib/GT/Mail/Message.pm
Normal file
672
site/glist/lib/GT/Mail/Message.pm
Normal file
@@ -0,0 +1,672 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Message
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::Mail::Message;
|
||||
|
||||
use strict;
|
||||
use vars qw/$ATTRIBS $CRLF/;
|
||||
use bases 'GT::Base' => '';
|
||||
|
||||
$ATTRIBS = {
|
||||
root_part => undef,
|
||||
debug => 0
|
||||
};
|
||||
|
||||
$CRLF = "\012";
|
||||
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------------
|
||||
# Init called from GT::Base
|
||||
my $self = shift;
|
||||
|
||||
$self->set( @_ );
|
||||
|
||||
if ( !defined( $self->{root_part} ) ) {
|
||||
$self->{root_part} = new GT::Mail::Parts;
|
||||
}
|
||||
$self->{parts} = _get_parts( $self->{root_part} );
|
||||
}
|
||||
|
||||
|
||||
sub delete_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Deletes the given part from the email
|
||||
#
|
||||
my ( $self, $part ) = @_;
|
||||
|
||||
die "Can't delete top level part" if $part == $self->{root_part};
|
||||
$self->_link;
|
||||
|
||||
|
||||
# We must remove it from the flat list of parts
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Now we must relink our list
|
||||
$self->_link;
|
||||
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub move_part_before {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part before another part. The first argument is the part to move
|
||||
# before, the second is the part to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $before_part, $part ) = @_;
|
||||
die "Can't move part before the top part" if $before_part == $self->{root_part};
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $before_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Now we add
|
||||
$self->add_part_before( $before_part, $part );
|
||||
}
|
||||
|
||||
sub move_part_after {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part after another part. The first argument is the part to move
|
||||
# after, the second is the part to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $after_part, $part ) = @_;
|
||||
die "Can't move part after the top part" if $after_part == $self->{root_part};
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $after_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Now we add
|
||||
$self->add_part_after( $after_part, $part );
|
||||
}
|
||||
|
||||
sub move_part_end {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part to the end of a multipart part. The first part is the
|
||||
# multipart part to move it to the end of. The second argument is the part
|
||||
# to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part to be moved
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Then we add it back in
|
||||
$self->add_part_end( $parent_part, $part );
|
||||
}
|
||||
|
||||
sub move_part_beginning {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part to the beginning of a multipart part. The first part is the
|
||||
# multipart part to move it to the beginning of. The second argument is the
|
||||
# part to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part to be moved
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Then we add it back in
|
||||
$self->add_part_beginning( $parent_part, $part );
|
||||
}
|
||||
|
||||
sub replace_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Replace a part with another part
|
||||
#
|
||||
my ( $self, $old_part, $new_part ) = @_;
|
||||
$self->_link;
|
||||
splice( @{$self->{parts}}, $old_part->{id}, 1, $new_part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_before {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part before the given part. The first argument is the part object
|
||||
# to add the part before. the second argument is the part to add.
|
||||
#
|
||||
my ( $self, $before_part, $part ) = @_;
|
||||
$self->_link;
|
||||
die "Can't add part before the top level part" if $before_part == $self->{root_part};
|
||||
my $parent_id = $before_part->{parent_id};
|
||||
|
||||
if ( !defined $parent_id or !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The part's parent must exist and must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $before_part->{id}, 0, $part );
|
||||
my $parent_part = $self->{parts}[$parent_id];
|
||||
$parent_part->add_parts_before( $before_part->{id}, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_after {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part after the given part. The first argument is the part object
|
||||
# to add the part after. the second argument is the part to add.
|
||||
#
|
||||
my ( $self, $after_part, $part ) = @_;
|
||||
$self->_link;
|
||||
die "Can't add part after the top level part" if $after_part == $self->{root_part};
|
||||
my $parent_id = $after_part->{parent_id};
|
||||
|
||||
if ( !defined $parent_id or !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The part's parent must exist and must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $after_part->{id} + 1, 0, $part );
|
||||
my $parent_part = $self->{parts}[$parent_id];
|
||||
$parent_part->add_parts_after( $after_part->{id}, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_beginning {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part at the beginning of the given multipart part. The first
|
||||
# argument is the part object to add the part before. the second argument is
|
||||
# the part to add.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
$self->_link;
|
||||
my $parent_id = $parent_part->{id};
|
||||
|
||||
if ( !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The parent part must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $parent_id + 1, 0, $part );
|
||||
$parent_part->add_part_before( $part->{parts}[0]{id}, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_end {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part at the end of the given multipart part. The first argument is
|
||||
# the part object to add the part at the end of. the second argument is the
|
||||
# part to add. The first argument must be a multipart part or a fatal error
|
||||
# occurs.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
$self->_link;
|
||||
my $parent_id = $parent_part->{id};
|
||||
|
||||
if ( !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The parent part must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $parent_id + @parts, 0, $part );
|
||||
$parent_part->parts( $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub move_part_to_position {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part to a position within another multipart part. The first
|
||||
# argument is the part to move within, the second argument is the part to
|
||||
# move and the final argument is the position within those parts to move it
|
||||
# in.
|
||||
#
|
||||
my ( $self, $parent_part, $part, $pos ) = @_;
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
$self->_link;
|
||||
my $parent_id = $parent_part->{id};
|
||||
|
||||
if ( !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The parent part must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $parent_id + $pos, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub get_part_by_id {
|
||||
# --------------------------------------------------------------------------
|
||||
# Method to retrieve a part object by it's id
|
||||
#
|
||||
my ( $self, $id ) = @_;
|
||||
|
||||
return $self->{parts}[$id];
|
||||
}
|
||||
|
||||
sub new_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Method to easily create a part object. All the header fields can be passed
|
||||
# in as a hash. If the key "body_data" the value will be set as the parts
|
||||
# body rather than a header field.
|
||||
#
|
||||
my ( $self, @opts ) = @_;
|
||||
my $part = new GT::Mail::Parts;
|
||||
while ( my ( $key, $val ) = ( shift( @opts ), shift( @opts ) ) ) {
|
||||
if ( $key eq 'body_data' ) {
|
||||
$part->body_data( $val );
|
||||
}
|
||||
elsif ( $key eq 'body_handle' ) {
|
||||
$part->body_handle( $val );
|
||||
}
|
||||
elsif ( $key eq 'body_path' ) {
|
||||
$part->body_path( $val );
|
||||
}
|
||||
else {
|
||||
$part->set( $key => $val );
|
||||
}
|
||||
}
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub all_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# my @parts = $obj->all_parts;
|
||||
# ----------------------------
|
||||
# Returns a list of all the part object for the current parsed email.
|
||||
# If the email is not multipart this will be just the header part.
|
||||
#
|
||||
return @{shift()->{parts}}
|
||||
}
|
||||
|
||||
sub size {
|
||||
# --------------------------------------------------------------------------
|
||||
# Returns the total size of an email. Call this method after the email has
|
||||
# been parsed.
|
||||
#
|
||||
my $self = shift;
|
||||
(@{$self->{parts}} > 0) or return;
|
||||
my $size = 0;
|
||||
foreach (@{$self->{parts}}) {
|
||||
$size += $_->size;
|
||||
}
|
||||
return $size;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
# --------------------------------------------------------------------------
|
||||
# Returns the entire email as a sting.
|
||||
#
|
||||
my ( $self ) = @_;
|
||||
$GT::Mail::Encoder::CRLF = $CRLF;
|
||||
|
||||
my $out;
|
||||
$$out = ' ' x 50*1024;
|
||||
$self->debug ("\n\t--------------> Creating email") if $self->{_debug};
|
||||
|
||||
# Need the head to contiue
|
||||
$self->{root_part} or die "No root part!";
|
||||
$self->{root_part}->set( 'MIME-Version' => '1.0' ) unless $self->{root_part}->get( 'MIME-Version' );
|
||||
|
||||
my $bound = $self->{root_part}->multipart_boundary;
|
||||
|
||||
# If the message has parts
|
||||
|
||||
if ( @{$self->{root_part}->{parts}} > 0 ) {
|
||||
$self->debug( "Creating multipart email." ) if $self->{_debug};
|
||||
$self->_build_multipart_head( $out );
|
||||
}
|
||||
|
||||
# Else we are single part and have either a body IO handle or the body is in memory
|
||||
else {
|
||||
$self->debug( "Creating singlepart email." ) if $self->{_debug};
|
||||
$self->_build_singlepart_head( $out );
|
||||
}
|
||||
|
||||
# If we have parts go through all of them and add them.
|
||||
if ( @{$self->{root_part}->{parts}} > 0 ) {
|
||||
my $num_parts = $#{$self->{root_part}->{parts}};
|
||||
for my $num ( 0 .. $num_parts ) {
|
||||
next unless $self->{root_part}->{parts}->[$num];
|
||||
$self->debug( "Creating part ($num)." ) if $self->{_debug};
|
||||
$self->_build_parts( $out, $self->{root_part}->{parts}->[$num] );
|
||||
if ( $num_parts == $num ) {
|
||||
$self->debug( "Boundary\n\t--$bound--" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . '--' . $CRLF;
|
||||
}
|
||||
else {
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . $CRLF;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Add the epilogue if we are multipart
|
||||
if ( @{$self->{root_part}->{parts}} > 0 ) {
|
||||
my $epilogue = join( '', @{$self->{root_part}->epilogue || []} ) || '';
|
||||
$epilogue =~ s/\015?\012//g;
|
||||
$self->debug( "Setting epilogue to ($epilogue)" ) if $self->{_debug};
|
||||
$$out .= $epilogue . $CRLF . $CRLF if $epilogue;
|
||||
}
|
||||
$self->debug( "\n\t<-------------- Email created." ) if $self->{_debug};
|
||||
return $$out;
|
||||
}
|
||||
|
||||
sub _build_multipart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a multipart header.
|
||||
#
|
||||
my ( $self, $out ) = @_;
|
||||
my $bound = $self->{root_part}->multipart_boundary;
|
||||
my $encoding = $self->{root_part}->suggest_encoding;
|
||||
$self->debug( "Setting encoding to ($encoding)." ) if ( $self->{debug} );
|
||||
$self->{root_part}->set( 'Content-Transfer-Encoding' => $encoding );
|
||||
$bound or $bound = "---------=_" . scalar (time) . "-$$-" . int(rand(time)/2);
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $self->{root_part}->get( 'Content-Type' );
|
||||
if ( $c !~ /\Q$bound/i ) {
|
||||
if ( $c and lc( $c ) !~ /boundary=/ ) {
|
||||
$c =~ /multipart/ or $c = 'multipart/mixed';
|
||||
$self->debug( qq|Setting content type to ($c; boundary="$bound")| ) if $self->{debug};
|
||||
$self->{root_part}->set( 'Content-Type' => $c . qq|; boundary="$bound"| );
|
||||
}
|
||||
else {
|
||||
$self->debug( "Setting multipart boundary to ($bound)." ) if $self->{_debug};
|
||||
$self->{root_part}->set( 'Content-Type' => qq!multipart/mixed; boundary="$bound"! )
|
||||
}
|
||||
}
|
||||
|
||||
my $preamble = join( '', @{$self->{root_part}->preamble || []} ) || "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug( "Setting preamble to ($preamble)." ) if ( $self->{_debug} );
|
||||
( my $head = $self->{root_part}->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $head . $CRLF . $preamble . $CRLF . $CRLF . '--' . $bound . $CRLF;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_singlepart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a single part header.
|
||||
#
|
||||
my ( $self, $out ) = @_;
|
||||
my $encoding = $self->{root_part}->suggest_encoding;
|
||||
$self->debug( "Setting encoding to ($encoding)." ) if $self->{_debug};
|
||||
$self->{root_part}->set( 'Content-Transfer-Encoding' => $encoding );
|
||||
( my $head = $self->{root_part}->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$$out .= $head . $CRLF;
|
||||
$self->debug( "Encoding body with ($encoding)." ) if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode (
|
||||
debug => $self->{_debug},
|
||||
encoding => $encoding,
|
||||
in => $self->{root_part}->body_as_string,
|
||||
out => $out
|
||||
) or return;
|
||||
|
||||
# Must seek to the beginning for additional calles
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method that builds the parts for the email.
|
||||
#
|
||||
my ($self, $out, $part) = @_;
|
||||
|
||||
# Need the head to contiue
|
||||
$self->{root_part} or die "No root part!";
|
||||
|
||||
my ( $body, $encoding, $bound );
|
||||
$bound = $part->multipart_boundary;
|
||||
|
||||
|
||||
# Find the encoding for the part and set it.
|
||||
$encoding = $part->suggest_encoding;
|
||||
$self->debug( "Setting encoding to ($encoding)." ) if $self->{_debug};
|
||||
$part->set( 'Content-Transfer-Encoding' => $encoding );
|
||||
|
||||
# If the message has parts and has a multipart boundary
|
||||
if ( @{$part->{parts}} > 0 and $bound ) {
|
||||
$self->debug( "Part is multpart." ) if $self->{_debug};
|
||||
|
||||
# Set the multipart boundary
|
||||
$self->debug( "Setting boundary to ($bound)." ) if $self->{_debug};
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $part->get( 'Content-Type' );
|
||||
if ( $c ) {
|
||||
$self->debug( qq|Setting content type to ($c; boundary="$bound")| ) if $self->{_debug};
|
||||
$part->set( 'Content-Type' => $c . qq|; boundary="$bound"| );
|
||||
}
|
||||
else {
|
||||
$self->debug( "Setting multipart boundary to ($bound)." ) if $self->{_debug};
|
||||
$part->set( 'Content-Type' => qq!multipart/mixed; boundary="$bound"! );
|
||||
}
|
||||
|
||||
my $preamble = join( '' => @{ $part->preamble || [] } ) || "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug( "Setting preamble to ($preamble)." ) if $self->{_debug};
|
||||
( my $head = $part->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $head . $CRLF . $preamble . $CRLF . '--' . $bound . $CRLF;
|
||||
}
|
||||
else {
|
||||
$self->debug( "Part is single part." ) if $self->{_debug};
|
||||
( my $head = $part->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$$out .= $head . $CRLF;
|
||||
|
||||
# Set the body only if we have one. We would not have one on the head an multipart
|
||||
$self->debug( "Encoding body with ($encoding)." ) if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode(
|
||||
encoding => $encoding,
|
||||
debug => $self->{_debug},
|
||||
in => $part->body_as_string,
|
||||
out => $out
|
||||
) or return;
|
||||
|
||||
}
|
||||
|
||||
# Add the rest of the parts
|
||||
if ( @{$part->{parts}} > 0 ) {
|
||||
$self->debug( "Part has parts." ) if $self->{_debug};
|
||||
my $num_parts = $#{$part->{parts}};
|
||||
for my $num ( 0 .. $num_parts ) {
|
||||
next unless $part->{parts}->[$num];
|
||||
$self->debug( "Creating part ($num)." ) if $self->{_debug};
|
||||
$self->_build_parts( $out, $part->{parts}->[$num] ) or return;
|
||||
if ( $bound ) {
|
||||
if ( $num_parts == $num ) {
|
||||
$self->debug( "Boundary\n\t--$bound--" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . '--' . $CRLF;
|
||||
}
|
||||
else {
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . $CRLF;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Maybe done!
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _delete_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal method to delete a part
|
||||
my ( $self, $part ) = @_;
|
||||
|
||||
# We must remove it from it's parent
|
||||
my $parent = $self->{parts}[$part->{parent_id}];
|
||||
for ( 0 .. $#{$parent->{parts}} ) {
|
||||
if ( $parent->{parts}[$_]{id} == $part->{id} ) {
|
||||
splice( @{$parent->{parts}}, $_, 1 );
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
# We must remove it from the flat list of parts
|
||||
return splice( @{$self->{parts}}, $part->{id}, 1 );
|
||||
}
|
||||
|
||||
sub _part_in_message {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal method to find out weather a part is in the current message
|
||||
my ( $self, $part ) = @_;
|
||||
for ( @{$self->{parts}} ) {
|
||||
return 1 if $_ == $part;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _link {
|
||||
# --------------------------------------------------------------------------
|
||||
# Creats part ids and links the children to the parrents. Called
|
||||
# When parts arer modified
|
||||
#
|
||||
my ( $self ) = @_;
|
||||
|
||||
# Creates ids to keep track of parts with.
|
||||
for ( 0 .. $#{$self->{parts}} ) {
|
||||
$self->{parts}[$_]{id} = $_;
|
||||
}
|
||||
_link_ids( $self->{root_part} );
|
||||
}
|
||||
|
||||
sub _links_ids {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal function to link all children to their parents with the parent id.
|
||||
# RECURSIVE
|
||||
#
|
||||
my ( $part, $parent_id ) = @_;
|
||||
for ( @{$part->{parts}} ) {
|
||||
_link_ids( $_, $part->{id} );
|
||||
}
|
||||
$part->{parent_id} = $parent_id;
|
||||
}
|
||||
|
||||
sub _get_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# Recursive function to get a flat list of all the parts in a part structure
|
||||
#
|
||||
my ( $part, $parts ) = @_;
|
||||
$parts ||= [];
|
||||
|
||||
for ( @{$part->{parts}} ) {
|
||||
push @$parts, @{_get_parts( $_, $parts )};
|
||||
}
|
||||
return $parts;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Message - Encapsolates an email message.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::Message;
|
||||
|
||||
# Get a GT::Mail::Message object from the parser
|
||||
use GT::Mail::Parse;
|
||||
|
||||
my $parser = new GT::Mail::Parse( in_file => "myemail.eml" );
|
||||
my $message = $parser->parse;
|
||||
|
||||
# Get the top level part
|
||||
my $root_part = $message->root_part;
|
||||
|
||||
# Replace the first part with a new part
|
||||
$message->replace_part( $root_part, $message->new_part(
|
||||
to => 'scott@gossamer-threads.com',
|
||||
from => 'alex@gossamer-threads.com',
|
||||
'content-type' => 'text/plain',
|
||||
body_data => 'Hi Scott, how are you?!'
|
||||
);
|
||||
|
||||
# Add a part at the end
|
||||
my $end_part = $message->new_part(
|
||||
'content-type' => 'image/gif',
|
||||
body_path => 'myimage.jpg'
|
||||
);
|
||||
$message->add_part_end( $root_part, $end_part );
|
||||
|
||||
# Move the first part in the top part to after the end part
|
||||
$message->move_part_after( $root_part->parts->[0], $end_part );
|
||||
|
||||
# Print the mime message
|
||||
print $message->to_string;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Message encapsolates a mime message which consists of
|
||||
L<GT::Mail::Parts> object. This module provides methods to change,
|
||||
move, remove, and access these parts.
|
||||
|
||||
=head2 Creating a new GT::Mail::Message object
|
||||
|
||||
Usually you will get a GT::Mail::Message object by call the parse method
|
||||
in L<GT::Mail::Parse>.
|
||||
|
||||
my $message = $parser->parse;
|
||||
|
||||
You may also call new on this class specifying the top level part and or
|
||||
a debug level.
|
||||
|
||||
my $message = new GT::Mail::Message(
|
||||
root_part => $part,
|
||||
debug => 1
|
||||
);
|
||||
|
||||
=head2 Creating a new Part
|
||||
|
||||
You can create a part by calling new on L<GT::Mail::Parts> directly
|
||||
|
||||
my $part = new GT::Mail::Parts;
|
||||
$part->set( 'content-type' => 'image/gif' );
|
||||
$part->body_path( 'myimage.gif' );
|
||||
|
||||
or you can call a method in this module to get a new part
|
||||
|
||||
my $part = $message->new_part(
|
||||
'content-type' => 'image/gif',
|
||||
body_path => 'myimage.gif'
|
||||
);
|
||||
|
||||
This method is a wraper on a combination of new() and some other
|
||||
supporting methods in L<GT::Mail::Parts> such as body_path(). Anything
|
||||
that is not B<body_path>, B<body_data>, or B<body_handle> is treated
|
||||
as header values.
|
||||
|
||||
=head2 Manipulating Parts
|
||||
|
||||
A MIME message is just a format for storing a tree structure. We provide
|
||||
tree-like methods to manipulate parts. All the method for manipulating
|
||||
parts take the part object(s) as arguments. We do this so you do not need
|
||||
to know how the tree is tracked internally.
|
||||
|
||||
=head2 Accessing Parts
|
||||
|
||||
|
||||
More to come!
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $
|
||||
|
||||
|
||||
|
||||
829
site/glist/lib/GT/Mail/POP3.pm
Normal file
829
site/glist/lib/GT/Mail/POP3.pm
Normal file
@@ -0,0 +1,829 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::POP3
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: POP3.pm,v 1.56 2004/03/19 00:36:16 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface to a POP3 server.
|
||||
#
|
||||
|
||||
package GT::Mail::POP3;
|
||||
# ==================================================================
|
||||
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw!$VERSION $DEBUG $ERROR $CRLF @ISA $ERRORS $ATTRIBS!;
|
||||
|
||||
# Constants
|
||||
use constants TIMEOUT => 0.01; # The timeout used on selects.
|
||||
|
||||
# Internal modules
|
||||
use GT::Base;
|
||||
use GT::Socket::Client;
|
||||
use GT::Mail::Parts;
|
||||
use GT::Mail::Parse;
|
||||
|
||||
# System modules
|
||||
use Fcntl qw/O_NONBLOCK F_SETFL F_GETFL/;
|
||||
use POSIX qw/EAGAIN EINTR/;
|
||||
|
||||
# Silence warnings
|
||||
$GT::Mail::Parse::error = '';
|
||||
|
||||
@ISA = qw(GT::Base);
|
||||
$DEBUG = 0;
|
||||
$CRLF = "\r\n";
|
||||
$| = 1;
|
||||
|
||||
$ATTRIBS = {
|
||||
host => undef,
|
||||
port => undef,
|
||||
user => undef,
|
||||
pass => undef,
|
||||
auth_mode => 'PASS',
|
||||
debug => 0,
|
||||
blocking => 0,
|
||||
ssl => 0,
|
||||
timeout => 30, # The connection timeout (passed to GT::Socket::Client)
|
||||
data_timeout => 5, # The timeout to read/write data from/to the connected socket
|
||||
};
|
||||
|
||||
$ERRORS = {
|
||||
NOTCONNECTED => "You are calling %s and you have not connected yet!",
|
||||
CANTCONNECT => "Could not connect to POP3 server: %s",
|
||||
READ => "Unble to read from socket, reason (%s). Read: (%s)",
|
||||
WRITE => "Unable to write %s length to socket. Wrote %s, Error(%s)",
|
||||
NOEOF => "No EOF or EOL found. Socket locked.",
|
||||
ACTION => "Could not %s. Server said: %s",
|
||||
NOMD5 => "Unable to load GT::MD5 (required for APOP authentication): %s",
|
||||
PARSE => "An error occured while parsing an email: %s",
|
||||
LOGIN => "An error occured while logging in: %s",
|
||||
OPEN => "Could not open (%s) for read and write. Reason: %s",
|
||||
};
|
||||
|
||||
sub head_part {
|
||||
# --------------------------------------------------------
|
||||
# my $head = $obj->head_part($num);
|
||||
# ---------------------------------
|
||||
# This method takes one argument, the number message to
|
||||
# parse. It returns a GT::Mail::Parts object that has
|
||||
# only the top level head part parsed.
|
||||
#
|
||||
my ($self, $num) = @_;
|
||||
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->head_part ($msg_num)');
|
||||
my $io = '';
|
||||
$self->top($num, sub { $io .= $_[0] }) or return;
|
||||
return GT::Mail::Parse->new(debug => $self->{_debug}, crlf => $CRLF)->parse_head(\$io);
|
||||
}
|
||||
|
||||
sub all_head_parts {
|
||||
# --------------------------------------------------------
|
||||
# my @heads = $obj->all_head_parts;
|
||||
# ---------------------------------
|
||||
# This does much the same as head_part() but returns an
|
||||
# array of GT::Mail::Parts objects, each one only having
|
||||
# the head of the message parsed.
|
||||
#
|
||||
my $self = shift;
|
||||
my @head_parts;
|
||||
for (1 .. $self->stat) {
|
||||
my $part = $self->head_part($_) or return;
|
||||
push(@head_parts, $part);
|
||||
}
|
||||
return wantarray ? @head_parts : \@head_parts;
|
||||
}
|
||||
|
||||
sub parse_message {
|
||||
# --------------------------------------------------------
|
||||
# my $mail = $obj->parse_message($num);
|
||||
# -------------------------------------
|
||||
# This method returns a GT::Mail object. It calles parse
|
||||
# for the message number specified before returning the
|
||||
# object. You can retrieve the different parts of the
|
||||
# message through the GT::Mail object. If this method
|
||||
# fails you should check $GT::Mail::error.
|
||||
#
|
||||
my ($self, $num) = @_;
|
||||
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->parse_message($msg_num)');
|
||||
my $io = $self->retr($num) or return;
|
||||
my $parser = new GT::Mail::Parse(debug => $self->{_debug}, in_string => $io, crlf => $CRLF);
|
||||
$parser->parse or return $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
|
||||
return $parser;
|
||||
}
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------
|
||||
# Initilize the POP box object.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
$self->set(@_);
|
||||
|
||||
for (qw/user pass host/) {
|
||||
(defined($self->{$_})) or return $self->error('BADARGS', 'FATAL', "CLASS->new(%ARGS); The '$_' key in the hash must exists");
|
||||
}
|
||||
$self->{_debug} = exists($self->{debug}) ? delete($self->{debug}) : $DEBUG;
|
||||
|
||||
# Can be either PASS or APOP depending on login type.
|
||||
$self->{auth_mode} ||= 'PASS';
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub send {
|
||||
# --------------------------------------------------------
|
||||
# Send a message to the server.
|
||||
#
|
||||
my ($self, $msg) = @_;
|
||||
|
||||
unless (defined $msg and length $msg) {
|
||||
$self->debug("Sending blank message!") if $self->{_debug};
|
||||
return;
|
||||
}
|
||||
|
||||
# Get the socket and end of line.
|
||||
my $s = $self->{sock};
|
||||
defined($s) and defined fileno($s) or return $self->error("NOTCONNECTED", "WARN", "send()");
|
||||
|
||||
# Print the message.
|
||||
$self->debug("--> $msg") if $self->{_debug};
|
||||
|
||||
$s->write($msg . $CRLF);
|
||||
|
||||
$self->getline(my $line) or return;
|
||||
|
||||
$line =~ s/$CRLF//o if $line;
|
||||
$line ||= 'Nothing sent back';
|
||||
$self->{message} = $line;
|
||||
$self->debug("<-- $line") if $self->{_debug};
|
||||
|
||||
return $line;
|
||||
}
|
||||
|
||||
sub getline {
|
||||
# --------------------------------------------------------
|
||||
# Read a line of input from the server.
|
||||
#
|
||||
my ($self) = @_;
|
||||
my $got_cr;
|
||||
my $safety;
|
||||
my $s = $self->{sock};
|
||||
$s->readline($_[1]);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub getall {
|
||||
# --------------------------------------------------------
|
||||
# Get all pending output from the server.
|
||||
#
|
||||
my ($self) = @_;
|
||||
$_[1] = '';
|
||||
my $l = 0;
|
||||
my $safety;
|
||||
my $s = $self->{sock};
|
||||
if ($self->{blocking}) {
|
||||
while (<$s>) {
|
||||
last if /^\.$CRLF/o;
|
||||
s/^\.//; # Lines starting with a . are doubled up in POP3
|
||||
$_[1] .= $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $save = $s->read_size;
|
||||
$s->read_size(1048576);
|
||||
$s->readalluntil("\n.$CRLF", $_[1], ".$CRLF");
|
||||
$s->read_size($save);
|
||||
|
||||
$_[1] =~ s/\n\.\r?\n$/\n/; # Remove the final . at the end of the e-mail
|
||||
$_[1] =~ s/^\.//mg; # Remove the initial '.' from any lines beginning with .
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub connect {
|
||||
# --------------------------------------------------------
|
||||
# Connect to the server.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($s, $iaddr, $msg, $paddr, $proto);
|
||||
|
||||
$self->debug("Attempting to connect .. ") if ($self->{_debug});
|
||||
|
||||
$self->{blocking} = 1 if $self->{ssl};
|
||||
$self->{port} ||= $self->{ssl} ? 995 : 110;
|
||||
|
||||
# If there was an existing connection, it'll be closed here when we reassign
|
||||
$self->{sock} = GT::Socket::Client->open(
|
||||
port => $self->{port},
|
||||
host => $self->{host},
|
||||
max_down => 0,
|
||||
timeout => $self->{timeout},
|
||||
non_blocking => !$self->{blocking},
|
||||
select_time => TIMEOUT,
|
||||
read_wait => $self->{data_timeout},
|
||||
ssl => $self->{ssl},
|
||||
debug => $self->{_debug}
|
||||
) or return $self->error("CANTCONNECT", "WARN", GT::Socket::Client->error);
|
||||
|
||||
$self->debug('Connected to ' . $self->{host} . ' on port ' . $self->{port} . ($self->{ssl} ? ' via SSL' : '')) if $self->{_debug};
|
||||
|
||||
# Get server welcoming.
|
||||
$self->getline($msg) or return;
|
||||
|
||||
# Store this - it's needed for APOP authentication
|
||||
$self->{msg_id}= $1 if ($msg =~ /(<[\w\d\-\.]+\@[\w\d\-\.]+>)/);
|
||||
|
||||
$self->debug("Going to login") if $self->{_debug};
|
||||
return $self->login();
|
||||
}
|
||||
|
||||
sub login {
|
||||
# --------------------------------------------------------
|
||||
# Login either using APOP or regular.
|
||||
#
|
||||
my $self = shift;
|
||||
($self->{auth_mode} eq 'APOP' && $self->{msg_id}) ? $self->login_apop : $self->login_pass;
|
||||
}
|
||||
|
||||
sub login_apop {
|
||||
# --------------------------------------------------------
|
||||
# Login using APOP.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($hash, $count, $line);
|
||||
{
|
||||
local $SIG{__DIE__};
|
||||
eval { require GT::MD5; 1 } or return $self->error('NOMD5', 'WARN', $@);
|
||||
}
|
||||
$self->debug("Attempting to log in via APOP ... ") if $self->{_debug};
|
||||
$hash = GT::MD5::md5_hex($self->{msg_id} . $self->{pass});
|
||||
|
||||
local ($_) = $self->send('APOP ' . $self->{user} . ' ' . $hash) or return;
|
||||
substr($_, 0, 1) eq '+' or return $self->error("LOGIN", "WARN", "APOP Login failed: $_");
|
||||
if (/^\+OK \S+ has (\d+) /i) {
|
||||
$self->{count} = $1;
|
||||
}
|
||||
elsif (uc substr($_, 0, 3) ne '+OK') {
|
||||
return $self->error('LOGIN', 'WARN', $_);
|
||||
}
|
||||
$self->{state} = 'TRANSACTION';
|
||||
$self->stat() or return;
|
||||
|
||||
$self->debug("APOP Login successful.") if $self->{_debug};
|
||||
return (($self->{count} == 0) ? '0E0' : $self->{count});
|
||||
}
|
||||
|
||||
sub login_pass {
|
||||
# --------------------------------------------------------
|
||||
# Login using clear text authentication.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($line);
|
||||
|
||||
$self->debug("Attempting to log in via clear text ... ") if $self->{_debug};
|
||||
|
||||
# Enter username.
|
||||
local($_) = $self->send('USER ' . $self->{user}) or return;
|
||||
substr($_, 0, 1) eq '+' or return $self->error('LOGIN', 'WARN', "USER POP Login failed: $_");
|
||||
|
||||
# Enter password.
|
||||
$_ = $self->send('PASS ' . $self->{pass}) or return;
|
||||
substr($_, 0, 1) eq '+' or return $self->error('LOGIN', 'WARN', "PASS POP Login failed: $_");
|
||||
|
||||
# Ok, get total number of message, and pop box status.
|
||||
if (/^\+OK \S+ has (\d+) /i) {
|
||||
$self->{count} = $1;
|
||||
}
|
||||
elsif (uc substr($_, 0, 3) ne '+OK') {
|
||||
return $self->error('LOGIN', 'WARN', $_);
|
||||
}
|
||||
$self->stat() or return;
|
||||
|
||||
$self->debug("Login successful.") if $self->{_debug};
|
||||
return $self->{count} == 0 ? '0E0' : $self->{count};
|
||||
}
|
||||
|
||||
sub top {
|
||||
# --------------------------------------------------------
|
||||
# Get the header of a message and the next x lines (optional).
|
||||
#
|
||||
my ($self, $num, $code) = @_;
|
||||
defined($num) or return $self->error('BADARGS', 'FATAL', '$obj->head($msg_num);. No message number passed to head.');
|
||||
$self->debug("Getting head of message $num ... ") if $self->{_debug};
|
||||
|
||||
local($_) = $self->send("TOP $num 0") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "TOP $num 0", "($_)");
|
||||
|
||||
my ($tp, $header);
|
||||
$self->getall($header);
|
||||
if (substr($header, 0, 1) eq '>') {
|
||||
substr($header, 0, index($header, $CRLF) + 2) = '';
|
||||
}
|
||||
|
||||
# Support broken headers which given unix linefeeds.
|
||||
if ($header =~ /[^\r]\n/) {
|
||||
$header =~ s/\r?\n/$CRLF/g;
|
||||
}
|
||||
$self->debug("Top of message $num retrieved.") if $self->{_debug};
|
||||
if ($code and ref $code eq 'CODE') {
|
||||
$code->($header);
|
||||
}
|
||||
else {
|
||||
return wantarray ? split(/$CRLF/o, $header) : $header;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub retr {
|
||||
# --------------------------------------------------------
|
||||
# Get the entire message.
|
||||
#
|
||||
my ($self, $num, $code) = @_;
|
||||
defined($num) or return $self->error('BADARGS', 'FATAL', '$obj->retr ($msg_numm, $code);');
|
||||
|
||||
$self->debug("Getting message $num ... ") if ($self->{_debug});
|
||||
|
||||
# Get the size of the message
|
||||
local ($_) = $self->send("RETR $num") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error('ACTION', 'WARN', "RETR $num", $_);
|
||||
|
||||
# Retrieve the entire email
|
||||
my $body = '';
|
||||
$self->getall($body);
|
||||
|
||||
# Qmail puts this wierd header as the first line
|
||||
if (substr($body, 0, 1) eq '>') {
|
||||
substr($body, 0, index($body, $CRLF) + 2) = '';
|
||||
}
|
||||
|
||||
# Support broken pop servers that send us unix linefeeds.
|
||||
if ($body =~ /[^\r]\n/) {
|
||||
$body =~ s/\r?\n/$CRLF/g;
|
||||
}
|
||||
$self->debug("Message $num retrieved.") if $self->{_debug};
|
||||
if ($code and ref $code eq 'CODE') {
|
||||
$code->($body);
|
||||
}
|
||||
else {
|
||||
return \$body;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub last {
|
||||
my ($self) = @_;
|
||||
|
||||
local($_) = $self->send("LAST") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "LAST", $_);
|
||||
s/^\+OK\s*//i;
|
||||
return $_;
|
||||
}
|
||||
|
||||
sub message_save {
|
||||
# --------------------------------------------------------
|
||||
# Get a message and save it to a file rather then returning.
|
||||
#
|
||||
my ($self, $num, $file) = @_;
|
||||
|
||||
# Check arguments.
|
||||
$num or return $self->error("BADARGS", "FATAL", '$obj->message_save ($msg_num, $IO);');
|
||||
$file or return $self->error("BADARGS", "FATAL", '$obj->message_save ($msg_num, $IO);');
|
||||
|
||||
my $io;
|
||||
if (ref $file) {
|
||||
$io = $file;
|
||||
}
|
||||
else {
|
||||
$file =~ /^\s*(.+?)\s*$/ and $file = $1;
|
||||
$io = \do { local *FH; *FH };
|
||||
open $io, ">$file" or return $self->error("OPENWRITE", "FATAL", $file, "$!");
|
||||
}
|
||||
|
||||
# Get the entire message body.
|
||||
$self->retr($num, sub { print $io $_[0] });
|
||||
$self->debug("Message $num saved to '$file'.") if $self->{_debug};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub stat {
|
||||
# --------------------------------------------------------
|
||||
# Handle a stat command, get the number of messages and size.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
local($_) = $self->send("STAT") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error('ACTION', 'WARN', 'STAT', $_);
|
||||
if (/^\+OK (\d+) (\d+)/i) {
|
||||
$self->{count} = $1;
|
||||
$self->{size} = $2;
|
||||
$self->debug("STAT successful - count: $1 size: $2") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
$self->debug("STAT failed, can't determine count.") if $self->{_debug};
|
||||
}
|
||||
return $self->{count} || "0E0";
|
||||
}
|
||||
|
||||
sub list {
|
||||
# --------------------------------------------------------
|
||||
# Return a list of messages available.
|
||||
#
|
||||
my $self = shift;
|
||||
my $num = shift || '';
|
||||
my @messages;
|
||||
|
||||
# Broken pop servers that don't like 'LIST '.
|
||||
my $cmd = ($num eq '') ? 'LIST' : "LIST $num";
|
||||
|
||||
local($_) = $self->send($cmd) or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "LIST $num", $_);
|
||||
if ($num) {
|
||||
s/^\+OK\s*//i;
|
||||
return $_;
|
||||
}
|
||||
my $msg = '';
|
||||
$self->getall($msg);
|
||||
@messages = split /$CRLF/o => $msg;
|
||||
$self->debug(@messages . " messages listed.") if ($self->{_debug});
|
||||
if (@messages) {
|
||||
return wantarray ? @messages : join("", @messages);
|
||||
}
|
||||
}
|
||||
|
||||
sub rset {
|
||||
# --------------------------------------------------------
|
||||
# Reset deletion stat.
|
||||
#
|
||||
my $self = shift;
|
||||
local($_) = $self->send("RSET") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "RSET", $_);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub dele {
|
||||
# --------------------------------------------------------
|
||||
# Delete a given message.
|
||||
#
|
||||
my ($self, $num) = @_;
|
||||
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->dele ($msg_num)');
|
||||
local($_) = $self->send("DELE $num") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "DELE $num", $_);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub quit {
|
||||
# --------------------------------------------------------
|
||||
# Close the socket.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->send("QUIT") or return;
|
||||
close $self->{sock};
|
||||
$self->{sock} = undef;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uidl {
|
||||
# --------------------------------------------------------
|
||||
# Returns a list of uidls from the remote server
|
||||
#
|
||||
my $self = shift;
|
||||
my $num = shift;
|
||||
local $_;
|
||||
if ($num and !ref $num) {
|
||||
$_ = $self->send("UIDL $num") or return;
|
||||
/^\+OK \d+ (.+)$/i or return $self->error("ACTION", "WARN", "UIDL $num", $_);
|
||||
return $1;
|
||||
}
|
||||
my $ret = {};
|
||||
$_ = $self->send("UIDL") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "UIDL $num", $_);
|
||||
my $list = '';
|
||||
$self->getall($list);
|
||||
for (split /$CRLF/o => $list) {
|
||||
if ($num and ref($num) eq 'CODE') {
|
||||
$num->($_);
|
||||
}
|
||||
else {
|
||||
/^(\d+) (.+)/ and $ret->{$1} = $2;
|
||||
}
|
||||
}
|
||||
return wantarray ? %{$ret} : $ret;
|
||||
}
|
||||
|
||||
sub count {
|
||||
# --------------------------------------------------------
|
||||
# Accessor for number of messages waiting.
|
||||
#
|
||||
return $_[0]->{count};
|
||||
}
|
||||
|
||||
sub size {
|
||||
# --------------------------------------------------------
|
||||
# Accessor for size of messages waiting.
|
||||
#
|
||||
return $_[0]->{count};
|
||||
}
|
||||
|
||||
sub last_message {
|
||||
# --------------------------------------------------------
|
||||
# Accessor for last server message.
|
||||
|
||||
@_ == 2 and $_[0]->{message} = $_[1];
|
||||
return $_[0]->{message};
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# --------------------------------------------------------
|
||||
# Auto close the socket.
|
||||
#
|
||||
my $self = shift;
|
||||
if ($self->{sock} and defined fileno($self->{sock})) {
|
||||
$self->send("QUIT");
|
||||
close $self->{sock};
|
||||
$self->{sock} = undef;
|
||||
}
|
||||
$self->debug("POP Object destroyed.") if ($self->{_debug} > 1);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::POP3 - Receieve email through POP3 protocal
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::POP3;
|
||||
|
||||
my $pop = GT::Mail::POP3->new(
|
||||
host => 'mail.gossamer-threads.com',
|
||||
port => 110,
|
||||
user => 'someusername',
|
||||
pass => 'somepassword',
|
||||
auth_mode => 'PASS',
|
||||
timeout => 30,
|
||||
debug => 1
|
||||
);
|
||||
|
||||
my $count = $pop->connect or die $GT::Mail::POP3::error;
|
||||
|
||||
for my $num (1 .. $count) {
|
||||
my $top = $pop->parse_head($num);
|
||||
|
||||
my @to = $top->split_field;
|
||||
|
||||
if (grep /myfriend\@gossamer-threads\.com/, @to) {
|
||||
$pop->message_save($num, '/keep/email.txt');
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::POP3 is a module to check an email account using the POP3 protocol.
|
||||
Many of the methods are integrated with L<GT::Mail::Parse>.
|
||||
|
||||
=head2 new - constructor method
|
||||
|
||||
This method is inherited from L<GT::Base>. The argument to this method can be
|
||||
in the form of a hash or hash ref. As a minimum 'user', 'pass', and 'host' must
|
||||
be specified.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debugging level for this instance of GT::Mail::POP3.
|
||||
|
||||
=item host
|
||||
|
||||
Sets the host to connect to for checking a POP account. This argument must be
|
||||
provided.
|
||||
|
||||
=item port
|
||||
|
||||
Sets the port on the POP server to attempt to connect to. This defaults to 110,
|
||||
unless using SSL, for which the default is 995.
|
||||
|
||||
=item ssl
|
||||
|
||||
Establishes the connection using SSL. Note that this requires Net::SSLeay of
|
||||
at least version 1.06.
|
||||
|
||||
=item user
|
||||
|
||||
Sets the user name to login with when connecting to the POP server. This must
|
||||
be specified.
|
||||
|
||||
=item pass
|
||||
|
||||
Sets the password to login with when connection to the POP server. This must be
|
||||
specified.
|
||||
|
||||
=item auth_mode
|
||||
|
||||
Sets the authentication type for this connection. This can be one of two
|
||||
values. PASS (the default) or APOP. If set to APOP, GT::Mail::POP3 will use
|
||||
APOP to login to the remote server.
|
||||
|
||||
=item timeout
|
||||
|
||||
Sets the connection timeout. This isn't entirely reliable as it uses alarm(),
|
||||
which isn't supported on all systems. That aside, this normally isn't needed
|
||||
if you want a timeout - it defaults to 30 on alarm()-supporting systems. The
|
||||
main purpose is to provide a value of 0 to disable the alarm() timeout.
|
||||
|
||||
=back
|
||||
|
||||
=head2 connect - Connect to the POP account
|
||||
|
||||
$obj->connect or die $GT::Mail::POP3::error;
|
||||
|
||||
This method performs the connection to the POP server. Returns the count of
|
||||
messages on the server on success, and undefined on failure. Takes no arguments
|
||||
and called before you can perform any actions on the POP server.
|
||||
|
||||
=head2 head_part - Access the email header
|
||||
|
||||
# Get a parsed header part object for the first email in the list.
|
||||
my $top_part = $obj->head_part(1);
|
||||
|
||||
Instance method. The only argument to this method is the message number to get.
|
||||
Returns a L<GT::Mail::Parts> object containing only the parsed header of the
|
||||
specified message.
|
||||
|
||||
=head2 all_head_parts - Access all email headers
|
||||
|
||||
# Get all the head parts from all messages
|
||||
my @headers = $obj->all_head_parts;
|
||||
|
||||
Instance method. Gets all the headers of all the email's on the remote server.
|
||||
Returns an array of the L<GT::Mail::Parts> object. One object for each
|
||||
email. None of the email's bodies are retrieved, only the head.
|
||||
|
||||
=head2 parse_message - Access an email
|
||||
|
||||
# Parse an email and get the GT::Mail object
|
||||
my $mail = $obj->parse_message (1);
|
||||
|
||||
Instance method. Pass in the number of the email to retrieve. This method
|
||||
retrieves the specified email and returns the parsed GT::Mail object. If this
|
||||
method fails you should check $GT::Mail::error for the error message.
|
||||
|
||||
=head2 message_save - Save an email
|
||||
|
||||
open FH, '/path/to/email.txt' or die $!;
|
||||
|
||||
# Save message 2 to file
|
||||
$obj->message_save (2, \*FH);
|
||||
close FH;
|
||||
|
||||
- or -
|
||||
|
||||
$obj->message_save (2, '/path/to/email.txt') or die $GT::Mail::POP3::error;
|
||||
|
||||
Instance method. This method takes the message number as it's first argument,
|
||||
and either a file path or a file handle ref as it's second argument. If a file
|
||||
path is provided the file will be opened to truncate. The email is then
|
||||
retrieved from the server and written to the file.
|
||||
|
||||
=head2 stat - Do a STAT command
|
||||
|
||||
# Get the number of messages on the server
|
||||
my $count = $obj->stat;
|
||||
|
||||
Instance method. Does a STAT command on the remote server. It stores the total
|
||||
size and returns the count of messages on the server, if successful. Otherwise
|
||||
returns undef.
|
||||
|
||||
=head2 list - Do a LIST command
|
||||
|
||||
# At a list of messages on the server
|
||||
my @messages = $obj->list;
|
||||
|
||||
Instance method. Does a LIST command on the remote server. Returns an array of
|
||||
the lines in list context and a single scalar that contains all the lines in
|
||||
scalar context.
|
||||
|
||||
=head2 rset - Do an RSET command
|
||||
|
||||
# Tell the server to ignore any dele commands we have issued in this
|
||||
# session
|
||||
$obj->rset;
|
||||
|
||||
Instance method. Does an RSET command. This command resets the servers
|
||||
knowledge of what should be deleted when QUIT is called. Returns 1 on success.
|
||||
|
||||
=head2 dele - Do a DELE command
|
||||
|
||||
# Delete message 4
|
||||
$obj->dele (4);
|
||||
|
||||
Instance method. Does a DELE command. The only argument is the message number
|
||||
to delete. Returns 1 on success.
|
||||
|
||||
=head2 quit - Quit the connection
|
||||
|
||||
# Close our connection
|
||||
$obj->quit;
|
||||
|
||||
Instance method. Sends the QUIT command to the server. The should should
|
||||
disconnect soon after this. No more actions can be taken on this connection
|
||||
until connect is called again.
|
||||
|
||||
=head2 uidl - Do a UIDL command
|
||||
|
||||
# Get the uidl for message 1
|
||||
my $uidl = $obj->uidl (1);
|
||||
|
||||
# Get a list of all the uidl's and print them
|
||||
$obj->uidl (sub { print @_ });
|
||||
|
||||
# Get an array of all the uidl's
|
||||
my @uidl = $obj->uidl;
|
||||
|
||||
Instance method. Attempts to do a UIDL command on the remote server. Please be
|
||||
aware support for the UIDL command is not very wide spread. This method can
|
||||
take the message number as it's first argument. If the message number is given,
|
||||
the UIDL for that message is returned. If the first argument is a code
|
||||
reference, a UIDL command is done with no message specified and the code
|
||||
reference is called for each line returned from the remote server. If no second
|
||||
argument is given, a UIDL command is done, and the results are returned in a
|
||||
has of message number to UIDL.
|
||||
|
||||
=head2 count - Get the number of messages
|
||||
|
||||
# Get the count from the last STAT
|
||||
my $count = $obj->count;
|
||||
|
||||
This method returns the number of messages on the server from the last STAT
|
||||
command. A STAT is done on connect.
|
||||
|
||||
=head2 size - Get the size of all messages
|
||||
|
||||
# Get the total size of all messages on the server
|
||||
my $size = $obj->size;
|
||||
|
||||
This method returns the size of all messages in the server as returned by the
|
||||
last STAT command sent to the server.
|
||||
|
||||
=head2 send - Send a raw command
|
||||
|
||||
# Send a raw command to the server
|
||||
my $ret = $obj->send ("HELO");
|
||||
|
||||
This method sends the specified raw command to the POP server. The one line
|
||||
return from the server is returned. Do not call this method if you are
|
||||
expecting more than a one line response.
|
||||
|
||||
=head2 top - Retrieve the header
|
||||
|
||||
# Get the header of message 2 in an array. New lines are stripped
|
||||
my @header = $obj->top (2);
|
||||
|
||||
# Get the header as a string
|
||||
my $header = $obj->top (2);
|
||||
|
||||
Instance method to retrieve the top of an email on the POP server. The only
|
||||
argument should be the message number to retrieve. Returns a scalar containing
|
||||
the header in scalar context and an array, which is the scalar split on
|
||||
\015?\012, in list context.
|
||||
|
||||
=head2 retr - Retrieve an email
|
||||
|
||||
# Get message 3 from the remote server in an array. New lines are stripped
|
||||
my @email = $obj->retr (3);
|
||||
|
||||
# Get it as a string
|
||||
my $email = $obj->retr (3);
|
||||
|
||||
Instance method to retrieve an email from the POP server. The first argument to
|
||||
this method should be the message number to retrieve. The second argument is an
|
||||
optional code ref to call for each line of the message that is retrieved. If no
|
||||
code ref is specified, this method will put the email in a scalar and return
|
||||
the scalar in scalar context and return the scalar split on \015?\012 in list
|
||||
context.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
L<GT::Socket::Client>
|
||||
L<GT::Base>
|
||||
L<GT::MD5> (for APOP authentication)
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: POP3.pm,v 1.56 2004/03/19 00:36:16 brewt Exp $
|
||||
|
||||
788
site/glist/lib/GT/Mail/Parse.pm
Normal file
788
site/glist/lib/GT/Mail/Parse.pm
Normal file
@@ -0,0 +1,788 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Parse
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Parse.pm,v 1.79 2004/10/23 02:16:39 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::Mail::Parse;
|
||||
# =============================================================================
|
||||
# If MIME::Base64 is installed use it - must eval before hand or 5.004_04 wipes
|
||||
# our ISA.
|
||||
my $have_b64 = eval {
|
||||
local $SIG{__DIE__};
|
||||
require MIME::Base64;
|
||||
import MIME::Base64;
|
||||
if ($] < 5.005) { local $^W; decode_base64('brok'); }
|
||||
1;
|
||||
};
|
||||
$have_b64 or *decode_base64 = \>_old_decode_base64;
|
||||
my $use_decode_qp;
|
||||
if ($have_b64 and
|
||||
$MIME::Base64::VERSION >= 2.16 and # Prior versions had decoding bugs
|
||||
defined &MIME::QuotedPrint::decode_qp and (
|
||||
not defined &MIME::QuotedPrint::old_decode_qp or
|
||||
\&MIME::QuotedPrint::decode_qp != \&MIME::QuotedPrint::old_decode_qp
|
||||
)
|
||||
) {
|
||||
$use_decode_qp = 1;
|
||||
}
|
||||
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw($VERSION $DEBUG $ERRORS $CRLF $CR_LN @ISA);
|
||||
|
||||
# System modules
|
||||
use Fcntl;
|
||||
|
||||
# Internal modules
|
||||
use GT::Mail::Parts;
|
||||
use GT::Base;
|
||||
|
||||
# Inherent from GT::Base for errors and debug
|
||||
@ISA = qw(GT::Base);
|
||||
|
||||
# Debugging mode
|
||||
$DEBUG = 0;
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = substr q$Revision: 1.79 $, 10;
|
||||
|
||||
# The CRLF sequence:
|
||||
$CRLF = "\n";
|
||||
|
||||
# The length of a crlf
|
||||
$CR_LN = 1;
|
||||
|
||||
# Error messages
|
||||
$ERRORS = {
|
||||
PARSE => "An error occured while parsing: %s",
|
||||
DECODE => "An error occured while decoding: %s",
|
||||
NOPARTS => "Email has no parts!",
|
||||
DEEPPARTS => "Deep recursion dected, email appears to have more than 50 parts!",
|
||||
MALFORMED => "Found (%s) before finding the start of the boundary. Message malformed"
|
||||
};
|
||||
|
||||
my %DecoderFor = (
|
||||
# Standard...
|
||||
'7bit' => 'NBit',
|
||||
'8bit' => 'NBit',
|
||||
'base64' => 'Base64',
|
||||
'binary' => 'Binary',
|
||||
'none' => 'Binary',
|
||||
'quoted-printable' => 'QuotedPrint',
|
||||
|
||||
# Non-standard...
|
||||
'x-uu' => 'UU',
|
||||
'x-uuencode' => 'UU',
|
||||
);
|
||||
|
||||
sub new {
|
||||
# --------------------------------------------------------------------------
|
||||
# CLASS->new (
|
||||
# naming => \&naming,
|
||||
# in_file => '/path/to/file/to/parse',
|
||||
# handle => \*FH
|
||||
# );
|
||||
# ----------------------------------------------
|
||||
# Class method to get a new object. Calles init if there are any additional
|
||||
# argument. To set the arguments that are passed to naming call naming
|
||||
# directly.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {
|
||||
file_handle => undef,
|
||||
parts => [],
|
||||
head_part => undef,
|
||||
headers_intact => 1,
|
||||
_debug => $DEBUG,
|
||||
}, $class;
|
||||
$self->init(@_) if @_;
|
||||
$self->debug("Created new object ($self).") if $self->{_debug} > 1;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->init (%opts);
|
||||
# -------------------
|
||||
# Sets the options for the current object.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift }
|
||||
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
else { return $self->error("BADARGS", "FATAL", "init") }
|
||||
|
||||
$self->{_debug} = exists($opt->{debug}) ? $opt->{debug} : $DEBUG;
|
||||
$self->{headers_intact} = exists($opt->{headers_intact}) ? $opt->{headers_intact} : 1;
|
||||
for my $m (qw(crlf in_file in_handle in_string attach_rfc822)) {
|
||||
$self->$m($opt->{$m}) if defined $opt->{$m};
|
||||
}
|
||||
}
|
||||
|
||||
sub attach_rfc822 {
|
||||
# --------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{attach_rfc822} = shift;
|
||||
}
|
||||
return $self->{attach_rfc822};
|
||||
}
|
||||
|
||||
sub crlf {
|
||||
# --------------------------------------------------------------------------
|
||||
$CRLF = pop || return $CRLF;
|
||||
$CR_LN = length($CRLF);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
# --------------------------------------------------------------------------
|
||||
# my $top = $obj->parse;
|
||||
# ----------------------
|
||||
# Parses the email set in new or init. Also calls init if there are any
|
||||
# arguments passed in.
|
||||
# Returns the top level part object.
|
||||
#
|
||||
my ($self, @opts) = @_;
|
||||
|
||||
# Any additional arguments goto init
|
||||
$self->init(@opts) if @opts;
|
||||
|
||||
($self->{string} and ref($self->{string}) eq 'SCALAR')
|
||||
or return $self->error('BADARGS', 'FATAL', "No input was given to parse before parse() was called");
|
||||
|
||||
# Recursive function to parse
|
||||
$self->_parse_part(undef, $self->{string}); # parse!
|
||||
|
||||
# Return top part
|
||||
return $self->{head_part};
|
||||
}
|
||||
|
||||
sub parse_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# my $head = $obj->parse_head;
|
||||
# ----------------------------
|
||||
# Passes any additional arguments to init. Parses only the top level header.
|
||||
# This saves some overhead if for example all you need to do it find out who
|
||||
# an email is to on a POP3 server.
|
||||
#
|
||||
my ($self, $in, @opts) = @_;
|
||||
|
||||
unless (ref $self) {
|
||||
$self = $self->new(@opts);
|
||||
}
|
||||
|
||||
$in ||= $self->{string};
|
||||
$in || return $self->error("BADARGS", "FATAL", "No string to parse set!");
|
||||
|
||||
# Parse the head
|
||||
return $self->_parse_head($in);
|
||||
}
|
||||
|
||||
#--------------------------------------------
|
||||
# Access
|
||||
#--------------------------------------------
|
||||
|
||||
|
||||
sub in_handle {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->in_handle (\*FH);
|
||||
# --------------------
|
||||
# Pass in a file handle to parse from when parse is called.
|
||||
#
|
||||
my ($self, $value) = @_;
|
||||
if (@_ > 1 and ref $value and defined fileno $value) {
|
||||
read $value, ${$self->{string}}, -s $value;
|
||||
}
|
||||
return $self->{string};
|
||||
}
|
||||
|
||||
sub in_file {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->in_file ('/path/to/file');
|
||||
# --------------------------------
|
||||
# Pass in the path to a file to parse when parse is called
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = shift;
|
||||
my $io = \do { local *FH; *FH };
|
||||
open $io, "<$file" or return $self->error("READOPEN", "FATAL", $file, $!);
|
||||
return $self->in_handle($io);
|
||||
}
|
||||
|
||||
sub in_string {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $string) = @_;
|
||||
return $self->{string} unless (@_ > 1);
|
||||
if (ref($string) eq 'SCALAR') {
|
||||
$self->{string} = $string;
|
||||
}
|
||||
else {
|
||||
$self->{string} = \$string;
|
||||
}
|
||||
return $self->{string};
|
||||
}
|
||||
|
||||
sub size {
|
||||
# --------------------------------------------------------------------------
|
||||
# my $email_size = $obj->size;
|
||||
# ----------------------------
|
||||
# Returns the total size of an email. Call this method after the email has
|
||||
# been parsed.
|
||||
#
|
||||
my $self = shift;
|
||||
(@{$self->{parts}} > 0) or return $self->error("NOPARTS", "WARN");
|
||||
my $size = 0;
|
||||
foreach (@{$self->{parts}}) {
|
||||
$size += $_->size;
|
||||
}
|
||||
return $size;
|
||||
}
|
||||
|
||||
sub all_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# my @parts = $obj->all_parts;
|
||||
# ----------------------------
|
||||
# Returns a list of all the part object for the current parsed email. If the
|
||||
# email is not multipart this will be just the header part.
|
||||
#
|
||||
return @{shift()->{parts}}
|
||||
}
|
||||
|
||||
sub top_part {
|
||||
# --------------------------------------------------------------------------
|
||||
return ${shift()->{parts}}[0];
|
||||
}
|
||||
|
||||
#---------------------------------------------
|
||||
# Internal Methods
|
||||
#---------------------------------------------
|
||||
|
||||
sub _parse_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parse just the head. Returns the part object.
|
||||
#
|
||||
my ($self, $in) = @_;
|
||||
|
||||
# Get a new part object
|
||||
my $part = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
|
||||
|
||||
if (ref $in eq 'ARRAY') {
|
||||
$part->extract($in) or return $self->error("PARSE", "WARN", "Couldn't parse head!");
|
||||
return $part;
|
||||
}
|
||||
$part->extract([map { $_ . $CRLF } split($CRLF => $$in)]) or return $self->error($GT::Mail::Parts::error, 'WARN');
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub _parse_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses all the parts of an email and stores them in there parts object.
|
||||
# This function is recursive.
|
||||
#
|
||||
my ($self, $outer_bound, $in, $part) = @_;
|
||||
my $state = 'OK';
|
||||
|
||||
# First part is going to be the top level part
|
||||
if (!$part) {
|
||||
$part = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
|
||||
$self->{head_part} = $part;
|
||||
}
|
||||
push @{$self->{parts}}, $part;
|
||||
|
||||
# Get the header for this part
|
||||
my $indx;
|
||||
if (($indx = index($$in, $CRLF)) == 0) {
|
||||
substr($$in, 0, $CR_LN) = '';
|
||||
}
|
||||
else {
|
||||
$indx = index($$in, ($CRLF . $CRLF));
|
||||
if ($indx == -1) {
|
||||
$self->debug('Message has no body.') if $self->{_debug};
|
||||
$indx = length($$in);
|
||||
}
|
||||
$part->extract([map { $_ . $CRLF } split($CRLF => substr($$in, 0, $indx))])
|
||||
or return $self->error($GT::Mail::Parts::error, 'WARN');
|
||||
substr($$in, 0, $indx + ($CR_LN * 2)) = '';
|
||||
}
|
||||
|
||||
# Get the mime type
|
||||
my ($type, $subtype) = split('/', $part->mime_type);
|
||||
$type ||= 'text';
|
||||
$subtype ||= 'plain';
|
||||
if ($self->{_debug}) {
|
||||
my $name = $part->recommended_filename || '[unnamed]';
|
||||
$self->debug("Type is '$type/$subtype' ($name)");
|
||||
}
|
||||
|
||||
# Deal with the multipart type with some recursion
|
||||
if ($type eq 'multipart') {
|
||||
my $retype = (($subtype eq 'digest') ? 'message/rfc822' : '');
|
||||
|
||||
# Find the multipart boundary
|
||||
my $inner_bound = $part->multipart_boundary;
|
||||
$self->debug("Boundary is $inner_bound") if $self->{_debug} > 1;
|
||||
defined $inner_bound or return $self->error("PARSE", "WARN", "No multipart boundary in multipart message.");
|
||||
index($inner_bound, $CRLF) == -1 or return $self->error("PARSE", "WARN", "CR or LF in multipart boundary.");
|
||||
|
||||
# Parse the Preamble
|
||||
$self->debug("Parsing preamble.") if $self->{_debug} > 1;
|
||||
$state = $self->_parse_preamble($inner_bound, $in, $part) or return;
|
||||
chomp($part->preamble->[-1]) if @{$part->preamble};
|
||||
|
||||
# Get all the parts of the multipart message
|
||||
my $partno = 0;
|
||||
my $parts;
|
||||
while (1) {
|
||||
++$partno < 200 or return $self->error('DEEPPARTS', 'WARN');
|
||||
$self->debug("Parsing part $partno.") if $self->{_debug};
|
||||
|
||||
($parts, $state) = $self->_parse_part($inner_bound, $in, GT::Mail::Parts->new(headers_intact => $self->{headers_intact})) or return;
|
||||
($state eq 'EOF') and return $self->error('PARSE', 'WARN', 'Unexpected EOF before close.');
|
||||
|
||||
$parts->mime_type($retype) if $retype;
|
||||
push(@{$part->{parts}}, $parts);
|
||||
|
||||
last if $state eq 'CLOSE';
|
||||
}
|
||||
|
||||
# Parse the epilogue
|
||||
$self->debug("Parsing epilogue.") if $self->{_debug} > 1;
|
||||
$state = $self->_parse_epilogue($outer_bound, $in, $part) or return;
|
||||
chomp($part->epilogue->[-1]) if @{$part->epilogue} and $state ne 'EOF';
|
||||
}
|
||||
|
||||
# We are on a single part
|
||||
else {
|
||||
$self->debug("Decoding single part.") if $self->{_debug} > 1;
|
||||
|
||||
# Find the encoding for the body of the part
|
||||
my $encoding = $part->mime_encoding || 'binary';
|
||||
if (!exists($DecoderFor{lc($encoding)})) {
|
||||
$self->debug("Unsupported encoding '$encoding': using 'binary'... \n" .
|
||||
"The entity will have an effective MIME type of \n" .
|
||||
"application/octet-stream, as per RFC-2045.")
|
||||
if $self->{_debug};
|
||||
$part->effective_type('application/octet-stream');
|
||||
$encoding = 'binary';
|
||||
}
|
||||
my $reparse;
|
||||
$reparse = ("$type/$subtype" eq "message/rfc822") unless $self->{attach_rfc822};
|
||||
my $encoded = "";
|
||||
|
||||
# If we have boundaries we parse the body to the boundary
|
||||
if (defined $outer_bound) {
|
||||
$self->debug("Parsing to boundary.") if $self->{_debug} > 1;
|
||||
$state = $self->_parse_to_bound($outer_bound, $in, \$encoded) or return;
|
||||
}
|
||||
# Else we would parse the rest of the input stream as the rest of the message
|
||||
else {
|
||||
$self->debug("No Boundries.") if $self->{_debug} > 1;
|
||||
$encoded = $$in;
|
||||
$state = 'EOF';
|
||||
}
|
||||
|
||||
# Normal part so we get the body and decode it.
|
||||
if (!$reparse) {
|
||||
$self->debug("Not reparsing.") if $self->{_debug} > 1;
|
||||
$part->{body_in} = 'MEMORY';
|
||||
|
||||
my $decoder = $DecoderFor{lc($encoding)};
|
||||
$self->debug("Decoding part using: " . lc($encoding)) if $self->{_debug};
|
||||
$part->{data} = '';
|
||||
my $out = '';
|
||||
my $res = $self->$decoder(\$encoded, \$out);
|
||||
undef $encoded;
|
||||
$res or return;
|
||||
$part->{data} = $out;
|
||||
undef $out;
|
||||
}
|
||||
else {
|
||||
# If have an embeded email we reparse it.
|
||||
$self->debug("Reparsing enclosed message.") if $self->{_debug};
|
||||
my $out = '';
|
||||
|
||||
my $decoder = $DecoderFor{lc($encoding)};
|
||||
$self->debug("Decoding " . lc($encoding)) if $self->{_debug};
|
||||
my $res = $self->$decoder(\$encoded, \$out);
|
||||
undef $encoded;
|
||||
$res or return;
|
||||
my $p = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
|
||||
push @{$part->{parts}}, $p;
|
||||
$self->_parse_part(undef, \$out, $p) or return;
|
||||
}
|
||||
}
|
||||
return ($part, $state);
|
||||
}
|
||||
|
||||
sub _parse_to_bound {
|
||||
# --------------------------------------------------------------------------
|
||||
# This method takes a boundary ($bound), an input string ref ($in), and an
|
||||
# output string ref ($out). It will place into $$out the data contained by
|
||||
# $bound, and remove the entire region (including boundary) from $$in.
|
||||
#
|
||||
my ($self, $bound, $in, $out) = @_;
|
||||
|
||||
# Set up strings for faster checking:
|
||||
my ($delim, $close) = ("--$bound", "--$bound--");
|
||||
$self->debug("Parsing bounds. Skip until\n\tdelim ($delim)\n\tclose ($close)") if $self->{_debug} > 1;
|
||||
my ($pos, $ret);
|
||||
|
||||
# Place our part in $$out.
|
||||
$$out = undef;
|
||||
if (defined($pos = index($$in, "$CRLF$delim$CRLF")) and $pos != -1) {
|
||||
$$out = substr($$in, 0, $pos);
|
||||
substr($$in, 0, $pos + length("$CRLF$delim$CRLF")) = "";
|
||||
$ret = 'DELIM';
|
||||
}
|
||||
elsif (index($$in, "$delim$CRLF") == 0) {
|
||||
substr($$in, 0, length("$delim$CRLF")) = "";
|
||||
$$out = "";
|
||||
$ret = 'DELIM';
|
||||
}
|
||||
elsif (defined($pos = index($$in, "$CRLF$close$CRLF")) and $pos != -1) {
|
||||
$$out = $$in;
|
||||
substr($$out, -(length($$out) - $pos)) = '';
|
||||
my $len = (length($$in) - (length("$CRLF$close$CRLF") + $pos)) * -1;
|
||||
if ($len == 0) {
|
||||
$$in = '';
|
||||
}
|
||||
else {
|
||||
$$in = substr($$in, $len);
|
||||
}
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
elsif (index($$in, "$CRLF$close") == (length($$in) - length("$CRLF$close"))) {
|
||||
$$out = substr($$in, 0, length($$in) - length("$CRLF$close"));
|
||||
$$in = "";
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
elsif (index($$in, "$close$CRLF") == 0) {
|
||||
$$out = "";
|
||||
substr($$in, 0, length("$close$CRLF")) = "";
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
elsif (index($$in, $close) == 0 and (length($$in) == length($close))) {
|
||||
$$out = "";
|
||||
$$in = "";
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
|
||||
if (defined $$out) {
|
||||
return $ret;
|
||||
}
|
||||
else {
|
||||
# Broken Email, retype to text/plain
|
||||
$self->{parts}->[$#{$self->{parts}}]->set('content-type' => 'text/plain');
|
||||
$$out = $$in;
|
||||
return 'CLOSE';
|
||||
}
|
||||
}
|
||||
|
||||
sub _parse_preamble {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses preamble and sets it in part.
|
||||
#
|
||||
my ($self, $inner_bound, $in, $part) = @_;
|
||||
|
||||
my $loc;
|
||||
my ($delim, $close) = ("--$inner_bound", "--$inner_bound--");
|
||||
|
||||
$self->debug("Parsing preamble. Skip until\n\tdelim ($delim)\n\tclose ($close)") if $self->{_debug} > 1;
|
||||
my @saved;
|
||||
$part->preamble(\@saved);
|
||||
|
||||
my ($data, $pos, $len);
|
||||
if (index($$in, "$delim$CRLF") == 0) {
|
||||
$data = '';
|
||||
substr($$in, 0, length("$delim$CRLF")) = '';
|
||||
}
|
||||
else {
|
||||
$pos = index($$in, "$CRLF$delim$CRLF");
|
||||
if ($pos >= 0) {
|
||||
$data = substr($$in, 0, $pos);
|
||||
substr($$in, 0, $pos + length("$CRLF$delim$CRLF")) = '';
|
||||
}
|
||||
elsif ($pos == -1) {
|
||||
return $self->error('PARSE', 'WARN', "Unable to find opening boundary: " .
|
||||
"$delim\n" .
|
||||
"Message is probably corrupt.");
|
||||
}
|
||||
}
|
||||
push @saved, split $CRLF => $data;
|
||||
undef $data;
|
||||
return 'DELIM';
|
||||
}
|
||||
|
||||
sub _parse_epilogue {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses epilogue and sets it in part.
|
||||
#
|
||||
my ($self, $outer_bound, $in, $part) = @_;
|
||||
my ($delim, $close, $loc);
|
||||
|
||||
($delim, $close) = ("--$outer_bound", "--$outer_bound--") if defined $outer_bound;
|
||||
|
||||
$self->debug("Parsing epilogue. Skip until\n\tdelim (" . ($delim || '') .
|
||||
")\n\tclose (" . ($close || '') . ")")
|
||||
if $self->{_debug} > 1;
|
||||
my @saved;
|
||||
$part->epilogue(\@saved);
|
||||
if (defined $outer_bound) {
|
||||
if ($$in =~ s/(.*?)(?:\A|$CRLF)\Q$delim\E$CRLF//s) {
|
||||
push(@saved, split($CRLF => $1));
|
||||
$self->debug("Found delim($delim)") if $self->{_debug};
|
||||
return 'DELIM'
|
||||
}
|
||||
elsif ($$in =~ s/(.*?)(?:\A|$CRLF)\Q$close\E(?:\Z|$CRLF)//s) {
|
||||
push(@saved, split($CRLF => $1));
|
||||
$self->debug("Found close($close)") if $self->{_debug};
|
||||
return 'CLOSE'
|
||||
}
|
||||
}
|
||||
push(@saved, split($CRLF => $$in));
|
||||
$$in = '';
|
||||
$self->debug("EOF: epilogue is " . length(join '', @saved) . " bytes") if $self->{_debug};
|
||||
return 'EOF';
|
||||
}
|
||||
|
||||
|
||||
sub Base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
|
||||
# Remove any non base64 characters.
|
||||
$$in =~ tr{A-Za-z0-9+/}{}cd;
|
||||
|
||||
# Must pass multiple of 4 to decode_base64. Store any remainder in $rem_str and
|
||||
# pad it with trailing equal signs.
|
||||
my $rem = length($$in) % 4;
|
||||
my ($rem_str);
|
||||
if ($rem) {
|
||||
my $pad = '=' x (4 - $rem);
|
||||
$rem_str = substr($$in, length($$in) - $rem);
|
||||
$rem_str .= $pad;
|
||||
substr($$in, $rem * -1) = '';
|
||||
}
|
||||
|
||||
$$out = decode_base64($$in);
|
||||
if ($rem) {
|
||||
$$out .= decode_base64($rem_str);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub Binary {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
$$out = $$in;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub NBit {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
$$out = $$in;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub QuotedPrint {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
if ($use_decode_qp) {
|
||||
$$out = MIME::QuotedPrint::decode_qp($$in);
|
||||
}
|
||||
else {
|
||||
$$out = $$in;
|
||||
$$out =~ s/\r\n/\n/g; # normalize newlines
|
||||
$$out =~ s/[ \t]+\n/\n/g; # rule #3 (trailing whitespace must be deleted)
|
||||
$$out =~ s/=\n//g; # rule #5 (soft line breaks)
|
||||
$$out =~ s/=([\da-fA-F]{2})/chr hex $1/ge;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub UU {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
my ($mode, $file);
|
||||
|
||||
# Find beginning...
|
||||
while ($$in =~ s/^(.+$CRLF)//o) {
|
||||
local $_ = $1;
|
||||
last if ($mode, $file) = /^begin\s*(\d*)\s*(\S*)/;
|
||||
}
|
||||
return $self->error("uu decoding: no begin found", 'WARN') if (!defined($_));
|
||||
|
||||
# Decode:
|
||||
while ($$in =~ s/^(.+$CRLF)//o) {
|
||||
local $_ = $1;
|
||||
last if /^end/;
|
||||
next if /[a-z]/;
|
||||
next unless int((((ord() - 32) & 077) + 2) / 3) == int(length($_) / 4);
|
||||
$$out .= unpack('u', $_);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub gt_old_decode_base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my $str = shift;
|
||||
my $res = "";
|
||||
|
||||
$str =~ tr|A-Za-z0-9+=/||cd;
|
||||
|
||||
$str =~ s/=+$//;
|
||||
$str =~ tr|A-Za-z0-9+/| -_|;
|
||||
return "" unless length $str;
|
||||
|
||||
my $uustr = '';
|
||||
my ($i, $l);
|
||||
$l = length($str) - 60;
|
||||
for ($i = 0; $i <= $l; $i += 60) {
|
||||
$uustr .= "M" . substr($str, $i, 60);
|
||||
}
|
||||
$str = substr($str, $i);
|
||||
# and any leftover chars
|
||||
if ($str ne "") {
|
||||
$uustr .= chr(32 + length($str)*3/4) . $str;
|
||||
}
|
||||
return unpack("u", $uustr);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Parse - MIME Parse
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::Parse
|
||||
|
||||
my $parser = new GT::Mail::Parse (
|
||||
naming => \&name_files,
|
||||
in_file => '/path/to/file.eml',
|
||||
debug => 1
|
||||
);
|
||||
|
||||
my $top = $parser->parse or die $GT::Mail::Parse::error;
|
||||
|
||||
- or -
|
||||
|
||||
my $parser = new GT::Mail::Parse;
|
||||
|
||||
open FH, '/path/to/file.eml' or die $!;
|
||||
my $top = $parser->parse (
|
||||
naming => \&name_files,
|
||||
handle => \*FH,
|
||||
debug => 1
|
||||
) or die $GT::Mail::Parse::error;
|
||||
close FH;
|
||||
|
||||
- or -
|
||||
|
||||
my $parser = new GT::Mail::Parse;
|
||||
|
||||
my $top_head = $parser->parse_head (
|
||||
naming => \&name_files,
|
||||
in_file => '/path/to/file.eml',
|
||||
debug => 1
|
||||
) or die $GT::Mail::Parse::error;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Parse is a 100% rfc822 email MIME parser that supports unlimited
|
||||
nested levels of MIME. Emails are parsed into L<GT::Mail::Parts> objects. Each
|
||||
part knows where it's body is and each part contains it's sub parts. See
|
||||
L<GT::Mail::Parts> for details on parts methods.
|
||||
|
||||
=head2 new - Constructor method
|
||||
|
||||
This is the constructor method to get a GT::Mail::Parse object, which you
|
||||
need to access all the methods (there are no Class methods). new() takes
|
||||
a hash or hash ref as it's arguments. Each key has an accessor method by the
|
||||
same name except debug, which can only be set by passing debug to new(), parse()
|
||||
or parse_head().
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debug level for this insance of the class.
|
||||
|
||||
=item naming
|
||||
|
||||
Specify a code reference to use as a naming convention for each part of the
|
||||
email being parsed. This is useful to keep file IO down when you want the emails
|
||||
seperated into each part as a file. If this is not specified GT::Mail::Parse
|
||||
uses a default naming, which is to start at one and incriment that number for each
|
||||
attachment. The attachments would go in the current working directory.
|
||||
|
||||
=item in_file
|
||||
|
||||
Specify the path to the file that contains the email to be parsed. One of in_file
|
||||
and handle must be specified.
|
||||
|
||||
=item handle
|
||||
|
||||
Specify the file handle or IO stream that contains the email to be parsed.
|
||||
|
||||
=back
|
||||
|
||||
=item attach_rfc822
|
||||
|
||||
By default, the parser will decode any embeded emails, and flatten out all the
|
||||
parts. If you prefer to leave embeded emails unparsed, pass in 1 to this option
|
||||
and the parser will treat it as an attachment.
|
||||
|
||||
=back
|
||||
|
||||
=head2 parse - Parse an email
|
||||
|
||||
Instance method. Parses the email specified by either in_file or handle. Returns
|
||||
the top level L<GT::Mail::Parts> object. Any additional parameters passed in are
|
||||
treated the same as if they were passed to the constuctor.
|
||||
|
||||
=head2 parse_head - Parse just the header of the email
|
||||
|
||||
Instance method. This method is exactly the same as parse except only the top
|
||||
level header is parsed and it's part object returned. This is useful to keep
|
||||
overhead down if you only need to know about the header of the email.
|
||||
|
||||
=head2 size - Get the size
|
||||
|
||||
Instance method. Returns the total size in bytes of the parsed unencoded email. This
|
||||
method will return undef if no email has been parsed.
|
||||
|
||||
=head2 all_parts - Get all parts
|
||||
|
||||
Instance method. Returns all the parts in the parsed email. This is a flatened
|
||||
list of the objects. Somewhat similar to what MIME::Tools does. All the parts
|
||||
still contain their sub parts.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Parse.pm,v 1.79 2004/10/23 02:16:39 brewt Exp $
|
||||
|
||||
1225
site/glist/lib/GT/Mail/Parts.pm
Normal file
1225
site/glist/lib/GT/Mail/Parts.pm
Normal file
File diff suppressed because it is too large
Load Diff
481
site/glist/lib/GT/Mail/Send.pm
Normal file
481
site/glist/lib/GT/Mail/Send.pm
Normal file
@@ -0,0 +1,481 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Send
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Send.pm,v 1.53 2004/08/23 20:07:44 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::Mail::Send;
|
||||
|
||||
use strict;
|
||||
use GT::Base;
|
||||
use GT::Socket::Client;
|
||||
use GT::Mail::POP3;
|
||||
use GT::MD5;
|
||||
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS $CRLF %SENDMAIL_ERRORS $HAVE_SSL);
|
||||
|
||||
%SENDMAIL_ERRORS = (
|
||||
64 => 'EX_USAGE',
|
||||
65 => 'EX_DATAERR',
|
||||
66 => 'EX_NOINPUT',
|
||||
67 => 'EX_NOUSER',
|
||||
68 => 'EX_NOHOST',
|
||||
69 => 'EX_UNAVAILABLE',
|
||||
70 => 'EX_SOFTWARE',
|
||||
71 => 'EX_OSERR',
|
||||
72 => 'EX_OSFILE',
|
||||
73 => 'EX_CANTCREAT',
|
||||
74 => 'EX_IOERR',
|
||||
75 => 'EX_TEMPFAIL',
|
||||
76 => 'EX_PROTOCOL',
|
||||
77 => 'EX_NOPERM',
|
||||
78 => 'EX_CONFIG',
|
||||
|
||||
# This is for qmail-inject's version of sendmail
|
||||
# Nice that they are different..
|
||||
111 => 'EX_TEMPFAIL',
|
||||
100 => 'EX_USAGE',
|
||||
);
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.53 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ATTRIBS = {
|
||||
mail => undef,
|
||||
host => undef,
|
||||
port => undef,
|
||||
ssl => undef,
|
||||
from => undef,
|
||||
path => undef,
|
||||
flags => undef,
|
||||
rcpt => undef,
|
||||
user => undef,
|
||||
pass => undef,
|
||||
pbs_user => undef,
|
||||
pbs_pass => undef,
|
||||
pbs_host => undef,
|
||||
pbs_port => undef,
|
||||
pbs_auth_mode => undef,
|
||||
pbs_ssl => undef,
|
||||
debug => 0,
|
||||
};
|
||||
$ERRORS = {
|
||||
HOSTNOTFOUND => "SMTP: server '%s' was not found.",
|
||||
CONNFAILED => "SMTP: connect() failed. reason: %s",
|
||||
SERVNOTAVAIL => "SMTP: Service not available: %s",
|
||||
SSLNOTAVAIL => "SMTP: SSL connections are not available: Net::SSLeay 1.06 or greater not installed.",
|
||||
COMMERROR => "SMTP: Unspecified communications error: '%s'.",
|
||||
USERUNKNOWN => "SMTP: Local user '%s' unknown on host '%s'. Server said: %s",
|
||||
TRANSFAILED => "SMTP: Transmission of message failed: %s",
|
||||
AUTHFAILED => "SMTP: Authentication failed: %s",
|
||||
TOEMPTY => "No To: field specified.",
|
||||
NOMSG => "No message body specified",
|
||||
SENDMAILNOTFOUND => "Sendmail was not defined or not found: %s",
|
||||
NOOPTIONS => "No options were specified. Be sure to pass a hash ref to send()",
|
||||
NOTRANSPORT => "Neither sendmail nor SMTP were specified!",
|
||||
SENDMAIL => "There was a problem sending to Sendmail: (%s)",
|
||||
NOMAILOBJ => "No mail object was specified.",
|
||||
EX_USAGE => "Command line usage error",
|
||||
EX_DATAERR => "Data format error",
|
||||
EX_NOINPUT => "Cannot open input",
|
||||
EX_NOUSER => "Addressee unknown",
|
||||
EX_NOHOST => "Host name unknown",
|
||||
EX_UNAVAILABLE => "Service unavailable",
|
||||
EX_SOFTWARE => "Internal software error",
|
||||
EX_OSERR => "System error (e.g., can't fork)",
|
||||
EX_OSFILE => "Critical OS file missing",
|
||||
EX_CANTCREAT => "Can't create (user) output file",
|
||||
EX_IOERR => "Input/output error",
|
||||
EX_TEMPFAIL => "Temp failure; user is invited to retry",
|
||||
EX_PROTOCOL => "Remote error in protocol",
|
||||
EX_NOPERM => "Permission denied",
|
||||
EX_CONFIG => "Configuration error",
|
||||
EX_UNKNOWN => "Sendmail exited with an unknown exit status: %s"
|
||||
};
|
||||
$CRLF = "\015\012";
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->set(@_);
|
||||
|
||||
# We need either a host or a path to sendmail and an email object
|
||||
$self->{host} or $self->{path} or return $self->error("NOTRANSPORT", "FATAL");
|
||||
exists $self->{mail} or return $self->error("NOMAILOBJ", "FATAL");
|
||||
|
||||
# Set debugging
|
||||
$self->{_debug} = defined($self->{debug}) ? $self->{debug} : $DEBUG;
|
||||
|
||||
# Default port for smtp
|
||||
if ($self->{host} and !$self->{port}) {
|
||||
$self->{port} = $self->{ssl} ? 465 : 25;
|
||||
}
|
||||
|
||||
# Default flags for sendmail
|
||||
elsif ($self->{path}) {
|
||||
($self->{flags}) or $self->{flags} = '-t -oi -oeq';
|
||||
$self->{path} =~ /^\s*(.+?)\s*$/ and $self->{path} = $1; # Untaint
|
||||
(-e $self->{path}) or return $self->error('SENDMAILNOTFOUND', 'FATAL', $1);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub smtp_send {
|
||||
# ---------------------------------------------------------------
|
||||
#
|
||||
my ($self, $sock, $cmd) = @_;
|
||||
|
||||
if (defined $cmd) {
|
||||
print $sock "$cmd$CRLF";
|
||||
$self->debug("SMTP Log: >> $cmd\n") if $self->{debug} > 1;
|
||||
}
|
||||
|
||||
$_ = <$sock>;
|
||||
return if !$_;
|
||||
|
||||
my $resp = $_;
|
||||
if (/^\d{3}-/) {
|
||||
while (defined($_ = <$sock>) and /^\d{3}-/) {
|
||||
$resp .= $_;
|
||||
}
|
||||
$resp .= $_;
|
||||
}
|
||||
$resp =~ s/$CRLF/\n/g;
|
||||
$self->debug("SMTP Log: << $resp") if $self->{debug} > 1;
|
||||
return $resp;
|
||||
}
|
||||
|
||||
sub smtp {
|
||||
# ---------------------------------------------------------------
|
||||
# Opens a smtp port and sends the message headers.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
ref $self or $self = $self->new(@_);
|
||||
|
||||
if ($self->{ssl}) {
|
||||
$HAVE_SSL ||= eval { require Net::SSLeay; Net::SSLeay->require_version(1.06); 1 };
|
||||
$HAVE_SSL or return $self->error('SSLNOTAVAIL', 'FATAL');
|
||||
}
|
||||
|
||||
if ($self->{pbs_host}) {
|
||||
my $pop = GT::Mail::POP3->new(
|
||||
host => $self->{pbs_host},
|
||||
port => $self->{pbs_port},
|
||||
user => $self->{pbs_user},
|
||||
pass => $self->{pbs_pass},
|
||||
auth_mode => $self->{pbs_auth_mode},
|
||||
ssl => $self->{pbs_ssl},
|
||||
debug => $self->{debug}
|
||||
);
|
||||
my $count = $pop->connect();
|
||||
if (!defined($count)) {
|
||||
$self->debug("Couldn't connect to server for POP3 before SMTP authentication: $GT::Mail::POP3::error") if $self->{debug};
|
||||
}
|
||||
else {
|
||||
$pop->quit();
|
||||
}
|
||||
}
|
||||
|
||||
my $sock = GT::Socket::Client->open(
|
||||
host => $self->{host},
|
||||
port => $self->{port},
|
||||
ssl => $self->{ssl}
|
||||
) or return $self->error("CONNFAILED", "WARN", GT::Socket::Client->error);
|
||||
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
local $_;
|
||||
|
||||
# Get the server's greeting message
|
||||
my $resp = $self->smtp_send($sock) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
$resp = $self->smtp_send($sock, "EHLO localhost") or return $self->error('COMMERROR', 'WARN');
|
||||
if ($resp =~ /^[45]/) {
|
||||
$resp = $self->smtp_send($sock, "HELO localhost") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
|
||||
# Authenticate if needed
|
||||
if ($resp =~ /AUTH[ =](.*)/ and $self->{user}) {
|
||||
my $server = uc $1;
|
||||
my $method = '';
|
||||
# These are the authentication types that are supported, ordered by preference
|
||||
for my $m (qw/CRAM-MD5 PLAIN LOGIN/) {
|
||||
if ($server =~ /$m/) {
|
||||
$method = $m;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ($method eq 'CRAM-MD5') {
|
||||
$resp = $self->smtp_send($sock, "AUTH CRAM-MD5") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
my ($challenge) = $resp =~ /\d{3}\s+(.*)/;
|
||||
$challenge = decode_base64($challenge);
|
||||
my $auth = encode_base64("$self->{user} " . hmac_md5_hex($challenge, $self->{pass}));
|
||||
|
||||
$resp = $self->smtp_send($sock, $auth) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
elsif ($method eq 'PLAIN') {
|
||||
my $auth = encode_base64("$self->{user}\0$self->{user}\0$self->{pass}");
|
||||
$resp = $self->smtp_send($sock, "AUTH PLAIN $auth") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
elsif ($method eq 'LOGIN') {
|
||||
$resp = $self->smtp_send($sock, "AUTH LOGIN") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
$resp = $self->smtp_send($sock, encode_base64($self->{user})) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
$resp = $self->smtp_send($sock, encode_base64($self->{pass})) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
}
|
||||
|
||||
# We use return-path so the email will bounce to who it's from, not the user
|
||||
# doing the sending.
|
||||
my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
|
||||
$from = $self->extract_email($from) || '';
|
||||
|
||||
$self->debug("Sending from: <$from>") if $self->{debug} == 1;
|
||||
$resp = $self->smtp_send($sock, "MAIL FROM: <$from>") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
my $found_valid = 0;
|
||||
my @tos = ($self->{mail}->{head}->split_field('to'), $self->{mail}->{head}->split_field('bcc'), $self->{mail}->{head}->split_field('cc'));
|
||||
for my $to (@tos) {
|
||||
next unless $to and my $email = $self->extract_email($to);
|
||||
|
||||
$found_valid++;
|
||||
$self->debug("Sending RCPT TO: <$email>.") if $self->{debug} == 1;
|
||||
$resp = $self->smtp_send($sock, "RCPT TO: <$email>") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('USERUNKNOWN', 'WARN', $email, $self->{host}, $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
$found_valid or return $self->error('TOEMPTY', 'FATAL');
|
||||
|
||||
$resp = $self->smtp_send($sock, "DATA") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
# Remove Bcc from the headers.
|
||||
my @bcc = $self->{mail}->{head}->delete('bcc');
|
||||
|
||||
my $mail = $self->{mail}->to_string;
|
||||
|
||||
# SMTP needs any leading .'s to be doubled up.
|
||||
$mail =~ s/^\./../gm;
|
||||
|
||||
# Print the mail body.
|
||||
$resp = $self->smtp_send($sock, $mail . $CRLF . '.') or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('TRANSFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
# Add them back in.
|
||||
foreach my $bcc (@bcc) {
|
||||
$self->{mail}->{head}->set('bcc', $bcc);
|
||||
}
|
||||
|
||||
# Close the connection.
|
||||
$resp = $self->smtp_send($sock, "QUIT") or return $self->error('COMMERROR', 'WARN');
|
||||
close $sock;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub sendmail {
|
||||
# ---------------------------------------------------------------
|
||||
# Sends a message using sendmail.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
ref $self or $self = $self->new(@_);
|
||||
|
||||
# Get a filehandle, and open pipe to sendmail.
|
||||
my $s = \do{ local *FH; *FH };
|
||||
|
||||
# If the email address is safe, we set the envelope via -f so bounces are handled properly.
|
||||
my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
|
||||
my $envelope = '';
|
||||
if ($from =~ /<?([\w\-\.]+\@[\w\-\.]+)>?/) {
|
||||
$envelope = "-f $1";
|
||||
}
|
||||
elsif ($from eq '<>' or $from eq '') {
|
||||
$envelope = "-f ''";
|
||||
}
|
||||
open($s, "|$self->{path} $self->{flags} $envelope 1>&2") or return $self->error("SENDMAIL", "WARN", "$!");
|
||||
$self->{mail}->write($s);
|
||||
return 1 if close $s;
|
||||
my $exit_value = $? >> 8;
|
||||
|
||||
my $code;
|
||||
if (exists $SENDMAIL_ERRORS{$exit_value}) {
|
||||
$code = $SENDMAIL_ERRORS{$exit_value};
|
||||
}
|
||||
else {
|
||||
$code = 'EX_UNKNOWN';
|
||||
}
|
||||
if ($code eq 'EX_TEMPFAIL') {
|
||||
return 1;
|
||||
}
|
||||
return $self->error($code, "WARN", $exit_value);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub extract_email {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes a field, returns the e-mail address contained in that field, or undef
|
||||
# if no e-mail address could be found.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
|
||||
my $to = shift;
|
||||
|
||||
# We're trying to get down to the actual e-mail address. To do so, we have to
|
||||
# remove quoted strings and comments, then extract the e-mail from whatever is
|
||||
# left over.
|
||||
$to =~ s/"(?:[^"\\]|\\.)*"//g;
|
||||
1 while $to =~ s/\((?:[^()\\]|\\.)*\)//sg;
|
||||
|
||||
my ($email) = $to =~ /([^<>\s]+\@[\w.-]+)/;
|
||||
|
||||
return $email;
|
||||
}
|
||||
|
||||
sub encode_base64 {
|
||||
my $res = '';
|
||||
pos($_[0]) = 0; # In case something has previously adjusted pos
|
||||
while ($_[0] =~ /(.{1,45})/gs) {
|
||||
$res .= substr(pack(u => $1), 1, -1);
|
||||
}
|
||||
$res =~ tr|` -_|AA-Za-z0-9+/|;
|
||||
|
||||
my $padding = (3 - length($_[0]) % 3) % 3;
|
||||
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
|
||||
$res;
|
||||
}
|
||||
|
||||
sub decode_base64 {
|
||||
my $str = shift;
|
||||
my $res = '';
|
||||
|
||||
$str =~ tr|A-Za-z0-9+=/||cd;
|
||||
|
||||
$str =~ s/=+$//;
|
||||
$str =~ tr|A-Za-z0-9+/| -_|;
|
||||
return '' unless length $str;
|
||||
|
||||
my $uustr = '';
|
||||
my ($i, $l);
|
||||
$l = length($str) - 60;
|
||||
for ($i = 0; $i <= $l; $i += 60) {
|
||||
$uustr .= "M" . substr($str, $i, 60);
|
||||
}
|
||||
$str = substr($str, $i);
|
||||
# and any leftover chars
|
||||
if ($str ne "") {
|
||||
$uustr .= chr(32 + length($str) * 3 / 4) . $str;
|
||||
}
|
||||
return unpack("u", $uustr);
|
||||
}
|
||||
|
||||
sub hmac_md5_hex {
|
||||
my ($challenge, $data) = @_;
|
||||
|
||||
GT::MD5::md5($challenge) if length $challenge > 64;
|
||||
|
||||
my $ipad = $data ^ (chr(0x36) x 64);
|
||||
my $opad = $data ^ (chr(0x5c) x 64);
|
||||
|
||||
return GT::MD5::md5_hex($opad, GT::MD5::md5($ipad, $challenge));
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Send - Module to send emails
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::Send;
|
||||
|
||||
# $mail_object must be a GT::Mail object
|
||||
my $send = new GT::Mail::Send (
|
||||
mail => $mail_object,
|
||||
host => 'smtp.gossamer-threads.com',
|
||||
debug => 1
|
||||
);
|
||||
|
||||
$send->smtp or die $GT::Mail::Send::error;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Send is an object interface to sending email over either
|
||||
SMTP or Sendmail. This module is used internally to GT::Mail.
|
||||
|
||||
=head2 new - Constructor method
|
||||
|
||||
Returns a new GT::Mail::Send object. You must specify either the smtp host
|
||||
or a path to sendmail. This method is inherented from GT::Base. The arguments
|
||||
can be in the form of a hash or hash ref.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debug level for this instance of GT::Mail::Send.
|
||||
|
||||
=item mail
|
||||
|
||||
Specify the mail object to use. This must be a GT::Mail object and must contain
|
||||
an email, either passed in or parsed in.
|
||||
|
||||
=item host
|
||||
|
||||
Specify the host to use when sending by SMTP.
|
||||
|
||||
=item port
|
||||
|
||||
Specify the port to use when sending over SMTP. Defaults to 25.
|
||||
|
||||
=item path
|
||||
|
||||
Specify the path to sendmail when sending over sendmail. If the binary passed in
|
||||
does not exist, undef will be returned and the error set in GT::Mail::Send::error.
|
||||
|
||||
=item flags
|
||||
|
||||
Specify the flags used to call sendmail. Defaults to -t -oi -oeq, see the Sendmail
|
||||
guilde for sendmail for more info on the parameters to sendmail.
|
||||
|
||||
=back
|
||||
|
||||
=head2 smtp
|
||||
|
||||
Class or instance method. Sends the passed in email over SMTP. If called as a class
|
||||
method, the parameters passed in will be used to call new(). Returns true on error,
|
||||
false otherwise.
|
||||
|
||||
=head2 sendmail
|
||||
|
||||
Class or instance method. Send the passed in email to sendmail using the specified
|
||||
path and flags. If called as a class method all additional arguments are passed to the
|
||||
new() method. Returns true on success and false otherwise.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Send.pm,v 1.53 2004/08/23 20:07:44 jagerman Exp $
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
424
site/glist/lib/GT/Plugins.pm
Normal file
424
site/glist/lib/GT/Plugins.pm
Normal file
@@ -0,0 +1,424 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Plugins.pm,v 1.55 2005/04/01 00:16:51 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A plugin system for CGI scripts.
|
||||
#
|
||||
|
||||
package GT::Plugins;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
# TODO: Eventually we want to get rid of the $ACTION global, but it would break
|
||||
# rather a lot to do so.
|
||||
use vars qw/$VERSION $DEBUG $ERRORS $ATTRIBS $ACTION $error @ISA $AUTOLOAD @EXPORT/;
|
||||
use GT::Base;
|
||||
use GT::Config;
|
||||
use GT::AutoLoader;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$ERRORS = {
|
||||
BADARGS => "Invalid arguments. Usage: %s",
|
||||
CANTLOAD => "Unable to load plugin '%s': %s",
|
||||
CANTOPEN => "Unable to open '%s': %s",
|
||||
CANTDELETE => "Unable to remove plugin file '%s': %s",
|
||||
CANTMOVE => "Unable to move plugin %s from '%s' to '%s': %s",
|
||||
CANTREMOVE => "Unable to remove plugin file '%s': %s",
|
||||
PLUGEXISTS => "The plugin '%s' already exists, unable to overwrite without confirmation",
|
||||
NOINSTALL => "Unable to load install code in plugin '%s'. Missing Install.pm file.",
|
||||
NOCODE => "Unable to load main code for plugin '%s' from tar file. Missing '%s.pm' file.",
|
||||
NOPLUGINNAME => "Please name your plugin before calling save()",
|
||||
NOPLUGIN => "There is no plugin named '%s' in the config file.",
|
||||
CORRUPTCFG => "Syntax error in config file: %s",
|
||||
PLUGINERR => "Error running plugin '%s' hook '%s': %s"
|
||||
};
|
||||
$ATTRIBS = { directory => undef, prefix => '' };
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
# Actions that plugins can handle.
|
||||
use constants
|
||||
STOP => 1,
|
||||
CONTINUE => 2,
|
||||
|
||||
NAME => 0,
|
||||
TYPE => 1,
|
||||
HOOK => 2,
|
||||
ENABLED => 3;
|
||||
|
||||
@EXPORT = qw/STOP CONTINUE/;
|
||||
|
||||
sub init {
|
||||
# -----------------------------------------------------------------
|
||||
# Set our debug level and any extra options.
|
||||
#
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
if (@args == 1 and not ref $args[0]) {
|
||||
@args = (directory => @args);
|
||||
}
|
||||
|
||||
$self->set(@args);
|
||||
|
||||
if ($self->{debug}) {
|
||||
$self->{_debug} = delete $self->{debug};
|
||||
}
|
||||
|
||||
$self->{directory} or $self->fatal(BADARGS => 'No directory passed to GT::Plugins->new()');
|
||||
|
||||
$self->load_cfg;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub active_plugins {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Class/object method that returns a boolean value indicating whether or not
|
||||
# the given argument (a plugin hook name) has any registered plugin hooks.
|
||||
# Primarily designed for optimizations where a section of code isn't needed
|
||||
# except for plugins.
|
||||
#
|
||||
my $self = shift;
|
||||
my $config = ref $self ? $self->{config} : $self->load_cfg(shift);
|
||||
|
||||
my $hook_name = lc shift;
|
||||
|
||||
return (
|
||||
exists $config->{_pre_hooks}->{$hook_name} and @{$config->{_pre_hooks}->{$hook_name}} or
|
||||
exists $config->{_post_hooks}->{$hook_name} and @{$config->{_post_hooks}->{$hook_name}}
|
||||
) ? 1 : undef;
|
||||
}
|
||||
|
||||
sub dispatch {
|
||||
# -----------------------------------------------------------------
|
||||
# Class Method to Run plugins.
|
||||
#
|
||||
my $self = shift;
|
||||
my $directory;
|
||||
my $config = ref $self ? $self->{config} : $self->load_cfg($directory = shift);
|
||||
my ($hook_name, $code, @args) = @_;
|
||||
|
||||
$hook_name = lc $hook_name;
|
||||
|
||||
# Run any pre hooks.
|
||||
my @results;
|
||||
my $debug = ref $self ? $self->{_debug} : $DEBUG;
|
||||
|
||||
if (exists $config->{_pre_hooks}->{$hook_name}) {
|
||||
local $^W; no strict 'refs';
|
||||
# Save our action in case plugins is called twice.
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_pre_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: pre $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'PRE') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->(@args);
|
||||
if ($ACTION == STOP) {
|
||||
$self->debug("Plugin pre hook $hook_name stopped further plugins.") if $debug;
|
||||
last;
|
||||
}
|
||||
}
|
||||
unless ($ACTION == STOP) {
|
||||
@results = $code->(@args);
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
else {
|
||||
@results = $code->(@args);
|
||||
}
|
||||
|
||||
# Run any post hooks.
|
||||
if (exists $config->{_post_hooks}->{$hook_name}) {
|
||||
local ($^W); no strict 'refs';
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_post_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: post $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'POST') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->(@results);
|
||||
if ($ACTION == STOP) {
|
||||
$self->debug("Plugin post hook $hook_name stopped further plugins.") if $debug;
|
||||
last;
|
||||
}
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
|
||||
# Must return as a list
|
||||
return @results ? (@results)[0 .. $#results] : ();
|
||||
}
|
||||
|
||||
sub dispatch_method {
|
||||
# -----------------------------------------------------------------
|
||||
# Class Method to Run plugins.
|
||||
#
|
||||
my $self = shift;
|
||||
my $directory;
|
||||
my $config = ref $self ? $self->{config} : $self->load_cfg($directory = shift);
|
||||
my ($hook_name, $object, $method, @args) = @_;
|
||||
$hook_name = lc $hook_name;
|
||||
|
||||
my $debug = ref $self ? $self->{_debug} : $DEBUG;
|
||||
|
||||
# Run any pre hooks.
|
||||
my @results;
|
||||
if (exists $config->{_pre_hooks}->{$hook_name}) {
|
||||
local ($^W); no strict 'refs';
|
||||
# Save our action in case plugins is called twice.
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_pre_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: pre $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'PRE') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->($object, @args);
|
||||
$ACTION == STOP and last;
|
||||
}
|
||||
unless ($ACTION == STOP) {
|
||||
@results = $object->$method(@args);
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
else {
|
||||
@results = $object->$method(@args);
|
||||
}
|
||||
|
||||
# Run any post hooks.
|
||||
if (exists $config->{_post_hooks}->{$hook_name}) {
|
||||
local ($^W); no strict 'refs';
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_post_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: post $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'POST') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->($object, @results);
|
||||
# If the post hook returned the object as the first return value
|
||||
# that probably means it returned @_ unaltered, in which case we
|
||||
# want to remove it so that @results doesn't end up with any number
|
||||
# of objects stuck to the beginning of arguments/return values.
|
||||
shift @results if ref $object and ref $results[0] and $object == $results[0];
|
||||
|
||||
$ACTION == STOP and last;
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
|
||||
# Must return as a list
|
||||
return @results ? (@results)[0 .. $#results] : ();
|
||||
}
|
||||
|
||||
sub load_cfg {
|
||||
# -----------------------------------------------------------------
|
||||
# Load the plugin config file.
|
||||
#
|
||||
my ($self, $directory) = @_;
|
||||
$directory ||= ref $self ? $self->{directory} : '.';
|
||||
|
||||
my $cfg = GT::Config->load("$directory/plugin.cfg", { local => 0, inheritance => 0, create_ok => 1 });
|
||||
|
||||
if (!$cfg and ref $self ? $self->{_debug} : $DEBUG) {
|
||||
$self->debug("Unable to load plugin config file '$directory/plugin.cfg': $GT::Config::error");
|
||||
}
|
||||
|
||||
# Take care to delete _pre_hooks just in case the file was somehow saved
|
||||
# with _pre_hooks in it.
|
||||
delete $cfg->{_pre_hooks} if not $cfg->cache_hit;
|
||||
|
||||
# If _pre_hooks exists, the config was loaded from the cache, and the below
|
||||
# has already been calculated.
|
||||
unless ($cfg->{_pre_hooks}) {
|
||||
$cfg->{_pre_hooks} = {};
|
||||
$cfg->{_post_hooks} = {};
|
||||
while (my ($plugin, $config) = each %$cfg) {
|
||||
next if substr($plugin, 0, 1) eq '_' or ref $config->{hooks} ne 'ARRAY';
|
||||
for my $hook (@{$config->{hooks}}) {
|
||||
next unless $hook->[ENABLED] and ($hook->[TYPE] eq 'PRE' or $hook->[TYPE] eq 'POST');
|
||||
push @{$cfg->{$hook->[TYPE] eq 'PRE' ? '_pre_hooks' : '_post_hooks'}->{lc $hook->[NAME]}}, $hook->[HOOK];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$self->{config} = $cfg if ref $self;
|
||||
return $cfg;
|
||||
}
|
||||
|
||||
$COMPILE{save_cfg} = __LINE__ . <<'END_OF_SUB';
|
||||
sub save_cfg {
|
||||
# -----------------------------------------------------------------
|
||||
# Save the plugin cfg file. OO usage: $plugin_obj->save; Deprecated, non-OO
|
||||
# usage: GT::Plugins->save_cfg($plugin_config_object); Also supported is:
|
||||
# GT::Plugins->save_cfg($ignored_value, $plugin_config_object); for
|
||||
# compatibility reasons. These are almost equivelant to
|
||||
# $plugin_config_object->save, except that they remove the internal _pre_hooks
|
||||
# and _post_hooks keys first, then restore them after saving.
|
||||
#
|
||||
my $self = shift;
|
||||
my $config = ref $self ? $self->{config} : @_ > 1 ? $_[1] : $_[0];
|
||||
|
||||
my ($pre, $post) = delete @$config{qw/_pre_hooks _post_hooks/};
|
||||
|
||||
$config->save();
|
||||
|
||||
@$config{qw/_pre_hooks _post_hooks/} = ($pre, $post);
|
||||
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub action {
|
||||
# -------------------------------------------------------------------
|
||||
# Sets the action the plugin wants.
|
||||
#
|
||||
$ACTION = $_[1];
|
||||
}
|
||||
|
||||
$COMPILE{_load_hook} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _load_hook {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a module and checks for the hook.
|
||||
#
|
||||
my ($self, $hook, $stage) = @_;
|
||||
my ($pkg) = $hook =~ /^(.*)::[^:]+$/ or return;
|
||||
$pkg =~ s,::,/,g;
|
||||
{
|
||||
local $SIG{__DIE__};
|
||||
eval { require "$pkg.pm" };
|
||||
}
|
||||
if ($@) {
|
||||
return $self->error('PLUGINERR', 'FATAL', $stage, $hook, "$@");
|
||||
}
|
||||
if (! defined &{$hook}) {
|
||||
return $self->error('PLUGINERR', 'FATAL', $stage, $hook, "$hook does not exist in $pkg");
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{reset_env} = __LINE__ . <<'END_OF_SUB';
|
||||
sub reset_env { }
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Plugins - a plugin interface for Gossamer Threads products.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Plugins;
|
||||
$PLUGIN = GT::Plugins->new('/path/to/plugin/dir');
|
||||
|
||||
$PLUGIN->dispatch(hook_name => \&code_ref => @args);
|
||||
$PLUGIN->dispatch_method(hook_name => $self => method => @args);
|
||||
|
||||
Old style, now deprecated in favour of the object approach above:
|
||||
|
||||
use GT::Plugins;
|
||||
|
||||
GT::Plugins->dispatch('/path/to/plugin/dir', hook_name => \&code_ref => @args);
|
||||
GT::Plugins->dispatch_method('/path/to/plugin/dir', hook_name => $self => method => @args);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The plugin module supports two modes of use. The first mode involves creating
|
||||
and using a GT::Plugins object upon which plugin dispatch methods may be called
|
||||
to provide hooks. The second does not use the object, but instead uses class
|
||||
methods with an extra argument of the plugin path preceding the other
|
||||
->dispatch() arguments.
|
||||
|
||||
Of the two approaches, the object approach is recommended as it is a) faster,
|
||||
and b) requires much less value duplication as the plugin directory needs to be
|
||||
specified only once. The old, class-method-based plugin interface should be
|
||||
considered deprecated, and all new code should attempt to use the object-based
|
||||
system.
|
||||
|
||||
A dispatch with each of the two interfaces work as follows, with differences in
|
||||
interfaces as noted:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
Loads the plugin config file. The actual file access and evaluation will be
|
||||
cached, but a small amount of extra overhead is required on each dispatch.
|
||||
This only applies to the deprecated class-method dispatch interface - the
|
||||
preferred object interface loads the configuration file only once.
|
||||
|
||||
=item 2.
|
||||
|
||||
Runs any 'PRE' hooks registered in the config file. When using ->dispatch(),
|
||||
each hook is passed the C<@args> arguments passed into ->dispatch. When using
|
||||
->dispatch_method(), both the object ($self) and arguments (@args) are passed
|
||||
to the hook.
|
||||
|
||||
Each plugin hook then has the ability to abort further plugins if desired by
|
||||
calling C<$PLUGIN-E<gt>action(STOP)> (or C<GT::Plugins-E<gt>action(STOP)> for
|
||||
the non-OO interface). STOP is exported by default from the GT::Plugins
|
||||
module. Performing a STOP will skip both any further 'PRE' hooks and the
|
||||
original function/method, and will use the hook's return value instead of the
|
||||
real code's return value.
|
||||
|
||||
The current behaviour of 'PRE' hooks ignores the return value of any 'PRE' hook
|
||||
that does not perform a STOP, however this behaviour B<may> change to use the
|
||||
return value as the arguments to the next PRE hook or actual code called. As
|
||||
such, it is strongly recommended to return @_ from any 'PRE' hooks.
|
||||
|
||||
=item 3.
|
||||
|
||||
Assuming C<-E<gt>action(STOP)> has not been called, the method
|
||||
(->dispatch_method) or code reference (->dispatch) will be called, and its
|
||||
return value stored.
|
||||
|
||||
=item 4.
|
||||
|
||||
Any registered 'POST' hooks registered in the config file will be run. When
|
||||
using ->dispatch(), the list-context return value of the main code run (or, if
|
||||
a 'PRE' hook called STOP, the return value of that 'PRE' hook) will be passed
|
||||
in. When using ->dispatch_method(), the object is additionally passed in as
|
||||
the first argument.
|
||||
|
||||
The list returned by the 'POST' hook will be used as arguments for any
|
||||
subsequent 'POST' hooks and as the final result returned by the ->dispatch() or
|
||||
->dispatch_method() call. There is one exception to this - for
|
||||
->dispatch_method() 'POST' hooks, if the first argument of the return value is
|
||||
the object, it will be removed; this is done to prevent a build-up of excess
|
||||
objects at the beginning of the 'POST' hook arguments/return values due to
|
||||
'POST' hooks simply returning @_ unaltered.
|
||||
|
||||
=item 5.
|
||||
|
||||
The return value of the final 'POST' hook, or, when no post hooks are
|
||||
configured, of the actual code, is returned as the result of the ->dispatch()
|
||||
call.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Also included as part of the plugin system are some modules for web based tools
|
||||
to manage plugins:
|
||||
|
||||
L<GT::Plugins::Manager> - Add, remove and edit plugin files.
|
||||
|
||||
L<GT::Plugins::Wizard> - Create shell plugins.
|
||||
|
||||
L<GT::Plugins::Installer> - Used in installing plugins.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Plugins.pm,v 1.55 2005/04/01 00:16:51 brewt Exp $
|
||||
|
||||
=cut
|
||||
837
site/glist/lib/GT/Plugins/Author.pm
Normal file
837
site/glist/lib/GT/Plugins/Author.pm
Normal file
@@ -0,0 +1,837 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Author.pm,v 1.14 2004/01/13 01:35:18 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A web based admin to package new plugins.
|
||||
#
|
||||
|
||||
package GT::Plugins::Author;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use lib '../..';
|
||||
use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $ERRORS $DEBUG $PLUGIN_DIR $FONT/;
|
||||
use GT::Base;
|
||||
use GT::Plugins;
|
||||
use GT::Template;
|
||||
use GT::Dumper;
|
||||
use GT::Tar;
|
||||
|
||||
$ATTRIBS = {
|
||||
plugin_name => '',
|
||||
prefix => '',
|
||||
version => '',
|
||||
meta => {},
|
||||
pre_install => '',
|
||||
install => '',
|
||||
pre_uninstall => '',
|
||||
uninstall => '',
|
||||
header => '',
|
||||
admin_menu => [],
|
||||
options => {},
|
||||
hooks => [],
|
||||
cfg => undef,
|
||||
tar => undef
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::Plugins';
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;
|
||||
$FONT = 'font face="Tahoma,Arial,Helvetica" size="2"';
|
||||
|
||||
sub init {
|
||||
# ------------------------------------------------------------------
|
||||
# Create a new plugin author object, called from GT::Base on new().
|
||||
#
|
||||
my $self = shift;
|
||||
if (! defined $PLUGIN_DIR) {
|
||||
$PLUGIN_DIR = shift or return $self->error('BADARGS', 'FATAL', "new GT::Plugins::Author ( '/path/to/plugin/dir' )");
|
||||
$PLUGIN_DIR .= $PLUGIN_DIR =~ m,/$, ? "Plugins" : "/Plugins";
|
||||
}
|
||||
$self->{cfg} = GT::Plugins->load_cfg($PLUGIN_DIR);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub list_editable {
|
||||
# ------------------------------------------------------------------
|
||||
# List current plugin names available to be edited.
|
||||
#
|
||||
my $self = shift;
|
||||
my $dir = $PLUGIN_DIR . "/Author";
|
||||
my @projects = ();
|
||||
|
||||
opendir (DIR, $dir) or return $self->error('CANTOPEN', 'FATAL', $dir, $!);
|
||||
while (defined(my $file = readdir(DIR))) {
|
||||
next unless ($file =~ /(.*)\.tar$/);
|
||||
push @projects, $1;
|
||||
}
|
||||
closedir(DIR);
|
||||
return \@projects;
|
||||
}
|
||||
|
||||
sub load_plugin {
|
||||
# ------------------------------------------------------------------
|
||||
# Load a plugin tar file into self.
|
||||
#
|
||||
my ($self, $plugin_name) = @_;
|
||||
$self->{plugin_name} = $plugin_name;
|
||||
$self->{tar} = $self->_load_tar or return;
|
||||
$self->_load_plugin;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub save {
|
||||
# ------------------------------------------------------------------
|
||||
# Save the current state of self into tar file.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{plugin_name} or return $self->error('NOPLUGINNAME', 'WARN');
|
||||
|
||||
|
||||
my ($author);
|
||||
$self->{tar} or $self->_load_tar;
|
||||
foreach my $file ($self->{tar}->files) {
|
||||
if ($file->name =~ /Author\.pm$/) {
|
||||
$author = $file;
|
||||
}
|
||||
}
|
||||
$author ?
|
||||
($author->body( $self->_create_author )) :
|
||||
($author = $self->{tar}->add_data( name => 'Author.pm', body => $self->_create_author ));
|
||||
|
||||
# add files.
|
||||
return $self->{tar}->write();
|
||||
}
|
||||
|
||||
sub add_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the Install.pm file.
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = $self->{tar}->get_file('Install.pm');
|
||||
if ($file) {
|
||||
$self->_replace_install($file);
|
||||
}
|
||||
else {
|
||||
my $time = localtime();
|
||||
my $version = $self->{version} || 0;
|
||||
my $meta_dump = GT::Dumper->dump( var => '$META', data => $self->{meta} );
|
||||
|
||||
my $output = <<END_OF_PLUGIN;
|
||||
# ==================================================================
|
||||
# $self->{prefix}Plugins::$self->{plugin_name} - Auto Generated Install Module
|
||||
#
|
||||
# $self->{prefix}Plugins::$self->{plugin_name}
|
||||
# Author : $self->{meta}->{author}
|
||||
# Version : $self->{version}
|
||||
# Updated : $time
|
||||
#
|
||||
# ==================================================================
|
||||
#
|
||||
|
||||
package $self->{prefix}Plugins::$self->{plugin_name};
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw/\$VERSION \$DEBUG \$NAME \$META/;
|
||||
\$VERSION = $version;
|
||||
\$DEBUG = 0;
|
||||
\$NAME = '$self->{plugin_name}';
|
||||
$meta_dump
|
||||
$self->{header}
|
||||
|
||||
$self->{install}
|
||||
$self->{uninstall}
|
||||
$self->{pre_install}
|
||||
$self->{pre_uninstall}
|
||||
|
||||
1;
|
||||
|
||||
END_OF_PLUGIN
|
||||
$self->{tar}->add_data( name => 'Install.pm', body => $output );
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# HTML Generationg Methods #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub attribs_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns a hash of attribs as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = {
|
||||
plugin => $self->{plugin},
|
||||
version => $self->{version},
|
||||
meta => $self->meta_as_html,
|
||||
install => $self->install_as_html,
|
||||
hooks => $self->hooks_as_html,
|
||||
admin_menu => $self->admin_menu_as_html,
|
||||
options => $self->options_as_html,
|
||||
files => $self->files_as_html,
|
||||
};
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub attribs_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns a hash of attribs in form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = {
|
||||
plugin => $self->{plugin},
|
||||
version => $self->{version},
|
||||
meta => $self->meta_as_form,
|
||||
install => $self->install_as_form,
|
||||
hooks => $self->hooks_as_form,
|
||||
admin_menu => $self->admin_menu_as_form,
|
||||
options => $self->options_as_form,
|
||||
files => $self->files_as_form,
|
||||
};
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub attribs_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Load author from a cgi object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
$self->meta_from_cgi($cgi);
|
||||
$self->install_from_cgi($cgi);
|
||||
$self->hooks_from_cgi($cgi);
|
||||
$self->admin_menu_from_cgi($cgi);
|
||||
$self->options_from_cgi($cgi);
|
||||
$self->files_from_cgi($cgi);
|
||||
}
|
||||
|
||||
sub meta_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = qq~
|
||||
<tr><td><$FONT>Version:</font></td><td><$FONT>~ . _escape_html($self->{version}) . qq~</font></td></tr>
|
||||
<tr><td><$FONT>Author:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{author}) . qq~</font></td></tr>
|
||||
<tr><td><$FONT>URL:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{url}) . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Description:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{description}) . qq~</font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub meta_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = qq~
|
||||
<tr><td><$FONT>Version:</font></td><td><$FONT><input type="text" name="version" value="~ . _escape_html($self->{version}) . qq~"></font></td></tr>
|
||||
<tr><td><$FONT>Author:</font></td><td><$FONT><input type="text" name="author" value="~ . _escape_html($self->{meta}->{author}) . qq~"></font></td></tr>
|
||||
<tr><td><$FONT>URL:</font></td><td><$FONT><input type="text" name="url" value="~ . _escape_html($self->{meta}->{url}) . qq~"></font></td></tr>
|
||||
<tr><td valign="top"><$FONT>Description:</font></td><td><$FONT><textarea cols=50 rows=5 name="description">~ . _escape_html($self->{meta}->{description}) . qq~</textarea></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub meta_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Takes meta information from CGI object and stores it in self.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
$self->{version} = $cgi->param('version');
|
||||
$self->{meta}->{author} = $cgi->param('author');
|
||||
$self->{meta}->{url} = $cgi->param('url');
|
||||
$self->{meta}->{description} = $cgi->param('description');
|
||||
}
|
||||
|
||||
sub install_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns the install information as html.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->_load_install;
|
||||
my $output = qq~
|
||||
<tr><td valign=top><$FONT>Pre Install Message:</font></td><td><$FONT>~ . ($self->{pre_install} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Post Install Message:</font></td><td><$FONT>~ . ($self->{pre_uninstall} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Install Code:</font></td><td><$FONT>~ . ($self->{install} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Uninstall Code:</font></td><td><$FONT>~ . ($self->{uninstall} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub install_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns the install information as a form.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->_load_install;
|
||||
my $output = qq~
|
||||
<tr><td valign=top><$FONT>Pre Install Message:<br>
|
||||
<input type="submit" name="preinst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="pre_install">~ . _escape_html($self->{pre_install}) . qq~</textarea></font></td></tr>
|
||||
<tr><td valign=top><$FONT>Post Install Message:<br>
|
||||
<input type="submit" name="preuninst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="pre_uninstall">~ . _escape_html($self->{pre_uninstall}) . qq~</textarea></font></td></tr>
|
||||
<tr><td valign=top><$FONT>Install Code:<br>
|
||||
<input type="submit" name="inst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="install">~ . _escape_html($self->{install}) . qq~</textarea></font></td></tr>
|
||||
<tr><td valign=top><$FONT>Uninstall Code:<br>
|
||||
<input type="submit" name="uninst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 wrap="off" rows=8 name="uninstall">~ . _escape_html($self->{uninstall}) . qq~</textarea></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub install_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the install information from a CGI object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
|
||||
if ($cgi->param('inst_auto_generate')) {
|
||||
$self->{install} = $self->_create_install;
|
||||
}
|
||||
elsif ($cgi->param('preinst_auto_generate')) {
|
||||
$self->{pre_install} = $self->_create_preinstall;
|
||||
}
|
||||
elsif ($cgi->param('preuninst_auto_generate')) {
|
||||
$self->{pre_uninstall} = $self->_create_preuninstall;
|
||||
}
|
||||
elsif ($cgi->param('uninst_auto_generate')) {
|
||||
$self->{uninstall} = $self->_create_uninstall;
|
||||
}
|
||||
else {
|
||||
$self->{pre_install} = $cgi->param('pre_install');
|
||||
$self->{pre_uninstall} = $cgi->param('pre_uninstall');
|
||||
$self->{install} = $cgi->param('install');
|
||||
$self->{uninstall} = $cgi->param('uninstall');
|
||||
}
|
||||
}
|
||||
|
||||
sub hooks_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns plugin hooks as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{hooks}}) {
|
||||
foreach my $hook (@{$self->{hooks}}) {
|
||||
my ($hook_name, $prepost, $code) = @$hook;
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$hook_name ($prepost)</font></td><td><$FONT>$code</font></td></tr>
|
||||
~;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No hooks installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub hooks_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns plugin hooks as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{hooks}}) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Hooks</font></td></tr>
|
||||
~;
|
||||
my $i = 0;
|
||||
foreach my $hook (@{$self->{hooks}}) {
|
||||
my ($hook_name, $prepost, $code) = @$hook;
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$hook_name ($prepost) => $code</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_hooks" value="$i"></font></td></tr>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
my $pkg = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::";
|
||||
$output .= qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Hook</font></td></tr>
|
||||
<tr><td><$FONT>Hook: <input type="text" name="hook_name" size="10"> <select name="prepost"><option>PRE<option>POST</select></font></td>
|
||||
<td><$FONT>Code: <input type="text" name="code" value="$pkg"></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub hooks_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the hook info based on CGI object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
my @to_delete = $cgi->param('delete_hooks');
|
||||
foreach my $delete_pos (@to_delete) {
|
||||
splice(@{$self->{hooks}}, $delete_pos, 1);
|
||||
}
|
||||
if ($cgi->param('hook_name')) {
|
||||
my ($name, $prepost, $code) = ($cgi->param('hook_name'), uc $cgi->param('prepost'), $cgi->param('code'));
|
||||
push @{$self->{hooks}}, [$name, $prepost, $code];
|
||||
}
|
||||
}
|
||||
|
||||
sub admin_menu_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{admin_menu}}) {
|
||||
foreach my $menu (@{$self->{admin_menu}}) {
|
||||
my $menu_name = _escape_html($menu->[0]);
|
||||
my $menu_url = _escape_html($menu->[1]);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$menu_name</font></td><td><$FONT>=> $menu_url</font></td></tr>
|
||||
~;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No Admin Menu options installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub admin_menu_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{admin_menu}}) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Admin Menu options</font></td></tr>
|
||||
~;
|
||||
my $i = 0;
|
||||
foreach my $menu (@{$self->{admin_menu}}) {
|
||||
my $menu_name = _escape_html($menu->[0]);
|
||||
my $menu_url = _escape_html($menu->[1]);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$menu_name => $menu_url</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_admin_menu" value="$i"></font></td></tr>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
$output .= qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Menu</font></td></tr>
|
||||
<tr><td><$FONT>Name: <input type="text" name="menu_name" size="10"></font></td>
|
||||
<td><$FONT>URL: <input type="text" name="menu_url" size="20"></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub admin_menu_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the admin menu info based on CGI object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
my @to_delete = $cgi->param('delete_admin_menu');
|
||||
foreach my $delete_pos (@to_delete) {
|
||||
splice(@{$self->{admin_menu}}, $delete_pos, 1);
|
||||
}
|
||||
if ($cgi->param('menu_name')) {
|
||||
my ($name, $url) = ($cgi->param('menu_name'), $cgi->param('menu_url'));
|
||||
push @{$self->{admin_menu}}, [$name, $url];
|
||||
}
|
||||
}
|
||||
|
||||
sub options_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (keys %{$self->{options}}) {
|
||||
foreach my $key (sort keys %{$self->{options}}) {
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>~ . _escape_html($key) . qq~</font></td><td><$FONT>=> ~ . _escape_html($self->{options}->{$key}) . qq~</font></td></tr>
|
||||
~;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No user options installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub options_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (keys %{$self->{options}}) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed User options</font></td></tr>
|
||||
~;
|
||||
my $i = 0;
|
||||
foreach my $key (sort keys %{$self->{options}}) {
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>~ . _escape_html($key) . qq~ => ~ . _escape_html($self->{options}->{$key}) . qq~</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_options" value="~ . _escape_html($key) . qq~"></font></td></tr>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
$output .= qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Option</font></td></tr>
|
||||
<tr><td><$FONT>Name: <input type="text" name="add_key" size="10"></font></td>
|
||||
<td><$FONT>Default: <input type="text" name="add_val" size="20"></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub options_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the options based on the user input.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
my @to_delete = $cgi->param('delete_options');
|
||||
foreach my $key (@to_delete) {
|
||||
delete $self->{options}->{$key};
|
||||
}
|
||||
my ($key, $value) = ($cgi->param('add_key'), $cgi->param('add_val'));
|
||||
if (defined $key and $key) {
|
||||
$self->{options}->{$key} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
sub files_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
my $num_files = 0;
|
||||
if ($self->{tar}) {
|
||||
my $files = $self->{tar}->files;
|
||||
foreach my $file (@$files) {
|
||||
my $name = $file->name;
|
||||
my $size = $file->size;
|
||||
$size = ($size > 1000) ? sprintf("%0.2f kb", $size /1000) : "$size bytes";
|
||||
next if ($name =~ /Author\.pm$/);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$name</font></td><td><$FONT>$size</font></td></tr>
|
||||
~;
|
||||
$num_files++;
|
||||
}
|
||||
}
|
||||
if (! $num_files) {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No extra files installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub files_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my ($self, $edit_url) = @_;
|
||||
my $output;
|
||||
my $num_files = 0;
|
||||
if ($self->{tar}) {
|
||||
my $files = $self->{tar}->files;
|
||||
foreach my $file (@$files) {
|
||||
my $name = _escape_html($file->name);
|
||||
my $size = $file->size;
|
||||
$size = ($size > 1000) ? sprintf("%0.2f kb", $size /1000) : "$size bytes";
|
||||
next if ($name =~ /Author\.pm$/);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$name</font></td><td><$FONT>($size)</font></td></tr>
|
||||
~;
|
||||
$num_files++;
|
||||
}
|
||||
}
|
||||
if ($num_files) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Files</font></td></tr>
|
||||
$output
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub files_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Set the file information.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
$self->{tar} or $self->_load_tar;
|
||||
my $filename = $cgi->param('add_name');
|
||||
my $filehandle = $cgi->param('add_file');
|
||||
my $body = $cgi->param('add_body');
|
||||
if ($filename) {
|
||||
if (ref $filehandle) {
|
||||
my ($buffer, $read);
|
||||
while ($read = read($filehandle, $buffer, 4096)) {
|
||||
$body .= $buffer;
|
||||
}
|
||||
}
|
||||
if (! $body) {
|
||||
$body = ' ';
|
||||
}
|
||||
$body =~ s/\r//g;
|
||||
my $res = $self->{tar}->add_data( name => $filename, body => $body );
|
||||
}
|
||||
my @to_delete = $cgi->param('delete_files');
|
||||
foreach my $file (@to_delete) {
|
||||
$self->{tar}->remove_file($file);
|
||||
}
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Private Methods #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub _load_plugin {
|
||||
# ----------------------------------------------------------------
|
||||
# Examines a plugin tar and fills up self with info.
|
||||
#
|
||||
my $self = shift;
|
||||
my $author = $self->{tar}->get_file('Author.pm') or return $self->error('CANTLOAD', 'WARN', $self->{plugin_name}, "No Author.pm file found in tar!");
|
||||
|
||||
# Eval the install file.
|
||||
my $file = $author->body_as_string;
|
||||
{
|
||||
local ($@, $SIG{__DIE__}, $^W);
|
||||
eval "$file";
|
||||
if ($@) {
|
||||
return $self->error('CANTLOAD', 'WARN', $file, "Author.pm does not compile: $@");
|
||||
}
|
||||
}
|
||||
|
||||
# Load the information.
|
||||
no strict 'refs';
|
||||
my $var = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::AUTHOR";
|
||||
my $author_info = ${$var};
|
||||
if (ref $author_info eq 'HASH') {
|
||||
foreach my $key (keys %$author_info) {
|
||||
$self->{$key} = $author_info->{$key};
|
||||
}
|
||||
}
|
||||
use strict 'refs';
|
||||
$self->_load_install;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _load_tar {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads the tar file into memory.
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = $PLUGIN_DIR . "/Author/" . $self->{plugin_name} . ".tar";
|
||||
if (-e $file) {
|
||||
$self->{tar} = GT::Tar->open($file) or return $self->error('CANTLOAD', 'WARN', $file, $GT::Tar::error);
|
||||
}
|
||||
else {
|
||||
$self->{tar} = new GT::Tar($file) or return $self->error('CANTLOAD', 'WARN', $file, $GT::Tar::error);
|
||||
}
|
||||
}
|
||||
|
||||
sub _create_author {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the author.pm file used by the web tool to auto create the plugin.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = '';
|
||||
my $time = localtime();
|
||||
my $version = $self->{version} || 0;
|
||||
my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{meta});
|
||||
|
||||
$output = <<END_OF_PLUGIN;
|
||||
# ==================================================================
|
||||
# Auto Generated Plugin Configuration - Needed for Web Based Creator.
|
||||
#
|
||||
# $self->{prefix}Plugins::$self->{plugin_name}
|
||||
# Author : $self->{meta}->{author}
|
||||
# Version : $self->{version}
|
||||
# Updated : $time
|
||||
#
|
||||
# ==================================================================
|
||||
#
|
||||
|
||||
package $self->{prefix}Plugins::$self->{plugin_name};
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw/\$AUTHOR/;
|
||||
|
||||
END_OF_PLUGIN
|
||||
my $author = {};
|
||||
foreach (keys %$ATTRIBS) {
|
||||
next if ($_ eq 'tar');
|
||||
$author->{$_} = $self->{$_};
|
||||
}
|
||||
$output .= GT::Dumper->dump(var => '$AUTHOR', data => $author);
|
||||
$output .= "\n\n1;\n";
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub _escape_html {
|
||||
# -------------------------------------------------------------------
|
||||
# Escape html.
|
||||
#
|
||||
my $val = shift;
|
||||
defined $val or return '';
|
||||
$val =~ s/&/&/g;
|
||||
$val =~ s/</</g;
|
||||
$val =~ s/>/>/g;
|
||||
$val =~ s/"/"/g;
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _create_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub install {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated install function. Must return status message to user.
|
||||
#
|
||||
my \$mgr = new GT::Plugins::Manager;~;
|
||||
foreach my $hook (@{$self->{hooks}}) {
|
||||
$code .= qq~
|
||||
\$mgr->install_hooks('$self->{plugin_name}', [['$hook->[0]', '$hook->[1]', '$hook->[2]']]);~;
|
||||
}
|
||||
foreach my $menu (@{$self->{admin_menu}}) {
|
||||
$code .= qq~
|
||||
\$mgr->install_menu('$self->{plugin_name}', [['$menu->[0]', '$menu->[1]']]);~;
|
||||
}
|
||||
if (keys %{$self->{options}}) {
|
||||
my $options = GT::Dumper->dump(var => '$opts', data => $self->{options});
|
||||
$options =~ s/\n/\n\t/g;
|
||||
$code .= qq~
|
||||
my $options
|
||||
\$mgr->install_options('$self->{plugin_name}', \$opts);~;
|
||||
}
|
||||
$code .= qq~
|
||||
return "Plugin $self->{plugin_name} installed successfully.";
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _create_uninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the pre-install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub uninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated uninstall function. Must return status message to user.
|
||||
#
|
||||
my \$message = "Plugin $self->{plugin_name} has been uninstalled.";
|
||||
return \$message;
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _create_preinstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the pre-install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub pre_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated pre_install function. Must return status message to user.
|
||||
#
|
||||
my \$message = "INSERT INSTALL MESSAGE HERE";
|
||||
return \$message;
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _create_preuninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the pre-install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub pre_uninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated pre_uninstall function. Must return status message to user.
|
||||
#
|
||||
my \$message = "INSERT UNINSTALL MESSAGE HERE";
|
||||
return \$message;
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _load_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Load the install functions from the Install.pm file.
|
||||
#
|
||||
my $self = shift;
|
||||
return unless ($self->{tar});
|
||||
my $install = $self->{tar}->get_file('Install.pm') or return;
|
||||
my $install_code = $install->body_as_string;
|
||||
$self->{pre_install} = $self->_parse_sub('pre_install', \$install_code);
|
||||
$self->{install} = $self->_parse_sub('install', \$install_code);
|
||||
$self->{pre_uninstall} = $self->_parse_sub('pre_uninstall', \$install_code);
|
||||
$self->{uninstall} = $self->_parse_sub('uninstall', \$install_code);
|
||||
}
|
||||
|
||||
sub _replace_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Load the install functions from the Install.pm file.
|
||||
#
|
||||
my ($self, $install) = @_;
|
||||
return unless ($install);
|
||||
|
||||
my $install_code = $install->body_as_string;
|
||||
$install_code =~ s/\r//g;
|
||||
$self->_replace_sub('pre_install', \$install_code, $self->{pre_install});
|
||||
$self->_replace_sub('install', \$install_code, $self->{install});
|
||||
$self->_replace_sub('pre_uninstall', \$install_code, $self->{pre_uninstall});
|
||||
$self->_replace_sub('uninstall', \$install_code, $self->{uninstall});
|
||||
$install_code =~ s/(\$VERSION\s*=\s*)(['"]?)[\d\.]+(['"]?)/$1$2$self->{version}$3/;
|
||||
$install_code =~ s/(Version\s*:\s*)[\d\.]+/$1$self->{version}/;
|
||||
$install_code =~ s/\$META\s*=\s*[^\}]+\}[\s\n]*;[\s\n]*/GT::Dumper->dump(var => '$META', data => $self->{meta}) . "\n"/esm;
|
||||
$install->body($install_code);
|
||||
}
|
||||
|
||||
sub _parse_sub {
|
||||
# -------------------------------------------------------------------
|
||||
# Parse out a subroutine in some code, and return it.
|
||||
#
|
||||
my ($self, $sub, $code) = @_;
|
||||
return '' unless ($sub and $$code);
|
||||
|
||||
$$code =~ m/(\s*)(sub\s+$sub[^\{]*\{.*?\n\1\})/sm;
|
||||
my $code_block = $2 || '';
|
||||
$code_block =~ s/\r//g;
|
||||
return $code_block;
|
||||
}
|
||||
|
||||
sub _replace_sub {
|
||||
# -------------------------------------------------------------------
|
||||
# Parse out a subroutine in some code, and replace it.
|
||||
#
|
||||
my ($self, $sub, $code, $new) = @_;
|
||||
return unless ($new);
|
||||
$new =~ s/\r//g;
|
||||
$new =~ s/^[\s\n]+|[\s\n]$//g;
|
||||
$$code =~ s/\r//g;
|
||||
if (! ($$code =~ s/([\s\n]*)(sub\s+$sub[^\{]*\{.*?\n\1\})/\n$new/sm)) {
|
||||
$$code =~ s/1;[\s\n\r]+$//gsm;
|
||||
$$code .= "\n" . $new . "\n1;\n\n";
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
258
site/glist/lib/GT/Plugins/Installer.pm
Normal file
258
site/glist/lib/GT/Plugins/Installer.pm
Normal file
@@ -0,0 +1,258 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Installer.pm,v 1.13 2004/08/23 19:54:27 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A web based admin to install/uninstall plugins.
|
||||
#
|
||||
|
||||
package GT::Plugins::Installer;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
|
||||
use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $DEBUG/;
|
||||
use GT::Base;
|
||||
use GT::Plugins;
|
||||
use GT::Tar;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::Plugins';
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
plugin_dir => undef,
|
||||
prog_ver => undef,
|
||||
prog_user_cgi => undef,
|
||||
prog_admin_cgi => undef,
|
||||
prog_images => undef,
|
||||
prog_libs => undef
|
||||
};
|
||||
@ISA = qw/GT::Base/;
|
||||
|
||||
sub init {
|
||||
# ----------------------------------------------------------------
|
||||
# Load the plugin config file on init() called from GT::Base.
|
||||
#
|
||||
my $self = shift;
|
||||
my $param = $self->common_param(@_);
|
||||
$self->set($param);
|
||||
if (! $self->{plugin_dir} or ! -d $self->{plugin_dir}) {
|
||||
return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to manager.");
|
||||
}
|
||||
$self->{cfg} = GT::Plugins->load_cfg($self->{plugin_dir});
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------------------------- #
|
||||
# Utilities used in Install/Uninstall by Plugins #
|
||||
# ----------------------------------------------------------------------------------------- #
|
||||
|
||||
sub install_hooks {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of plugin hooks.
|
||||
#
|
||||
my ($self, $plugin, $hooks) = @_;
|
||||
if (ref $hooks ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_menu('PLUGINNAME', [['hookname', 'PRE/POST', 'action'], ...])");
|
||||
}
|
||||
if (ref $hooks->[0] ne 'ARRAY') {
|
||||
$hooks = [ $hooks ];
|
||||
}
|
||||
foreach my $hook (@$hooks) {
|
||||
my ($hookname, $prepost, $action) = @$hook;
|
||||
if (! ((uc $prepost eq 'PRE') or (uc $prepost eq 'POST'))) {
|
||||
die "Invalid hook argument. Must be pre/post, not: $prepost";
|
||||
}
|
||||
push @{$self->{cfg}->{$plugin}->{hooks}}, [lc $hookname, uc $prepost, $action, 1];
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of menu options for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $menus) = @_;
|
||||
if (ref $menus ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_menu('PLUGINNAME', [['title', 'url'], ...])");
|
||||
}
|
||||
if (ref $menus->[0] ne 'ARRAY') {
|
||||
$menus = [ $menus ];
|
||||
}
|
||||
foreach my $menu (@$menus) {
|
||||
push @{$self->{cfg}->{$plugin}->{menu}}, $menu;
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_options {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of options for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $opts, ) = @_;
|
||||
if (ref $opts ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_options('PLUGINNAME', [['name', 'val', 'instructions'] ...])");
|
||||
}
|
||||
if (ref $opts->[0] ne 'ARRAY') {
|
||||
$opts = [ $opts ];
|
||||
}
|
||||
foreach my $opt (@$opts) {
|
||||
exists $self->{cfg}->{$plugin}->{user} or ($self->{cfg}->{$plugin}->{user} = []);
|
||||
push @{$self->{cfg}->{$plugin}->{user}}, $opt;
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_registry {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a registry item for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $opts) = @_;
|
||||
if (ref $opts ne 'HASH') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_options('PLUGINNAME', { key => value, ... })");
|
||||
}
|
||||
my $registry = ($self->{cfg}->{$plugin}->{registry} ||= {});
|
||||
foreach my $key (keys %$registry) {
|
||||
$registry->{$key} = $registry->{$key};
|
||||
}
|
||||
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub uninstall_hooks {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove plugins, just a no-op as the config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $hooks) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove menus, no-op as config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $menus) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_options {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove options, just a no-op as config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $opts) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_registry {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove registry, just a no-op as config gets deleted.
|
||||
#
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Plugins::Installer
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$mgr->install_hooks('PluginName', ['hook_name', 'PRE|POST', 'code']);
|
||||
$mgr->install_menu('PluginName', ['menu_name', 'menu_url', 'enabled']);
|
||||
$mgr->install_options('PluginName', ['option_key', 'option_val', 'instructions']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The installer is an object that is passed into plugins during installation.
|
||||
It provides methods to add hooks, menu options, admin options or copy files
|
||||
into the users application.
|
||||
|
||||
=head2 install_hooks
|
||||
|
||||
C<install_hooks> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item hook_name
|
||||
|
||||
The hook you want to override.
|
||||
|
||||
=item PRE/POST
|
||||
|
||||
Either the string PRE or POST depending on whether the hook should be run
|
||||
before the main code, or after.
|
||||
|
||||
=item code
|
||||
|
||||
The name of the code to run. It should be Plugins::PACKAGE::YourPluginName::function.
|
||||
Where PACKAGE is the name of the Gossamer Product the plugin is for. For example
|
||||
Plugins::GMail::Wap::header
|
||||
|
||||
=back
|
||||
|
||||
C<install_hooks> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head2 install_menu
|
||||
|
||||
C<install_menu> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item menu_name
|
||||
|
||||
The name that will show up in the admin menu.
|
||||
|
||||
=item menu_url
|
||||
|
||||
The URL for the menu option.
|
||||
|
||||
=item enabled
|
||||
|
||||
Either true or false depending on whether the menu option should be shown.
|
||||
|
||||
=back
|
||||
|
||||
C<install_menu> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head2 install_options
|
||||
|
||||
C<install_options> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item option_key
|
||||
|
||||
This is the key, and is used when accessing the options hash.
|
||||
|
||||
=item option_value
|
||||
|
||||
This is the default value.
|
||||
|
||||
=item instructions
|
||||
|
||||
A string instruction users on what the plugin does.
|
||||
|
||||
=back
|
||||
|
||||
C<install_options> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Installer.pm,v 1.13 2004/08/23 19:54:27 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1170
site/glist/lib/GT/Plugins/Manager.pm
Normal file
1170
site/glist/lib/GT/Plugins/Manager.pm
Normal file
File diff suppressed because it is too large
Load Diff
1098
site/glist/lib/GT/Plugins/Wizard.pm
Normal file
1098
site/glist/lib/GT/Plugins/Wizard.pm
Normal file
File diff suppressed because it is too large
Load Diff
155
site/glist/lib/GT/RDF.pm
Normal file
155
site/glist/lib/GT/RDF.pm
Normal file
@@ -0,0 +1,155 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::RDF
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: RDF.pm,v 1.2 2001/04/11 02:37:12 alex Exp $
|
||||
#
|
||||
# Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: An RDF parser.
|
||||
#
|
||||
|
||||
package GT::RDF;
|
||||
|
||||
use GT::Base;
|
||||
use strict;
|
||||
use vars qw/$DEBUG @ISA $TAG $ERRORS/;
|
||||
|
||||
@ISA = qw(GT::Base);
|
||||
$DEBUG = 0;
|
||||
$TAG = 'Topic|ExternalPage';
|
||||
$ERRORS = {};
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (@_ == 1) {
|
||||
$self->io (shift()) or return;
|
||||
}
|
||||
else {
|
||||
if (ref $_[0] eq 'HASH') { $opt = shift }
|
||||
elsif (defined ($_[0]) and not @_ % 2) { $opt = {@_} }
|
||||
exists ($opt->{io}) or return $self->error ("BADARGS", "FATAL", 'CLASS->new (%opt) %opt must contain the key io and it must be either a file handle or a path to a file.');
|
||||
$self->io ($opt->{io});
|
||||
}
|
||||
$self->{io} || return $self->error ("BADARGS", "FATAL", 'CLASS->new (\\*FH) -or- CLASS->new (%opts). You must define in input. Either a file or a file handle');
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub io {
|
||||
my ($self, $io) = @_;
|
||||
if (ref $io eq 'GLOB') {
|
||||
$self->{io} = $io;
|
||||
}
|
||||
elsif (-e $io) {
|
||||
my $fh = \do { local *FH; *FH };
|
||||
open $fh, $io or return $self->error ("OPENREAD", "FATAL", $!);
|
||||
$self->{io} = $fh;
|
||||
}
|
||||
else {
|
||||
return $self->error ("BADARGS", "FATAL", '$obj->io (\*FH) -or- $obj->io ("/path/to/file")');
|
||||
}
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my $self = shift;
|
||||
|
||||
my $io = $self->{io};
|
||||
|
||||
while (1) {
|
||||
$self->{name} = '';
|
||||
$self->{attribs} = {};
|
||||
$self->{tags} = [];
|
||||
my $parse;
|
||||
if ($self->{buffer} =~ s,(<($TAG).*?</\2[^>]*?>),$parse = $1; '',oes) {
|
||||
my @tokens = grep !/^\s*$/, split /(<[^>]+?>)/, $parse;
|
||||
my $start = shift (@tokens);
|
||||
|
||||
# Discard closing tag
|
||||
pop (@tokens);
|
||||
|
||||
# Get the start tag and its attributes
|
||||
$start =~ /^<($TAG)\s*(.*[^\/])>$/os;
|
||||
$self->{name} = $1;
|
||||
my $attr = $2;
|
||||
if ($attr) {
|
||||
my @tmp = split (/"/, $attr);
|
||||
my $ret = {};
|
||||
my $last = '';
|
||||
for (0 .. $#tmp) {
|
||||
if (!$_ % 2) {
|
||||
$tmp[$_] =~ s/^\s+|=$//g;
|
||||
$last = $tmp[$_];
|
||||
$ret->{$last} = '';
|
||||
}
|
||||
else {
|
||||
$ret->{$last} = $tmp[$_];
|
||||
}
|
||||
}
|
||||
$self->{attribs} = $ret;
|
||||
}
|
||||
|
||||
# Parse the remaining tags.
|
||||
my $last_entry;
|
||||
for (@tokens) {
|
||||
if (/^<([^\/\s]+)\s*(.*?[^\/])?>$/s) {
|
||||
my $tag = $1;
|
||||
my $attr = $2;
|
||||
my $ret = {};
|
||||
if ($attr) {
|
||||
my @tmp = split (/"/, $attr);
|
||||
my $last = '';
|
||||
for (0 .. $#tmp) {
|
||||
if (!$_ % 2) {
|
||||
$tmp[$_] =~ s/^\s+|=$//g;
|
||||
$last = $tmp[$_];
|
||||
$ret->{$last} = '';
|
||||
}
|
||||
else {
|
||||
$ret->{$last} = $tmp[$_];
|
||||
}
|
||||
}
|
||||
}
|
||||
$last_entry = { name => $tag, attribs => $ret };
|
||||
push (@{$self->{tags}}, $last_entry);
|
||||
}
|
||||
elsif (/^<([^\s\/]+)\s*(.*?)\/>$/s) {
|
||||
my $tag = $1;
|
||||
my $attr = $2;
|
||||
my $ret = {};
|
||||
if ($attr) {
|
||||
my @tmp = split (/"/, $attr);
|
||||
my $last = '';
|
||||
for (0 .. $#tmp) {
|
||||
if (!$_ % 2) {
|
||||
$tmp[$_] =~ s/^\s+|=$//g;
|
||||
$last = $tmp[$_];
|
||||
$ret->{$last} = '';
|
||||
}
|
||||
else {
|
||||
$ret->{$last} = $tmp[$_];
|
||||
}
|
||||
}
|
||||
}
|
||||
my $entry = { name => $tag, attribs => $ret };
|
||||
push (@{$self->{tags}}, $entry);
|
||||
}
|
||||
elsif (/^([^<]+)$/ and $last_entry) {
|
||||
$last_entry->{data} = $1;
|
||||
}
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
# No match
|
||||
else {
|
||||
my $tmp;
|
||||
read ($io, $tmp, 3072) or last;
|
||||
$self->{buffer} .= $tmp;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
715
site/glist/lib/GT/SQL.pm
Normal file
715
site/glist/lib/GT/SQL.pm
Normal file
@@ -0,0 +1,715 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL
|
||||
# CVS Info :
|
||||
# $Id: SQL.pm,v 1.111 2005/04/14 20:22:37 alex Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface to a RDBMS.
|
||||
#
|
||||
|
||||
package GT::SQL;
|
||||
# ==================================================================
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
use GT::Config;
|
||||
use GT::SQL::Base;
|
||||
use GT::SQL::Table;
|
||||
use GT::SQL::Driver;
|
||||
use strict;
|
||||
use vars qw(@ISA $DEBUG $ERRORS $VERSION %OBJ_CACHE $error $errcode);
|
||||
|
||||
@ISA = qw(GT::SQL::Base);
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.111 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERRORS = {
|
||||
# Common Errors
|
||||
UNIQUE => "The column '%s' must be unique, and already has an entry '%s'",
|
||||
NOTABLE => 'No table defined -- call $db->table($table) before accessing',
|
||||
CANTOPEN => "Cannot open file '%s': %s",
|
||||
CANTOPENDIR => "Cannot read directory '%s': %s",
|
||||
FILENOEXISTS => "File '%s' does not exist or the permissions are set incorrectly",
|
||||
# GT::SQL Errors
|
||||
NODRIVER => "Database driver %s is not installed. Available drivers: %s",
|
||||
CANTLOAD => "Unable to load driver '%s': %s",
|
||||
BADPREFIX => "Invalid prefix: '%s'",
|
||||
NODATABASE => 'No database def file -- create def file with ->set_connect before calling $obj->%s',
|
||||
CANTCONNECT => "Could not connect to database: %s",
|
||||
CANTPREPARE => "Failed to prepare query: '%s': %s",
|
||||
CANTEXECUTE => "Failed to execute query: '%s': %s",
|
||||
BADSUBCLASS => "Unable to load subclass: '%s': %s",
|
||||
NEEDDEBUG => "You must turn on debug in order to access query logs",
|
||||
NOORACLEHOME => "The environment variable ORACLE_HOME is not defined. It must be defined for the script to connect properly",
|
||||
NONLSDATE => "Unable to set NLS_DATE_FORMAT: %s",
|
||||
# Table Errors
|
||||
BADNAME => "Invalid table name '%s'",
|
||||
NOTNULL => "Column %s cannot be left blank",
|
||||
NORECMOD => "The record you are attempting to modify no longer exists in the current table",
|
||||
NOVALUES => "You did not pass any valid column names to %s",
|
||||
BADMULTVALUES => "One or more of the value groups passed to %s contained an incorrect number of values",
|
||||
NOPKTOMOD => "Cannot modify record, no primary key specified",
|
||||
DEPENDENCY => "Table %s has dependencies. Aborting",
|
||||
ILLEGALVAL => "%s cannot contain the value '%s'",
|
||||
ALREADYCHANGED => "The record you are attempting to modify has changed since you last accessed it",
|
||||
REGEXFAIL => "The regular expressions %s for this column is not properly formed",
|
||||
FKNOTABLE => "A foreign key is referencing a non existant table: %s. GT::SQL load error: %s",
|
||||
FKNOEXISTS => "You attempted to remove non-existent foreign key '%s' from table '%s'",
|
||||
CIRCULAR => "Circular reference detected in the foreign key schema. Already seen column: %s",
|
||||
CIRCULARLIMIT => "Loop detected in circular reference check, hit maximum recursion depth of 100",
|
||||
# Relation Errors
|
||||
BADCOLS => "Bad columns / column clash: columns named '%s' have been found in current relation, please qualify your expression",
|
||||
# Creator Errors
|
||||
BADTYPE => "%s is not a supported type",
|
||||
AINOTPK => "Column %s defined as auto_increment but is not an INT",
|
||||
TBLEXISTS => "Could not create table '%s': It already exists",
|
||||
NOTABLEDEFS => "You must define your table before creating it",
|
||||
NOPOS => "No position column was found in definition for column: %s",
|
||||
# Editor Errors
|
||||
NOCOL => "There is no column %s in this table",
|
||||
REFCOL => "You cannot alter column %s, as table %s still has references to it. Remove those references first",
|
||||
NOPK => "There is no primary key for this table",
|
||||
COLREF => "You cannot alter column %s, as it is a foreign key. Remove the foreign key first",
|
||||
NOINDEX => "You are trying to modify an index that does not exist",
|
||||
NOUNIQUE => "You are trying to drop a unique column '%s', but it is not unique",
|
||||
INDXQTEXT => "Cannot create index on '%s' as it is a text/blob field",
|
||||
COLEXISTS => "Unable to add column '%s' - already exists",
|
||||
NOTUNIQUE => "Cannot create unique index on '%s', data is not unique",
|
||||
INDXEXISTS => "Unable to add index '%s' - already exists",
|
||||
PKTEXT => "Column %s specified as a primary key but is a text or a blob type",
|
||||
UNIQTEXT => "Column %s specified as a unique but is a text or blob column type",
|
||||
TABLEREFD => "%s cannot be dropped as table still has references to it",
|
||||
NOFILESAVEIN => "Column %s must have file_save_in set if is to be File type",
|
||||
NODIRPRIV => "Privileges on directory %s do not allow write or directory does not exist",
|
||||
SAMEDRIVER => "Search Driver '%s' is unchanged",
|
||||
NOTNULLDEFAULT => "Column %s was specified as not null, but has no default value",
|
||||
# Admin Error
|
||||
NOACTION => "The CGI object passed in did not contain a valid action. %s",
|
||||
# Tree errors
|
||||
NOTREE => "No tree object exists for table '%s'. Create a tree first with \$editor->add_tree",
|
||||
NOTREEOBJ => "You attempted to call '%s' without a valid tree object. Call \$table->tree() first",
|
||||
TREEEXISTS => "A tree already exists for table '%s'",
|
||||
TREENOCANDO => "You attempted to call '%s' on table '%s', but that table has a tree attached and does not support the command",
|
||||
TREENOIDS => "You did not pass any ID's to %s",
|
||||
TREEBADPK => "You tried to create a tree on table '%s', but that table doesn't have a primary key, or has multiple primary keys",
|
||||
TREEBADJOIN => "Joining more than 2 tables with a tree is not supported. You attempted to join: %s",
|
||||
TREEFATHER => "Unable to update a tree record to a descendant of itself",
|
||||
# Driver errors
|
||||
DRIVERPROTOCOL => "Driver implements wrong protocol: protocol v%d required, driver is v%d",
|
||||
};
|
||||
|
||||
use constant DEF_HEADER => <<'HEADER';
|
||||
# Database access & configuration file
|
||||
# Last updated: [localtime]
|
||||
# Created by GT::SQL $Revision: 1.111 $
|
||||
HEADER
|
||||
|
||||
sub new {
|
||||
# -------------------------------------------------------------------
|
||||
# GT::SQL constructor. Takes:
|
||||
# my $db = new GT::SQL '/path/to/def';
|
||||
# my $db = new GT::SQL { def_path => '/defpath', debug => 1 };
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless { _err_pkg => __PACKAGE__, _debug => $DEBUG }, $class;
|
||||
|
||||
# Get our arguments into a hash ref
|
||||
my $opts = {};
|
||||
if (@_ == 0) { $opts = {}; }
|
||||
elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift; }
|
||||
elsif (@_ > 1 and !(@_ % 2)) { $opts = {@_}; }
|
||||
else {
|
||||
$opts->{def_path} = shift;
|
||||
}
|
||||
|
||||
# Set debugging level, caching options and whether to allow subclassing.
|
||||
$self->{_debug} = exists $opts->{debug} ? $opts->{debug} : $DEBUG;
|
||||
$self->{cache} = exists $opts->{cache} ? $opts->{cache} : 1;
|
||||
$self->{subclass} = exists $opts->{subclass} ? $opts->{subclass} : 1;
|
||||
|
||||
# Def path must exist and be a directory
|
||||
exists $opts->{def_path} or return $self->fatal(BADARGS => "$class->new(HASH_REF). def_path must be defined and a directory path in the hash");
|
||||
-d $opts->{def_path} or return $self->fatal(BADARGS => "The defs directory '$opts->{def_path}' does not exist, or is not a directory");
|
||||
|
||||
# Load the database def file if it exists
|
||||
|
||||
# Some old programs would sometimes erroneously leave an invalid blank
|
||||
# database.def file in the def_path; if such a file exists, make GT::Config
|
||||
# ignore it.
|
||||
my $empty = (-f "$opts->{def_path}/database.def" and !-s _);
|
||||
|
||||
$self->{connect} = GT::Config->load(
|
||||
"$opts->{def_path}/database.def" => {
|
||||
create_ok => 1,
|
||||
chmod => 0666,
|
||||
debug => $self->{_debug},
|
||||
header => DEF_HEADER,
|
||||
($empty ? (empty => 1) : ()),
|
||||
}
|
||||
);
|
||||
|
||||
$self->{connect}->{PREFIX} = '' unless defined $self->{connect}->{PREFIX};
|
||||
# Heavily deprecated. Not guaranteed to always be correct:
|
||||
$GT::SQL::PREFIX = $self->{connect}->{PREFIX};
|
||||
$self->{connect}->{def_path} = $opts->{def_path};
|
||||
$self->{connect}->{obj_cache} = $self->{cache};
|
||||
|
||||
$self->debug("OBJECT CREATED") if $self->{_debug} and $self->{_debug} > 2;
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{set_connect} = __LINE__ . <<'END_OF_SUB';
|
||||
sub set_connect {
|
||||
# -------------------------------------------------------------------
|
||||
# Sets the connection info, only needed to setup the database.def file.
|
||||
# $db->set_connect({
|
||||
# driver => 'mysql',
|
||||
# host => 'localhost',
|
||||
# port => 2323,
|
||||
# database => 'mydatabase',
|
||||
# login => 'user',
|
||||
# password => 'foo',
|
||||
# }) or die "Can't connect: $GT::SQL::error";
|
||||
#
|
||||
my $self = shift;
|
||||
my $connect = $self->{connect};
|
||||
my %old_connect = %$connect;
|
||||
# Parse our arguments.
|
||||
if (!@_) { return $self->fatal(BADARGS => '$obj->set_connect(HASH_REF)') }
|
||||
elsif (@_ == 1 and ref $_[0] eq 'HASH') { %$connect = %{+shift} }
|
||||
elsif (@_ % 2 == 0) { %$connect = @_ }
|
||||
else { return $self->fatal(BADARGS => '$obj->set_connect(HASH_REF)') }
|
||||
|
||||
if (keys %old_connect) {
|
||||
for (keys %old_connect) {
|
||||
$connect->{$_} = $old_connect{$_} unless exists $connect->{$_};
|
||||
}
|
||||
}
|
||||
$connect->{PREFIX} = '' unless defined $connect->{PREFIX};
|
||||
|
||||
# Fix the connect string for test connecting
|
||||
$connect->{driver} ||= 'mysql';
|
||||
|
||||
# Make sure DBI has been loaded
|
||||
eval { require DBI };
|
||||
$@ and return $self->warn(CANTCONNECT => "DBI module not installed. You must install the perl database module DBI from: http://www.perl.com/CPAN/modules/by-module/DBI");
|
||||
|
||||
# Make sure the requested driver exists
|
||||
my @drivers = GT::SQL::Driver->available_drivers;
|
||||
unless (grep $_ eq uc $connect->{driver}, @drivers, 'ODBC') {
|
||||
return $self->warn(NODRIVER => $connect->{driver}, join ", ", @drivers);
|
||||
}
|
||||
|
||||
my $raiseerror = delete $connect->{RaiseError};
|
||||
my $printerror = delete $connect->{PrintError};
|
||||
$connect->{RaiseError} = 0;
|
||||
$connect->{PrintError} = 0;
|
||||
|
||||
# Get our driver.
|
||||
my $table = GT::SQL::Table->new(connect => $connect, debug => $self->{_debug});
|
||||
$table->connect or return;
|
||||
|
||||
# Put things back the way they were.
|
||||
$connect->{RaiseError} = defined $raiseerror ? $raiseerror : 1;
|
||||
$connect->{PrintError} = defined $printerror ? $printerror : 0;
|
||||
|
||||
$self->{connect} = $connect;
|
||||
|
||||
# Use this connect string from now on.
|
||||
$self->write_db_config;
|
||||
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{write_db_config} = __LINE__ . <<'END_OF_SUB';
|
||||
sub write_db_config {
|
||||
# -------------------------------------------------------------------
|
||||
# Saves the database.def file. Takes no arguments.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{connect}->save;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# ============================================================================ #
|
||||
# DATABASE INFO ACCESSORS #
|
||||
# ============================================================================ #
|
||||
$COMPILE{driver} = __LINE__ . <<'END_OF_SUB';
|
||||
sub driver {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the name of the driver being used.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{driver};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{host} = __LINE__ . <<'END_OF_SUB';
|
||||
sub host {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the name of the host being used.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{host};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{port} = __LINE__ . <<'END_OF_SUB';
|
||||
sub port {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the port currently being used, undef if default.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{port};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{database} = __LINE__ . <<'END_OF_SUB';
|
||||
sub database {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the name of the database being used.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{database};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{login} = __LINE__ . <<'END_OF_SUB';
|
||||
sub login {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the login username for the current connection.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{login};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{password} = __LINE__ . <<'END_OF_SUB';
|
||||
sub password {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the login password for the current connection.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{password};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# ============================================================================ #
|
||||
# HTML ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
$COMPILE{html} = __LINE__ . <<'END_OF_SUB';
|
||||
sub html {
|
||||
# -------------------------------------------------------------------
|
||||
# Return an html object. Takes an array ref of table names, or a, and a cgi
|
||||
# object.
|
||||
# my $html = $db->html(['Links'], $in);
|
||||
# or
|
||||
# my $html = $db->html($table_obj, $in);
|
||||
#
|
||||
my ($self, $tables, $cgi) = @_;
|
||||
ref $tables or return $self->fatal(BADARGS => 'Error: no table array ref passed to html');
|
||||
ref $cgi or return $self->fatal(BADARGS => 'Error: no cgi object/hash ref passed to html');
|
||||
|
||||
# If already passed a table object, use it, otherwise create a new one
|
||||
my ($table);
|
||||
if (ref $tables eq 'ARRAY') {
|
||||
$table = $self->table(@$tables);
|
||||
}
|
||||
elsif (UNIVERSAL::isa($tables, 'GT::SQL::Table') or UNIVERSAL::isa($tables, 'GT::SQL::Relation')) {
|
||||
$table = $tables;
|
||||
}
|
||||
else {
|
||||
return $self->fatal(BADARGS => "Error: '$tables' must be either an array ref or a table object");
|
||||
}
|
||||
|
||||
my $meth = @{[$table->name]} > 1 ? "_html_relation" : "_html_table";
|
||||
$self->$meth($table, $cgi);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_html_relation} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _html_relation {
|
||||
my ($self, $rel, $cgi) = @_;
|
||||
|
||||
my $class;
|
||||
my $key = join "\0", map { s/^$self->{connect}->{PREFIX}//; $_ } sort keys %{$rel->{tables}};
|
||||
foreach my $table (values %{$rel->{tables}}) {
|
||||
my $subclass = $table->subclass;
|
||||
if ($self->{subclass} and exists $subclass->{html}->{$self->{connect}->{PREFIX} . $key}) {
|
||||
$class = $subclass->{html}->{$self->{connect}->{PREFIX} . $key};
|
||||
$self->_load_module($class) or return;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if (!$class) {
|
||||
require GT::SQL::Display::HTML::Relation;
|
||||
$class = 'GT::SQL::Display::HTML::Relation';
|
||||
}
|
||||
return $class->new(
|
||||
db => $rel,
|
||||
input => $cgi
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_html_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _html_table {
|
||||
my ($self, $table, $cgi) = @_;
|
||||
my $class;
|
||||
if ($self->{subclass} and $table->{schema}->{subclass}->{html}->{$table->name}) {
|
||||
$class = $table->{schema}->{subclass}->{html}->{$table->name};
|
||||
$self->_load_module($class) or return;
|
||||
}
|
||||
if (!$class) {
|
||||
require GT::SQL::Display::HTML::Table;
|
||||
$class = 'GT::SQL::Display::HTML::Table';
|
||||
}
|
||||
return $class->new(
|
||||
db => $table,
|
||||
input => $cgi
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub query_stack {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns raw query stack (as array/array ref).
|
||||
#
|
||||
return wantarray ? @GT::SQL::Driver::debug::QUERY_STACK : \@GT::SQL::Driver::debug::QUERY_STACK;
|
||||
}
|
||||
|
||||
sub query_stack_disp {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns formatted query stack (handled in Driver.pm).
|
||||
#
|
||||
my ($out, $i) = ('', 0);
|
||||
foreach (reverse 0 .. $#GT::SQL::Driver::debug::QUERY_STACK) {
|
||||
my $query = $GT::SQL::Driver::debug::QUERY_STACK[$_];
|
||||
my $stack = $GT::SQL::Driver::debug::STACK_TRACE[$_] || '';
|
||||
$i++;
|
||||
chomp $query;
|
||||
$query =~ s/^[\s]*(.*?)[\s]*$/$1/mg;
|
||||
$query =~ s/\n/\n /mg;
|
||||
$out .= "$i: $query\n$stack";
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
|
||||
$COMPILE{prefix} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prefix {
|
||||
# -------------------------------------------------------------------
|
||||
# Set/Get the database prefix to be attached to all tables. Calling this as a
|
||||
# class accessor method is extremely deprecated (it returns $GT::SQL::PREFIX,
|
||||
# which is itself extremely deprecated); calling this to *set* a prefix is not
|
||||
# permitted.
|
||||
#
|
||||
|
||||
my $self = shift;
|
||||
|
||||
if (@_) {
|
||||
ref $self or $self->fatal(BADARGS => 'Usage: $obj->prefix(...) not CLASS->prefix(...)');
|
||||
my $prefix = shift;
|
||||
if ($prefix =~ /\W/) {
|
||||
return $self->fatal(BADPREFIX => $prefix);
|
||||
}
|
||||
$self->{connect}->{PREFIX} = $prefix;
|
||||
}
|
||||
else {
|
||||
return ref $self ? $self->{connect}->{PREFIX} : $GT::SQL::PREFIX;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{reset_env} = __LINE__ . <<'END_OF_SUB';
|
||||
sub reset_env {
|
||||
# -------------------------------------------------------------------
|
||||
# Reset globals.
|
||||
#
|
||||
GT::SQL::Driver->reset_env(); # Shut down database connections.
|
||||
%OBJ_CACHE = ();
|
||||
$error = '';
|
||||
$errcode = '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::SQL - A database independent perl interface
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::SQL;
|
||||
|
||||
my $db = GT::SQL->new('/path/to/def');
|
||||
my $table = $db->table('Links');
|
||||
my $editor = $db->editor('Links');
|
||||
my $creator = $db->creator('NewTable');
|
||||
my $html = $db->html('Links', new CGI);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::SQL is a perl database abstraction layer to relational databases, providing
|
||||
a native Perl interface rather than a query-based interface.
|
||||
|
||||
A GT::SQL object provides the interface to the entire database by providing
|
||||
objects that are able to perform the work needed.
|
||||
|
||||
=head2 Creating a new GT::SQL object
|
||||
|
||||
There are two ways to get a GT::SQL object. First, you can simply provide the
|
||||
path to the def file directory where GT::SQL stores all it's information:
|
||||
|
||||
$db = GT::SQL->new('/path/to/def');
|
||||
|
||||
or you can pass in a hash or hash ref and specify options:
|
||||
|
||||
$db = GT::SQL->new(
|
||||
def_path => '/path/to/def',
|
||||
cache => 1,
|
||||
debug => 1,
|
||||
subclass => 1
|
||||
);
|
||||
|
||||
You must specify def_path. Setting C<cache =E<gt> 1> will result in all table
|
||||
and relation objects being cached, which provides a performance improvement in
|
||||
any situation where the same table or relation is used again.
|
||||
|
||||
Specifying C<subclass =E<gt> 0> or C<subclass =E<gt> 1> will enable or disable
|
||||
the ability to subclass any of the objects GT::SQL creates. The default
|
||||
value is C<1>, and should not normally be changed.
|
||||
|
||||
GT::SQL has significant amounts of debugging output that can be enabled by
|
||||
specifying a value of C<1> to the C<debug> option. Larger values can be
|
||||
specified for more detailed debugging output, however a level of C<1> is almost
|
||||
always more than sufficient. The accepted values are as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Level 0
|
||||
|
||||
This is the default, no debugging information is printed to stderr. All errors
|
||||
can be obtained in $GT::SQL::error.
|
||||
|
||||
=item Level 1
|
||||
|
||||
All queries will be displayed to stderr. This is the recommended value if
|
||||
query debugging is desired.
|
||||
|
||||
=item Level 2
|
||||
|
||||
Same as level 1, but includes more detailed information. Also, when calling
|
||||
query_stack you get a stack trace on what generated each query. Not
|
||||
recommended except when working directly on GT::SQL.
|
||||
|
||||
=item Level 3
|
||||
|
||||
Very detailed debug logs including creation and destruction of objects.
|
||||
query_stack generates a javascript page with query, stack trace, and data dump
|
||||
of arguments, but can be extremely large. Not recommended except for debugging
|
||||
GT::SQL internals.
|
||||
|
||||
=back
|
||||
|
||||
B<Pass in a def path>
|
||||
|
||||
$obj = GT::SQL->new('/path/to/def/directory');
|
||||
|
||||
This method of calling new is also supported, however has the drawback that
|
||||
none of the above options can be provided.
|
||||
|
||||
=head2 Getting Connected
|
||||
|
||||
GT::SQL loads the database connection info from database.def which is located
|
||||
in the defs directory.
|
||||
|
||||
To create this file, you call set_connect() as follows:
|
||||
|
||||
$obj->set_connect({
|
||||
driver => 'mysql',
|
||||
host => 'localhost',
|
||||
port => 3243,
|
||||
database => 'databasename',
|
||||
login => 'username',
|
||||
password => 'password',
|
||||
PREFIX => 'prefix_'
|
||||
});
|
||||
|
||||
This will test the database information, and save it to the def file. All
|
||||
future connections will automatically use this connection information.
|
||||
|
||||
Not all of the arguments in this hash are necessary; some have reasonable
|
||||
defaults for the connection.
|
||||
|
||||
=over 4
|
||||
|
||||
=item driver
|
||||
|
||||
This needs to be the driver that is being used for the connection. The default
|
||||
for this is C<mysql>. Driver names are case-insensitive. Available drivers
|
||||
are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item MySQL
|
||||
|
||||
Driver for MySQL databases. Requires that the DBD::mysql module be installed.
|
||||
|
||||
=item Pg
|
||||
|
||||
Driver for PostgreSQL databases. Requires that the DBD::Pg module be
|
||||
installed.
|
||||
|
||||
=item MSSQL
|
||||
|
||||
Driver for MSSQL 7.0 and above. Requires that the DBD::ODBC module be
|
||||
installed.
|
||||
|
||||
=item Oracle
|
||||
|
||||
Driver for Oracle 8 and above. Requires the DBD::Oracle module.
|
||||
|
||||
=back
|
||||
|
||||
=item host
|
||||
|
||||
This will specify the host to connect to. The default, which is acceptable for
|
||||
most installations, is C<localhost>.
|
||||
|
||||
=item port
|
||||
|
||||
This is the port on which to connect to the SQL server. The default for this
|
||||
is to allow the DBI driver to choose the default, which is almost always the
|
||||
appropriate choice.
|
||||
|
||||
=item database
|
||||
|
||||
This is the database name to use on the SQL server. This is required to
|
||||
connect. For MSSQL, this is the I<Data Source> name.
|
||||
|
||||
=item PREFIX
|
||||
|
||||
This specifies a prefix to use for table names. See the L</"Table Prefixes">
|
||||
section below for more information.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Supported Objects
|
||||
|
||||
The following objects can be obtained through a GT::SQL object:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Table/Relation
|
||||
|
||||
To get a table or relation object for working with SQL tables, you should call:
|
||||
|
||||
my $table = $db->table('table_name');
|
||||
|
||||
or for a table join:
|
||||
|
||||
my $relation = $db->table('table_name', 'other_table');
|
||||
|
||||
See L<GT::SQL::Table> for more information on how to use a table object.
|
||||
|
||||
=item Creator
|
||||
|
||||
To create new tables, you need to use a creator. You can get one by calling:
|
||||
|
||||
my $creator = $db->creator('new_table');
|
||||
|
||||
where C<new_table> is the name of the table you wish to create. See
|
||||
L<GT::SQL::Creator> for more information on how to use a creator object.
|
||||
|
||||
=item Editor
|
||||
|
||||
To edit existing tables (i.e. add/drop/change columns, add/drop indexes, etc.)
|
||||
you need an editor object:
|
||||
|
||||
my $editor = $db->editor('existing_table');
|
||||
|
||||
where C<existing_table> is the name of the table you wish the modify. See
|
||||
L<GT::SQL::Editor> for more information on how to use an editor object.
|
||||
|
||||
=item HTML
|
||||
|
||||
To get an html object for generating forms and html output, you need to pass in
|
||||
the table/relation object you want to work with, and a cgi object:
|
||||
|
||||
my $html = $db->html($table, $cgi);
|
||||
|
||||
The html object uses information found in CGI to set values, etc. See
|
||||
L<GT::SQL::Display::HTML> for more information on how to use a html object.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Table Prefixes
|
||||
|
||||
GT::SQL supports the concept of table prefixes. If you specify a prefix using
|
||||
the accessor, it is saved in the database.def file and will be used in all
|
||||
future calls to table(), editor() and creator().
|
||||
|
||||
To set a prefix:
|
||||
|
||||
$db->prefix("foo");
|
||||
|
||||
to get the current prefix:
|
||||
|
||||
my $prefix = $db->prefix;
|
||||
|
||||
What this will do is transparently prepend C<foo> to the beginning of every
|
||||
table name. This means anywhere you access the table C<bar>, the actual table
|
||||
stored on the SQL server will be C<foobar>. Note that the prefix should B<not>
|
||||
be included when getting table/creator/editor/etc. objects - the prefix is
|
||||
handled completely transparently to all public GT::SQL functionality.
|
||||
|
||||
=head2 Query Stack
|
||||
|
||||
To display a list of all raw SQL queries sent to the database you can use:
|
||||
|
||||
my @queries = $db->query_stack;
|
||||
|
||||
or to have them formatted try
|
||||
|
||||
print $db->query_stack_disp;
|
||||
|
||||
which will join them up, displayed nicely. This is also available as a class
|
||||
method:
|
||||
|
||||
print GT::SQL->query_stack_disp;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::SQL::Table>
|
||||
|
||||
L<GT::SQL::Editor>
|
||||
|
||||
L<GT::SQL::Creator>
|
||||
|
||||
L<GT::SQL::Types>
|
||||
|
||||
L<GT::SQL::Admin>
|
||||
|
||||
L<GT::SQL::Display::HTML>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: SQL.pm,v 1.111 2005/04/14 20:22:37 alex Exp $
|
||||
|
||||
=cut
|
||||
3042
site/glist/lib/GT/SQL/Admin.pm
Normal file
3042
site/glist/lib/GT/SQL/Admin.pm
Normal file
File diff suppressed because it is too large
Load Diff
609
site/glist/lib/GT/SQL/Base.pm
Normal file
609
site/glist/lib/GT/SQL/Base.pm
Normal file
@@ -0,0 +1,609 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Table
|
||||
# CVS Info :
|
||||
# $Id: Base.pm,v 1.69 2004/09/22 02:43:29 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base class for GT::SQL::Table and GT::SQL::Relation
|
||||
#
|
||||
|
||||
package GT::SQL::Base;
|
||||
# ===============================================================
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
use strict;
|
||||
use vars qw($ERRORS $DEBUG @ISA $VERSION $ERROR_MESSAGE);
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.69 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
|
||||
# ============================================================================ #
|
||||
# TABLE ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
sub table {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a table or relation argument. Called with array of table names:
|
||||
# my $relation = $db->table('Links', 'CatLinks', 'Category');
|
||||
# my $table = $db->table('Links');
|
||||
#
|
||||
my ($self, @tables) = @_;
|
||||
|
||||
# Make sure we have a driver, and a list of tables were specified.
|
||||
$self->{connect} or return $self->fatal(NODATABASE => 'table()');
|
||||
@tables or return $self->fatal(BADARGS => 'Usage: $obj->table(@TABLES)');
|
||||
|
||||
for (@tables) { # Tables aren't passed to table() prefixed, so prefix them all.
|
||||
$_ = $self->{connect}->{PREFIX} . $_;
|
||||
}
|
||||
my $cache_key = join("\0", @tables, $self->{connect}->{def_path});
|
||||
$cache_key = (@tables > 1 ? "RELATION\0" : "TABLE\0") . $cache_key;
|
||||
$self->{cache} and exists $GT::SQL::OBJ_CACHE{$cache_key} and return $GT::SQL::OBJ_CACHE{$cache_key};
|
||||
|
||||
my $obj;
|
||||
if (@tables > 1) {
|
||||
$obj = $self->new_relation(@tables);
|
||||
}
|
||||
else {
|
||||
my $name = $self->{connect}->{def_path} . '/' . $tables[0] . '.def';
|
||||
(-e $name) or return $self->fatal(FILENOEXISTS => $name);
|
||||
$obj = $self->new_table($tables[0]);
|
||||
}
|
||||
# We don't need to worry about caching here - new_relation or new_table will add it to the cache.
|
||||
return $obj;
|
||||
}
|
||||
|
||||
# ============================================================================ #
|
||||
# EDITOR ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
$COMPILE{editor} = __LINE__ . <<'END_OF_SUB';
|
||||
sub editor {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns an editor object. Takes a table name as argument.
|
||||
# my $editor = $db->editor('Links')
|
||||
#
|
||||
my $self = shift;
|
||||
my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->editor(\'tablename\')');
|
||||
|
||||
$self->{connect}->{driver} or return $self->fatal(NODATABASE => 'editor()');
|
||||
|
||||
my $table = $self->table($table_name);
|
||||
|
||||
# Set the error package to reflect the editor
|
||||
$table->{_err_pkg} = 'GT::SQL::Editor';
|
||||
$table->{_err_pkg} = 'GT::SQL::Editor';
|
||||
|
||||
# Get an editor object
|
||||
require GT::SQL::Editor;
|
||||
$self->debug("CREATING GT::SQL::Editor OBJECT") if $self->{_debug} > 2;
|
||||
return GT::SQL::Editor->new(
|
||||
debug => $self->{_debug},
|
||||
table => $table,
|
||||
connect => $self->{connect}
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{prefix} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prefix {
|
||||
my $self = shift;
|
||||
return $self->{connect}->{PREFIX};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub new_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates a table object for a single table.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $cache_key = "TABLE\0$table\0$self->{connect}->{def_path}";
|
||||
if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
|
||||
$self->debug("Returning table object for $table from cache") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $cached;
|
||||
}
|
||||
|
||||
$self->debug("Creating new table object for $table") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
# Create a blank table object.
|
||||
my $table_obj = GT::SQL::Table->new(
|
||||
name => $table, # Already prefixed in schema
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Table'
|
||||
);
|
||||
|
||||
# Create a new object if we are subclassed.
|
||||
my $subclass = $table_obj->subclass;
|
||||
my $name = $table_obj->name;
|
||||
my $class = $subclass->{table}->{$name} || 'GT::SQL::Table';
|
||||
if ($subclass and $subclass->{table}->{$name}) {
|
||||
no strict 'refs';
|
||||
$self->_load_module($class) or return;
|
||||
my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : {};
|
||||
foreach (keys %$errors) {
|
||||
$ERRORS->{$_} = $errors->{$_};
|
||||
}
|
||||
use strict 'refs';
|
||||
$table_obj = $class->new(
|
||||
name => $name, # Already prefixed in schema
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Table',
|
||||
_schema => $table_obj->{schema}
|
||||
);
|
||||
}
|
||||
$self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
|
||||
$GT::SQL::OBJ_CACHE{$cache_key} = $table_obj if $self->{connect}->{obj_cache};
|
||||
return $table_obj;
|
||||
}
|
||||
|
||||
sub new_relation {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the table objects and relation object for multi-table tasks.
|
||||
# Internal use. Call table instead.
|
||||
#
|
||||
my ($self, @tables) = @_;
|
||||
my $href = {};
|
||||
my $tables_ord = [];
|
||||
my $tables = {};
|
||||
|
||||
require GT::SQL::Relation;
|
||||
|
||||
my $cache_key = join "\0", "RELATION", @tables, $self->{connect}->{def_path};
|
||||
if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
|
||||
$self->debug("Returning relation object for @tables from cache") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $cached;
|
||||
}
|
||||
|
||||
# Build our hash of prefixed table name to table object.
|
||||
foreach my $table (@tables) {
|
||||
$self->debug("CREATING GT::SQL::Table OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
my $tmp = $self->new_table($table);
|
||||
my $name = $tmp->name;
|
||||
push @$tables_ord, $name;
|
||||
$tables->{$name} = $tmp;
|
||||
}
|
||||
|
||||
# Get our driver, class name and key to look up subclasses (without prefixes).
|
||||
my $class = 'GT::SQL::Relation';
|
||||
my $prefix = $self->{connect}->{PREFIX};
|
||||
my $subclass_key = join "\0", map { s/^$prefix//; $_ } sort keys %{$tables};
|
||||
|
||||
# Look for any subclass to use, and load any error messages.
|
||||
no strict 'refs';
|
||||
|
||||
foreach my $table (values %{$tables}) {
|
||||
my $subclass = $table->subclass;
|
||||
if ((!exists $self->{subclass} or $self->{subclass}) and exists $subclass->{relation}->{$prefix . $subclass_key}) {
|
||||
$class = $subclass->{relation}->{$prefix . $subclass_key};
|
||||
my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : next;
|
||||
foreach (keys %$errors) {
|
||||
$ERRORS->{$_} = $errors->{$_};
|
||||
}
|
||||
}
|
||||
}
|
||||
use strict 'refs';
|
||||
|
||||
# Load our relation object.
|
||||
$self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
$self->_load_module($class) or return;
|
||||
|
||||
my $rel = $class->new(
|
||||
tables => $tables,
|
||||
debug => $self->{_debug},
|
||||
connect => $self->{connect},
|
||||
_err_pkg => 'GT::SQL::Relation',
|
||||
tables_ord => $tables_ord
|
||||
);
|
||||
$GT::SQL::OBJ_CACHE{$cache_key} = $rel if ($self->{connect}->{obj_cache});
|
||||
|
||||
return $rel;
|
||||
}
|
||||
|
||||
# ============================================================================ #
|
||||
# CREATOR ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
$COMPILE{creator} = __LINE__ . <<'END_OF_SUB';
|
||||
sub creator {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a creator object. Takes a table name as argument.
|
||||
# my $creator = $db->creator('Links')
|
||||
#
|
||||
my $self = shift;
|
||||
my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->creator(\'tablename\')');
|
||||
$self->{connect}->{driver} or return $self->fatal(NODATABASE => 'creator()');
|
||||
my $name = $self->{connect}->{PREFIX} . $table_name;
|
||||
|
||||
# Create either an empty schema or use an old one.
|
||||
$self->debug("Creating new GT::SQL::Table object '$table_name' to be used in Creator.") if ($self->{_debug} > 2);
|
||||
my $table = GT::SQL::Table->new(
|
||||
name => $table_name,
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Creator'
|
||||
);
|
||||
|
||||
# Return a creator object.
|
||||
require GT::SQL::Creator;
|
||||
$self->debug("CREATING GT::SQL::Creator OBJECT") if $self->{_debug} > 2;
|
||||
return GT::SQL::Creator->new(
|
||||
table => $table,
|
||||
debug => $self->{_debug},
|
||||
connect => $self->{connect}
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub connect {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a driver object, and connects.
|
||||
#
|
||||
my $self = shift;
|
||||
return 1 if $self->{driver};
|
||||
$self->{connect} or return $self->fatal('NOCONNECT');
|
||||
|
||||
my $driver = uc $self->{connect}->{driver} || 'MYSQL';
|
||||
$self->{driver} = GT::SQL::Driver->load_driver(
|
||||
$driver,
|
||||
schema => $self->{tables} || $self->{schema},
|
||||
name => scalar $self->name,
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => $self->{_err_pkg}
|
||||
) or return $self->fatal(CANTLOAD => $driver, $GT::SQL::error);
|
||||
|
||||
unless ($self->{driver}->connect) {
|
||||
delete $self->{driver};
|
||||
return;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub count {
|
||||
# -------------------------------------------------------------------
|
||||
# $obj->count;
|
||||
# ------------
|
||||
# Returns the number of tuples handled
|
||||
# by this relation.
|
||||
#
|
||||
# $obj->count($condition);
|
||||
# -------------------------
|
||||
# Returns the number of tuples that matches
|
||||
# that $condition.
|
||||
#
|
||||
my $self = shift;
|
||||
my @cond;
|
||||
if (!ref $_[0] and @_ % 2 == 0 and defined $_[0]) {
|
||||
push @cond, {@_};
|
||||
}
|
||||
else {
|
||||
for (@_) {
|
||||
return $self->fatal(BADARGS => 'Arguments to count() must either be a hash, or one or more hash refs and/or GT::SQL::Condition objects')
|
||||
unless ref eq 'GT::SQL::Condition' or ref eq 'HASH';
|
||||
push @cond, $_;
|
||||
}
|
||||
}
|
||||
my $sel_opts = $self->{sel_opts};
|
||||
$self->{sel_opts} = [];
|
||||
my $sth = $self->select('COUNT(*)' => @cond ? GT::SQL::Condition->new(@cond) : ()) or return;
|
||||
$self->{sel_opts} = $sel_opts;
|
||||
return int $sth->fetchrow;
|
||||
}
|
||||
|
||||
$COMPILE{total} = __LINE__ . <<'END_OF_SUB';
|
||||
sub total {
|
||||
# -------------------------------------------------------------------
|
||||
# total()
|
||||
# IN : none
|
||||
# OUT: total number of records in table
|
||||
#
|
||||
shift->count
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{quote} = __LINE__ . <<'END_OF_SUB';
|
||||
sub quote {
|
||||
# -------------------------------------------------------------------
|
||||
# $obj->quote($value);
|
||||
# ---------------------
|
||||
# Returns the quoted representation of $value.
|
||||
#
|
||||
return GT::SQL::Driver::quote(pop)
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{hits} = __LINE__ . <<'END_OF_SUB';
|
||||
sub hits {
|
||||
# -----------------------------------------------------------
|
||||
# hits()
|
||||
# IN : none
|
||||
# OUT: number of results in last search. (calls count(*) on
|
||||
# demand from hits() or toolbar())
|
||||
#
|
||||
my $self = shift;
|
||||
if (! defined $self->{last_hits}) {
|
||||
$self->{last_hits} = (defined $self->{last_where} ? $self->count($self->{last_where}) : $self->count) || 0;
|
||||
}
|
||||
return $self->{last_hits};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_cgi_to_hash} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _cgi_to_hash {
|
||||
# -------------------------------------------------------------------
|
||||
# Internal Use
|
||||
# $self->_cgi_to_hash($in);
|
||||
# --------------------------
|
||||
# Creates a hash ref from a cgi object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
defined $cgi and ref $cgi =~ /CGI/ or return $self->fatal(BADARGS => "'$cgi' is not a CGI object");
|
||||
|
||||
my @keys = $cgi->param;
|
||||
my $result = {};
|
||||
for my $key (@keys) {
|
||||
my @values = $cgi->param($key);
|
||||
$result->{$key} = @values == 1 ? $values[0] : \@values;
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_get_search_opts} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _get_search_opts {
|
||||
# -------------------------------------------------------------------
|
||||
# Internal Use
|
||||
# _get_search_opts($hash_ref);
|
||||
# ----------------------------
|
||||
# Gets the search options based on the hash ref
|
||||
# passed in.
|
||||
#
|
||||
# sb => field_list # Return results sorted by field list.
|
||||
# so => [ASC|DESC] # Sort order of results.
|
||||
# mh => n # Return n results maximum, default to 25.
|
||||
# nh => n # Return the n'th set of results, default to 1.
|
||||
# rs => [col, col2] # A list of columns you want returned
|
||||
#
|
||||
my $self = shift;
|
||||
my $opt_r = shift;
|
||||
my $ret = {};
|
||||
$ret->{nh} = (defined $opt_r->{nh} and $opt_r->{nh} =~ /^(\d+)$/) ? $1 : 1;
|
||||
$ret->{mh} = (defined $opt_r->{mh} and $opt_r->{mh} =~ /^(-?\d+)$/) ? $1 : 25;
|
||||
$ret->{so} = (defined $opt_r->{so} and $opt_r->{so} =~ /^(ASC|DESC)$/i) ? $1 : '';
|
||||
$ret->{sb} = (defined $opt_r->{sb} and $opt_r->{sb} =~ /^([\w\s,.]+)$/) ? $1 : '';
|
||||
|
||||
# You can pass in 'Col ASC, Col2 DESC' in {sb} so we need to remove sort order then.
|
||||
if ((lc $ret->{sb}) =~ /\s(?:asc|desc)/) {
|
||||
$ret->{so} = '';
|
||||
}
|
||||
if (defined $ret->{rs} and ref $ret->{rs} eq 'ARRAY') {
|
||||
my @valid;
|
||||
foreach my $col (@{$ret->{rs}}) {
|
||||
$col =~ /^([\w\s,]+)$/ and push @valid, $1;
|
||||
}
|
||||
$ret->{rs} = \@valid;
|
||||
}
|
||||
else {
|
||||
$ret->{rs} = (defined $opt_r->{rs} and $opt_r->{rs} =~ /^([\w\s,]+)$/) ? $1 : '';
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Transitional support. build_query_cond _was_ a private method
|
||||
$COMPILE{_build_query_cond} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _build_query_cond {
|
||||
my $self = shift;
|
||||
warn "obj->_build_query_cond() is deprecated; use obj->build_query_cond()" if $self->{_debug};
|
||||
$self->build_query_cond(@_)
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{build_query_cond} = __LINE__ . <<'END_OF_SUB';
|
||||
sub build_query_cond {
|
||||
# -------------------------------------------------------------------
|
||||
# Builds a condition object based on form input.
|
||||
# field_name => value # Find all rows with field_name = value
|
||||
# field_name => ">=?value" # Find all rows with field_name > or >= value.
|
||||
# field_name => "<=?value" # Find all rows with field_name < or <= value.
|
||||
# field_name => "!value" # Find all rows with field_name != value.
|
||||
# field_name-opt => >=?|<=?|=|<>|LIKE|STARTS|ENDS
|
||||
# # Find all rows with field_name (whichever) value.
|
||||
# field_name-gt => value # Find all rows with field_name > value.
|
||||
# field_name-lt => value # Find all rows with field_name < value.
|
||||
# field_name-ge => value # Find all rows with field_name >= value.
|
||||
# field_name-le => value # Find all rows with field_name <= value.
|
||||
# field_name-ne => value # Find all rows with field_name != value.
|
||||
# keyword => value # Find all rows where any field_name = value
|
||||
# query => value # Find all rows using GT::SQL::Search module
|
||||
# ww => 1 # 1 => use = comparision, 0/unspecified => use LIKE '%value%' comparision
|
||||
# ma => 1 # 1 => OR match 0/unspecified => AND match
|
||||
#
|
||||
my ($self, $opts, $c) = @_;
|
||||
|
||||
my $cond = new GT::SQL::Condition;
|
||||
my ($cmp, $l);
|
||||
($cmp, $l) = $opts->{ww} ? ('=', '') : ('LIKE', '%');
|
||||
$cond->boolean($opts->{ma} ? 'OR' : 'AND');
|
||||
my $ins = 0;
|
||||
|
||||
# First find the fields and find what we
|
||||
# want to do with them.
|
||||
if (defined $opts->{query} and $opts->{query} =~ /\S/) {
|
||||
require GT::SQL::Search;
|
||||
my $search = GT::SQL::Search->load_search({
|
||||
%{$opts},
|
||||
db => $self->{driver},
|
||||
table => $self,
|
||||
debug => $self->{debug},
|
||||
_debug => $self->{_debug}
|
||||
});
|
||||
my $sth = $search->query();
|
||||
$self->{last_hits} = $search->rows();
|
||||
$self->{rejected_keywords} = $search->{rejected_keywords};
|
||||
return $sth;
|
||||
}
|
||||
elsif (defined $opts->{keyword} and ($opts->{keyword} ne "") and ($opts->{keyword} ne '*')) {
|
||||
my $val = $opts->{keyword};
|
||||
my $is_dig = $val =~ /^[+-]*\d+\.?\d*$/;
|
||||
|
||||
foreach my $field (keys %$c) {
|
||||
next unless (index($c->{$field}->{type}, 'DATE') == -1); # No DATE fields.
|
||||
next unless (index($c->{$field}->{type}, 'TIME') == -1); # No TIME fields.
|
||||
next unless (index($c->{$field}->{type}, 'ENUM') == -1); # No ENUM fields.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'INT') != -1)); # No ints if not an int.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'DECIMAL') != -1)); # No ints if not an int.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'FLOAT') != -1)); # No ints if not an int.
|
||||
|
||||
$cond->add($field, $cmp, "$l$opts->{keyword}$l");
|
||||
$ins = 1;
|
||||
}
|
||||
$cond->bool('OR');
|
||||
}
|
||||
else {
|
||||
|
||||
# Go through each column and build condition.
|
||||
foreach my $field (keys %$c) {
|
||||
my $comp = $cmp;
|
||||
my $s = $l;
|
||||
my $e = $l;
|
||||
my @ins;
|
||||
|
||||
if ($opts->{"$field-opt"}) {
|
||||
$comp = uc $opts->{"$field-opt"};
|
||||
|
||||
$s = $e = '';
|
||||
if ( $comp eq 'LIKE' ) {
|
||||
$e = $s = '%';
|
||||
}
|
||||
elsif ( $comp eq 'STARTS' ) {
|
||||
$comp = 'LIKE';
|
||||
$e = '%';
|
||||
}
|
||||
elsif ( $comp eq 'ENDS' ) {
|
||||
$comp = 'LIKE';
|
||||
$s = '%';
|
||||
}
|
||||
|
||||
}
|
||||
else {
|
||||
if ($c->{$field}->{type} =~ /ENUM/i) {
|
||||
$comp = '=';
|
||||
$e = $s = '';
|
||||
}
|
||||
}
|
||||
|
||||
# Comp can only be: =, <, >, <=, >=, <>, LIKE, STARTS, ENDS
|
||||
$comp = '=' unless $comp =~ /^(=|<=?|>=?|<>|LIKE)$/i;
|
||||
|
||||
if (exists $opts->{"$field-gt"} and ($opts->{"$field-gt"} ne "")) {
|
||||
push @ins, [$field, '>', $opts->{$field . "-gt"}];
|
||||
}
|
||||
if (exists $opts->{"$field-lt"} and ($opts->{"$field-lt"} ne "")) {
|
||||
push @ins, [$field, '<', $opts->{$field . "-lt"}];
|
||||
}
|
||||
if (exists $opts->{"$field-ge"} and ($opts->{"$field-ge"} ne "")) {
|
||||
push @ins, [$field, '>=', $opts->{$field . "-ge"}];
|
||||
}
|
||||
if (exists $opts->{"$field-le"} and ($opts->{"$field-le"} ne "")) {
|
||||
push @ins, [$field, '<=', $opts->{$field . "-le"}];
|
||||
}
|
||||
|
||||
if (exists $opts->{"$field-ne"} and ($opts->{"$field-ne"} ne "")) {
|
||||
my $c = new GT::SQL::Condition;
|
||||
$c->add($field => '!=' => $opts->{"$field-ne"});
|
||||
}
|
||||
|
||||
if (exists $opts->{$field} and ($opts->{$field} ne "")) {
|
||||
if (ref($opts->{$field}) eq 'ARRAY' ) {
|
||||
my $add = [];
|
||||
for ( @{$opts->{$field}} ) {
|
||||
next if !defined( $_ ) or !length( $_ ) or !/\S/;
|
||||
push @$add, $_;
|
||||
}
|
||||
if ( @$add ) {
|
||||
push @ins, [$field, 'IN', $add];
|
||||
}
|
||||
}
|
||||
elsif ($opts->{$field} =~ /^(>=?|<=?|!)(.*)/) {
|
||||
push @ins, [$field, ($1 eq '!') ? '<>' : $1, $2];
|
||||
}
|
||||
elsif ($opts->{$field} eq '+') {
|
||||
push @ins, [$field, "<>", ''];
|
||||
}
|
||||
elsif ($opts->{$field} eq '-') {
|
||||
push @ins, [$field, "=", ''];
|
||||
}
|
||||
elsif ($opts->{$field} eq '*') {
|
||||
if ($opts->{"$field-opt"} and ($opts->{"$field-opt"} eq '<>')) {
|
||||
push @ins, [$field, '=', ''];
|
||||
}
|
||||
else {
|
||||
next;
|
||||
}
|
||||
}
|
||||
else {
|
||||
substr($opts->{$field}, 0, 1) = "" if substr($opts->{$field}, 0, 1) eq '\\';
|
||||
push @ins, [$field, $comp, "$s$opts->{$field}$e"];
|
||||
}
|
||||
}
|
||||
|
||||
if (@ins) {
|
||||
for (@ins) {
|
||||
$cond->add($_);
|
||||
}
|
||||
$ins = 1;
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
return $ins ? $cond : '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub _load_module {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a subclassed module.
|
||||
#
|
||||
my ($self, $class) = @_;
|
||||
|
||||
no strict 'refs';
|
||||
return 1 if (UNIVERSAL::can($class, 'new'));
|
||||
|
||||
(my $pkg = $class) =~ s,::,/,g;
|
||||
my $ok = 0;
|
||||
my @err = ();
|
||||
until ($ok) {
|
||||
local ($@, $SIG{__DIE__});
|
||||
eval { require "$pkg.pm" };
|
||||
if ($@) {
|
||||
push @err, $@;
|
||||
# In case the module had compile errors, %class:: will be defined, but not complete.
|
||||
undef %{$class . '::'} if defined %{$class . '::'};
|
||||
}
|
||||
else {
|
||||
$ok = 1;
|
||||
last;
|
||||
}
|
||||
my $pos = rindex($pkg, '/');
|
||||
last if $pos == -1;
|
||||
substr($pkg, $pos) = "";
|
||||
}
|
||||
unless ($ok and UNIVERSAL::can($class, 'new')) {
|
||||
return $self->fatal(BADSUBCLASS => $class, join ", ", @err);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
404
site/glist/lib/GT/SQL/Condition.pm
Normal file
404
site/glist/lib/GT/SQL/Condition.pm
Normal file
@@ -0,0 +1,404 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Base
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Condition.pm,v 1.44 2004/10/12 17:54:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements an SQL condition.
|
||||
#
|
||||
|
||||
package GT::SQL::Condition;
|
||||
# ===============================================================
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $VERSION/;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.44 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
# CLASS->new;
|
||||
# $obj->new;
|
||||
# ----------
|
||||
# This class method is the base constructor for the GT::SQL::Condition
|
||||
# object. It can be passed the boolean operator that has to be used for that
|
||||
# object ("AND" is the default), the conditions for this object.
|
||||
#
|
||||
my $class = shift;
|
||||
$class = ref $class || $class;
|
||||
my $self = {
|
||||
cond => [],
|
||||
not => 0,
|
||||
bool => 'AND'
|
||||
};
|
||||
bless $self, $class;
|
||||
|
||||
if (@_ and defined $_[$#_] and (uc $_[$#_] eq 'AND' or uc $_[$#_] eq 'OR' or $_[$#_] eq ',') ) {
|
||||
$self->boolean(uc pop);
|
||||
}
|
||||
$self->add(@_) if @_;
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{clone} = __LINE__ . <<'END_OF_SUB';
|
||||
sub clone {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Clones the current object - that is, gives you an identical object that
|
||||
# doesn't reference the original at all.
|
||||
#
|
||||
my $self = shift;
|
||||
my $newself = { not => $self->{not}, bool => $self->{bool} };
|
||||
bless $newself, ref $self;
|
||||
my @cond;
|
||||
|
||||
for (@{$self->{cond}}) {
|
||||
# {cond} can contain two things - three-value array references
|
||||
# ('COL', '=', 'VAL'), or full-fledged condition objects.
|
||||
if (ref eq 'ARRAY') {
|
||||
push @cond, [@$_];
|
||||
}
|
||||
elsif (UNIVERSAL::isa($_, __PACKAGE__)) {
|
||||
push @cond, $_->clone;
|
||||
}
|
||||
}
|
||||
$newself->{cond} = \@cond;
|
||||
$newself;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{not} = __LINE__ . <<'END_OF_SUB';
|
||||
sub not {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->not;
|
||||
# ----------------
|
||||
# Negates the current condition.
|
||||
#
|
||||
$_[0]->{not} = 1;
|
||||
return $_[0];
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
|
||||
$COMPILE{new_clean} = __LINE__ . <<'END_OF_SUB';
|
||||
sub new_clean {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->new_clean;
|
||||
# ----------------
|
||||
# Returns the same condition object, but ready to be prepared again.
|
||||
#
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
my $res = $class->new;
|
||||
$res->boolean($self->boolean);
|
||||
for my $cond (@{$self->{cond}}) {
|
||||
$res->add($cond);
|
||||
}
|
||||
return $res;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub boolean {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->boolean;
|
||||
# --------------
|
||||
# Returns the boolean operator which is being used for the current object.
|
||||
#
|
||||
# $obj->boolean($string);
|
||||
# ------------------------
|
||||
# Sets $string as the boolean operator for this condition object. Typically
|
||||
# this should be nothing else than "AND" or "OR", but no checks are
|
||||
# performed, so watch out for typos!
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{bool} = shift || return $self->{bool};
|
||||
}
|
||||
|
||||
sub add {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->add($col => $op => $val [, $col2 => $op2 => $val2, ...]);
|
||||
# ----------------------------
|
||||
# Adds a one or more COL OP VAL clauses to the current condition.
|
||||
#
|
||||
# $obj->add($condition [, $cond2, ...]);
|
||||
# -----------------------
|
||||
# Adds one or more condition clauses to the current condition.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
while (@_) {
|
||||
my $var = shift;
|
||||
if (ref $var eq 'ARRAY' or UNIVERSAL::isa($var, __PACKAGE__)) {
|
||||
push @{$self->{cond}}, $var;
|
||||
}
|
||||
elsif (ref $var eq 'HASH') {
|
||||
for (keys %$var) {
|
||||
push @{$self->{cond}}, [$_ => '=' => $var->{$_}];
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $op = @_ >= 2 ? shift || '=' : '='; # To support $cond->add(foo => $bar);
|
||||
my $val = shift;
|
||||
if (not defined $val) {
|
||||
if ($op eq '=' and $self->{bool} ne ',') {
|
||||
$op = 'IS';
|
||||
}
|
||||
elsif ($op eq '!=' or $op eq '<>') {
|
||||
$op = 'IS NOT';
|
||||
}
|
||||
}
|
||||
push @{$self->{cond}}, [$var => $op => $val];
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub sql {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a string for the current SQL object which is the SQL representation
|
||||
# of that condition. The string can then be inserted after a SQL WHERE clause.
|
||||
# Optionally takes an option which, if true, uses placeholders and returns
|
||||
# ($sql, \@values, \@columns) instead of just $sql.
|
||||
#
|
||||
my ($self, $ph) = @_;
|
||||
my $bool = $self->{bool};
|
||||
my (@vals, @cols, @output);
|
||||
|
||||
foreach my $cond (@{$self->{cond}}) {
|
||||
if (ref $cond eq 'ARRAY') {
|
||||
my ($col, $op, $val) = @$cond;
|
||||
# Perl: column => '=' => [1,2,3]
|
||||
# SQL: column IN (1,2,3)
|
||||
if (uc $op eq 'IN' || $op eq '=' and ref $val eq 'ARRAY') {
|
||||
if (@$val > 1) {
|
||||
$op = 'IN';
|
||||
$val = '('
|
||||
. join(',' => map !length || /\D/ ? quote($_) : $_, @$val)
|
||||
. ')';
|
||||
}
|
||||
elsif (@$val == 0) {
|
||||
($col, $op, $val) = (qw(1 = 0));
|
||||
}
|
||||
else {
|
||||
$op = '=';
|
||||
$val = quote($val->[0]);
|
||||
}
|
||||
push @output, "$col $op $val";
|
||||
}
|
||||
# Perl: column => '!=' => [1,2,3]
|
||||
# SQL: NOT(column IN (1,2,3))
|
||||
elsif ($op eq '!=' || $op eq '<>' and ref $val eq 'ARRAY') {
|
||||
my $output;
|
||||
if (@$val > 1) {
|
||||
$output = "NOT ($col IN ";
|
||||
$output .= '('
|
||||
. join(',' => map !length || /\D/ ? quote($_) : $_, @$val)
|
||||
. ')';
|
||||
$output .= ')';
|
||||
}
|
||||
elsif (@$val == 0) {
|
||||
$output = '1 = 1';
|
||||
}
|
||||
else {
|
||||
$output = "$col $op " . quote($val->[0]);
|
||||
}
|
||||
push @output, $output;
|
||||
}
|
||||
elsif ($ph and defined $val and not ref $val) {
|
||||
push @output, "$col $op ?";
|
||||
push @cols, $col;
|
||||
push @vals, $val;
|
||||
}
|
||||
else {
|
||||
push @output, "$col $op " . quote($val);
|
||||
}
|
||||
}
|
||||
elsif (UNIVERSAL::isa($cond, __PACKAGE__)) {
|
||||
my @sql = $cond->sql($ph);
|
||||
if ($sql[0]) {
|
||||
push @output, "($sql[0])";
|
||||
if ($ph) {
|
||||
push @vals, @{$sql[1]};
|
||||
push @cols, @{$sql[2]};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
my $final = join " $bool ", @output;
|
||||
$final &&= "NOT ($final)" if $self->{not};
|
||||
|
||||
return wantarray ? ($final, $ph ? (\@vals, \@cols) : ()) : $final;
|
||||
}
|
||||
|
||||
$COMPILE{sql_ph} = __LINE__ . <<'END_OF_SUB';
|
||||
sub sql_ph {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Depreciated form of ->sql(1);
|
||||
shift->sql(1);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub quote {
|
||||
# -----------------------------------------------------------------------------
|
||||
# this subroutines quotes (or not) a value given its column.
|
||||
#
|
||||
defined(my $val = pop) or return 'NULL';
|
||||
return ref $val eq 'SCALAR' ? $$val : GT::SQL::Driver->quote($val);
|
||||
}
|
||||
|
||||
sub as_hash {
|
||||
# -----------------------------------------------------------------------------
|
||||
# returns the condition object as a flattened hash.
|
||||
#
|
||||
my $cond = shift;
|
||||
ref $cond eq 'HASH' and return $cond;
|
||||
my %ret;
|
||||
for my $arr (@{$cond->{cond}}) {
|
||||
if (ref $arr eq 'ARRAY') {
|
||||
$ret{$arr->[0]} = $arr->[2];
|
||||
}
|
||||
else {
|
||||
my $h = as_hash($arr);
|
||||
for my $k (keys %$h) {
|
||||
$ret{$k} = $h->{$k};
|
||||
}
|
||||
}
|
||||
}
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::SQL::Condition - Creates complex where clauses
|
||||
|
||||
=head1 SYNOPSYS
|
||||
|
||||
my $cond = GT::SQL::Condition->new(Column => LIKE => 'foo%');
|
||||
print $cond->sql;
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
Column => LIKE => 'foo%',
|
||||
Column2 => '<' => 'abc'
|
||||
);
|
||||
$cond->bool('OR');
|
||||
print $cond->sql;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The condition module is useful for generating complex SQL WHERE clauses. At
|
||||
it's simplest, a condition is composed of three parts: column, condition and
|
||||
value.
|
||||
|
||||
Here are some examples.
|
||||
|
||||
To find all users with a first name that starts with Alex use:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(FirstName => LIKE => 'Alex%');
|
||||
|
||||
To find users with first name like alex, B<and> last name like krohn use:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
FirstName => LIKE => 'Alex%',
|
||||
LastName => LIKE => 'Krohn%'
|
||||
);
|
||||
|
||||
To find users with first name like alex B<or> last name like krohn use:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
FirstName => LIKE => 'Alex%',
|
||||
LastName => LIKE => 'Krohn%'
|
||||
);
|
||||
$cond->bool('OR');
|
||||
|
||||
You may also specify this as:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
FirstName => LIKE => 'Alex%',
|
||||
LastName => LIKE => 'Krohn%',
|
||||
'OR'
|
||||
);
|
||||
|
||||
Now say we wanted something a bit more complex that would normally involve
|
||||
setting parentheses. We want to find users who have either first name like alex
|
||||
or last name like krohn, and whose employer is Gossamer Threads. We could use:
|
||||
|
||||
my $cond1 = GT::SQL::Condition->new(
|
||||
'FirstName', 'LIKE', 'Alex%',
|
||||
'LastName', 'LIKE', 'Krohn%'
|
||||
);
|
||||
$cond1->bool('or');
|
||||
my $cond2 = GT::SQL::Condition->new(
|
||||
$cond1,
|
||||
Employer => '=' => 'Gossamer Threads'
|
||||
);
|
||||
|
||||
By default, all values are quoted, so you don't need to bother using any quote
|
||||
function. If you don't want something quoted (say you want to use a function
|
||||
for example), then you pass in a reference.
|
||||
|
||||
For example, to find users who have a last name that sounds like 'krohn', you
|
||||
could use your SQL engines SOUNDEX function:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(LastName => '=' => \"SOUNDEX('krohn')");
|
||||
|
||||
and the right side wouldn't be quoted.
|
||||
|
||||
You can also use a condition object to specify a list of multiple values, which
|
||||
will become the SQL 'IN' operator. For example, to match anyone with a first
|
||||
name of Alex, Scott or Jason, you can do:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(FirstName => IN => ['Alex', 'Scott', 'Jason']);
|
||||
|
||||
which will turn into:
|
||||
|
||||
FirstName IN ('Alex', 'Scott', 'Jason')
|
||||
|
||||
Note that when using multiple values, you can use '=' instead of 'IN'. Empty
|
||||
lists will be treated as an impossible condition (1 = 0). This is primarily
|
||||
useful for list handling list of id numbers.
|
||||
|
||||
To match NULL values, you can use C<undef> for the value passed to the add()
|
||||
method. If specifying '=' as the operator, it will automatically be changed to
|
||||
'IS':
|
||||
|
||||
$cond->add(MiddleName => '=' => undef);
|
||||
|
||||
becomes:
|
||||
|
||||
MiddleName IS NULL
|
||||
|
||||
|
||||
To negate your queries you can use the C<not> function.
|
||||
|
||||
my $cond = GT::SQL::Condition->new(a => '=' => 5);
|
||||
$cond->not;
|
||||
|
||||
would translate into NOT (a = '5'). You can also do this all on one line like:
|
||||
|
||||
print GT::SQL::Condition->new(a => '=' => '5')->not->sql;
|
||||
|
||||
This returns the sql right away.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Condition.pm,v 1.44 2004/10/12 17:54:30 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1216
site/glist/lib/GT/SQL/Creator.pm
Normal file
1216
site/glist/lib/GT/SQL/Creator.pm
Normal file
File diff suppressed because it is too large
Load Diff
887
site/glist/lib/GT/SQL/Display/HTML.pm
Normal file
887
site/glist/lib/GT/SQL/Display/HTML.pm
Normal file
@@ -0,0 +1,887 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: HTML.pm,v 1.92 2005/04/05 18:47:08 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS $INPUT_SEPARATOR/;
|
||||
use GT::Base;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$FONT = 'face="Tahoma,Arial,Helvetica" size=2';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.92 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$INPUT_SEPARATOR = "\n";
|
||||
|
||||
$ATTRIBS = {
|
||||
db => undef,
|
||||
input => undef,
|
||||
mode => '',
|
||||
code => {},
|
||||
font => $FONT,
|
||||
hide_timestamp => 0,
|
||||
hide_download => 0,
|
||||
file_field => 0,
|
||||
file_delete => 0,
|
||||
file_use_path => 0,
|
||||
view_key => 0,
|
||||
defaults => 0,
|
||||
search_opts => 0,
|
||||
values => {},
|
||||
multiple => 0,
|
||||
table => 'border=0 width=500',
|
||||
tr => '',
|
||||
td => 'valign=top align=left',
|
||||
extra_table => 1,
|
||||
col_font => $FONT,
|
||||
val_font => $FONT,
|
||||
hide => [],
|
||||
skip => [],
|
||||
view => [],
|
||||
disp_form => 1,
|
||||
disp_html => 0,
|
||||
url => $ENV{REQUEST_URI},
|
||||
};
|
||||
|
||||
sub init {
|
||||
# ---------------------------------------------------------------
|
||||
# new() comes from GT::Base.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Set any passed in options.
|
||||
$self->set (@_);
|
||||
|
||||
# Try to set the URL
|
||||
$self->{url} or eval { require GT::CGI; $self->{url} = GT::CGI->url(); };
|
||||
$self->{url} ||= '';
|
||||
|
||||
# Make sure we have a database object.
|
||||
# exists ($self->{db}) and (ref $self->{db}) or return $self->error ("BADARGS", "FATAL", "You must pass in a GT::SQL::Table object");
|
||||
|
||||
my $input = ref $self->{input};
|
||||
if ($input and ($input eq 'GT::CGI')) {
|
||||
$self->{input} = $self->{input}->get_hash;
|
||||
}
|
||||
elsif ($input and ($input eq 'CGI')) {
|
||||
my $h = {};
|
||||
foreach my $key ($self->{input}->param) {
|
||||
$h->{$key} = $self->{input}->param($key);
|
||||
}
|
||||
$self->{input} = $h;
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub reset_opts {
|
||||
# ---------------------------------------------------------------
|
||||
# Resets the display options.
|
||||
#
|
||||
my $self = shift;
|
||||
while (my ($k, $v) = each %$ATTRIBS) {
|
||||
next if $k eq 'db';
|
||||
next if $k eq 'disp_form';
|
||||
next if $k eq 'disp_html';
|
||||
next if $k eq 'input';
|
||||
if (! ref $v) {
|
||||
$self->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$self->{$k} = {};
|
||||
foreach my $k1 (keys %{$ATTRIBS->{$k}}) { $self->{$k}->{$k1} = $ATTRIBS->{$k}->{$k1}; }
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$self->{$k} = [];
|
||||
foreach my $v1 (@{$ATTRIBS->{$k}}) { push @{$self->{$k}}, $v1; }
|
||||
}
|
||||
else { $self->{$k} = $v; }
|
||||
}
|
||||
}
|
||||
|
||||
sub form {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as an html form.
|
||||
#
|
||||
my $self = shift;
|
||||
$_[0]->{disp_form} = 1;
|
||||
$_[0]->{disp_html} = 0;
|
||||
return $self->_display (@_);
|
||||
}
|
||||
|
||||
sub display {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as html.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->error ("NEEDSUBCLASS", "FATAL")
|
||||
}
|
||||
|
||||
sub _get_defaults {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns default values for fields. Bases it on what's passed in,
|
||||
# cgi input, def file defaults, otherwise blank.
|
||||
#
|
||||
my $self = shift;
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
my $c = $self->{cols} || $self->{db}->cols;
|
||||
my $values = {};
|
||||
foreach my $col (@cols) {
|
||||
my $value = '';
|
||||
if (exists $self->{values}->{$col}) { $value = $self->{values}->{$col} }
|
||||
elsif (exists $self->{input}->{$col}) { $value = $self->{input}->{$col} }
|
||||
elsif ($self->{defaults} and exists $c->{$col}->{default}) {
|
||||
if ($c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
($c->{$col}->{default} =~ /0000/)
|
||||
? ($value = $self->_get_time($c->{$col}))
|
||||
: ($value = $c->{$col}->{default});
|
||||
}
|
||||
else {
|
||||
$value = $c->{$col}->{default};
|
||||
}
|
||||
}
|
||||
elsif ($self->{defaults} and $c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
$value = $self->_get_time($c->{$col});
|
||||
}
|
||||
if ($c->{$col}->{form_type} and uc $c->{$col}->{form_type} eq 'FILE' ) {
|
||||
$values->{$col."_filename"} = $self->{values}->{$col."_filename"};
|
||||
}
|
||||
$values->{$col} = $value;
|
||||
}
|
||||
return $values;
|
||||
}
|
||||
|
||||
sub _skip {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $col) = @_;
|
||||
|
||||
# Skip timestamps, any fields requested to be skipped or any hidden fields (hidden forms appended at bottom).
|
||||
return 1 if ($self->{hide_timestamp} and $self->{cols}->{$col}->{time_check});
|
||||
return 1 if ($self->{skip} and (grep /^$col$/, @{$self->{skip}}));
|
||||
return 1 if ($self->{hide} and (grep /^$col$/, @{$self->{hide}}));
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _get_form_display {
|
||||
my ($self, $col) = @_;
|
||||
|
||||
if (
|
||||
($self->{view_key} and
|
||||
exists $self->{cols}->{$col}->{time_check} and
|
||||
$self->{cols}->{$col}->{time_check})
|
||||
||
|
||||
($self->{view} and (grep /^$col$/, @{$self->{view}}))
|
||||
)
|
||||
{
|
||||
return 'hidden_text';
|
||||
}
|
||||
|
||||
my $form_type = lc $self->{cols}->{$col}->{form_type} or return 'default';
|
||||
|
||||
if ( $form_type eq 'password' and index( $self->{mode}, 'search_form' ) + 1 ) {
|
||||
return 'default'
|
||||
}
|
||||
|
||||
elsif ( $form_type and $self->can( $form_type ) ) {
|
||||
return $form_type;
|
||||
}
|
||||
|
||||
return 'default';
|
||||
}
|
||||
|
||||
sub _get_html_display {
|
||||
my $self = shift;
|
||||
my $col = shift;
|
||||
return 'display_text';
|
||||
}
|
||||
|
||||
# Form types
|
||||
sub default {
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to form creator _mk_char_form");
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to form creator _mk_char_form");
|
||||
my $val = exists $opts->{value} ? $opts->{value} : (exists $def->{default} ? $def->{default} : '');
|
||||
my $size = exists $opts->{form_size} ? $opts->{form_size} : (exists $def->{form_size} ? ($def->{form_size} || 30) : 30);
|
||||
my $max = exists $opts->{size} ? $opts->{def}->{size} : (exists $def->{size} ? $def->{size} : 255);
|
||||
|
||||
defined ($val) or $val = '';
|
||||
_escape(\$val);
|
||||
return qq~<input type="TEXT" name="$name" value="$val" maxlength="$max" size="$size">~;
|
||||
}
|
||||
|
||||
sub date {
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{form_size} ||= 20;
|
||||
return $self->text ($opts);
|
||||
}
|
||||
|
||||
sub multiple { shift->select (@_) }
|
||||
|
||||
sub select {
|
||||
# ---------------------------------------------------------------
|
||||
# Make a select list. Valid options are:
|
||||
# name => FORM_NAME
|
||||
# values => { form_value => displayed_value }
|
||||
# value => selected_value
|
||||
# or
|
||||
# value => [selected_value1, selected_value2]
|
||||
# multiple => n - adds MULTIPLE SIZE=n to select list
|
||||
# sort => coderef called to sort the list or array ref specifying the order in
|
||||
# which the fields should be display. A code ref, when called, will be
|
||||
# passed the following arguments: ($value{$a}, $value{$b}, $a, $b)
|
||||
# blank => 1 or 0. If true, a blank first option will be printed, if false
|
||||
# the blank first element will not be printed. Defaults to true.
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS1", "FATAL", "No form name passed to select");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Get the default value to display if nothing is selected.
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
else { $def = '' }
|
||||
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my ($sort_f, $sort_o);
|
||||
if (ref $opts->{sort} eq 'CODE') {
|
||||
$sort_f = $opts->{sort};
|
||||
}
|
||||
elsif (ref $opts->{sort} eq 'ARRAY') {
|
||||
$sort_o = $opts->{sort};
|
||||
}
|
||||
# sort_order => [...] has been replaced with sort => [...] and so it
|
||||
# is NOT mentioned in the subroutine comments.
|
||||
elsif (ref $opts->{sort_order} eq 'ARRAY') {
|
||||
$sort_o = $opts->{sort_order};
|
||||
}
|
||||
my $blank = exists $opts->{blank} ? $opts->{blank} : 1;
|
||||
|
||||
# Multiple was passed in
|
||||
my $mult;
|
||||
my $clean_name = $name;
|
||||
if ($name =~ /^\d\-(.+)$/) {
|
||||
$clean_name = $1;
|
||||
}
|
||||
if (exists $self->{cols}->{$clean_name} and $self->{cols}->{$clean_name}->{form_type} and $self->{cols}->{$clean_name}->{form_type} eq 'MULTIPLE') {
|
||||
$mult = qq!MULTIPLE SIZE="$self->{cols}->{$clean_name}->{form_size}"!;
|
||||
}
|
||||
elsif (exists $opts->{multiple} and $opts->{multiple} > 1) {
|
||||
$mult = qq!MULTIPLE SIZE="$opts->{multiple}"!;
|
||||
}
|
||||
elsif (exists $self->{cols}->{$clean_name} and $self->{cols}->{$clean_name}->{form_size}) {
|
||||
$mult = qq!SIZE="$self->{cols}->{$clean_name}->{form_size}"!;
|
||||
}
|
||||
else {
|
||||
$mult = '';
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
my $out = qq~<select $mult name="$name"$class>~;
|
||||
$blank and ($out .= qq~<option value="">---</option>~);
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->($hash{$a}, $hash{$b}, $a, $b) } keys %hash }
|
||||
else { @keys = @$names; }
|
||||
|
||||
if (! ref $def) {
|
||||
$def = { map { ($_ => 1) } split (/\Q$INPUT_SEPARATOR\E%?/o, $def) };
|
||||
}
|
||||
else { # Array ref
|
||||
$def = { map { ($_ => 1) } @$def };
|
||||
}
|
||||
for my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
$out .= qq~<option value="$key"~;
|
||||
$out .= " selected" if $def->{$key};
|
||||
$out .= ">$val</option>";
|
||||
}
|
||||
$out .= "</select>\n";
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub radio {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a radio series.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No name for field passed to radio");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Make sure we have something.
|
||||
if (! @{$names} or ! @{$values}) {
|
||||
return $self->error ("BADARGS", "FATAL", "No value hash passed to checkbox");
|
||||
}
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my $sort_f = exists $opts->{sort} ? $opts->{sort} : sub { lc $hash{$a} cmp lc $hash{$b} };
|
||||
my $sort_o = exists $opts->{sort_order} ? $opts->{sort_order} : '';
|
||||
my $out;
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o; }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->() } keys %hash; }
|
||||
else { @keys = keys %hash; }
|
||||
|
||||
(ref $def eq 'ARRAY') or ($def = [$def]);
|
||||
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
KEY: foreach my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
VAL: foreach my $sel (@$def) {
|
||||
($key eq $sel) and ($out .= qq~$val<input type="radio" value="$key"$class name="$name" checked> ~) and next KEY;
|
||||
}
|
||||
$out .= qq~$val<input name="$name" type="radio" value="$key"$class> ~;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub checkbox {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a checkbox set.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Make sure we have something.
|
||||
if (! @{$names} or ! @{$values}) {
|
||||
return $self->error ("BADARGS", "FATAL", "No value hash passed to checkbox");
|
||||
}
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
my $sort_f = exists $opts->{sort} ? $opts->{sort} : sub { lc $hash{$a} cmp lc $hash{$b} };
|
||||
my $sort_o = exists $opts->{sort_order} ? $opts->{sort_order} : '';
|
||||
my $out;
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o; }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->() } keys %hash }
|
||||
else { @keys = keys %hash }
|
||||
|
||||
if (! ref $def) {
|
||||
$def = [sort split (/\Q$INPUT_SEPARATOR\E%?/o, $def)];
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
KEY: foreach my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
VAL: foreach my $sel (@$def) {
|
||||
($key eq $sel) and ($out .= qq~ <input name="$name" type="checkbox" value="$key" checked$class>$val~) and next KEY;
|
||||
}
|
||||
$out .= qq~ <input name="$name" type="checkbox" value="$key"$class>$val~;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub hidden {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a hidden field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
return qq~<input type="hidden" name="$name" value="$def">~;
|
||||
}
|
||||
|
||||
sub hidden_text {
|
||||
my ($self, $opts) = @_;
|
||||
my $out;
|
||||
my $html = $self->_get_html_display;
|
||||
$out .= "<font $self->{val_font}>";
|
||||
$out .= $self->$html($opts);
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
elsif (exists $opts->{def}->{time_check}) { $def = $self->_get_time ($opts->{def}) }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
$out .= qq~<input type="hidden" name="$opts->{name}" value="$def"></font>~;
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub file {
|
||||
# ---------------------------------------------------------------
|
||||
# creates a file field
|
||||
#
|
||||
# function is a bit large since it has to do a fair bit, with multiple options.
|
||||
#
|
||||
my ($self, $opts, $values, $display ) = @_;
|
||||
|
||||
$values ||= {};
|
||||
$self->{file_field} or return $self->text($opts);
|
||||
|
||||
my @parts = split /\./, $opts->{name};
|
||||
my $name = pop @parts;
|
||||
my $dbname = shift @parts || $self->{db}->name;
|
||||
my $prefix = $self->{db}->prefix;
|
||||
$dbname =~ s,^$prefix,, if ($prefix);
|
||||
|
||||
my $def = $opts->{def};
|
||||
my $out;
|
||||
my $colname = $opts->{name}; $colname =~ s,^\d*-,,;
|
||||
my $fname = $opts->{value};
|
||||
_escape(\$fname);
|
||||
|
||||
# Find out if the file exists
|
||||
my $tbl = $display->{db}->new_table( $dbname . "_Files" ) or return 'Associated _File table is missing';
|
||||
my @pk = $self->{db}->pk; @pk == 1 or return 'File handling requires one primary key';
|
||||
|
||||
my $href = $tbl->get({ ForeignColName => $colname, ForeignColKey => $values->{$pk[0]} });
|
||||
unless ( ( not $href and not $self->{file_use_path} ) or
|
||||
( not ( -e $opts->{value}) and $self->{file_use_path} ) ) {
|
||||
|
||||
require GT::SQL::File;
|
||||
my $sfname = $values->{$colname."_filename"};
|
||||
$out = $sfname || GT::SQL::File::get_filename($fname ||= $href->{File_Name} );
|
||||
$self->{file_use_path} and $out .= qq!<input name="$opts->{name}_path" type=hidden value="$fname">!;
|
||||
$sfname and $out .= qq!<input type=hidden name="$opts->{name}_filename" type=hidden value="$sfname">!;
|
||||
|
||||
if ( $fname and $self->{file_delete} ) {
|
||||
|
||||
if ( $def->{form_type} =~ /^file$/i and not $self->{hide_downloads} and $self->{url} ) {
|
||||
my $url = _reparam_url(
|
||||
$self->{url},
|
||||
{
|
||||
do => 'download_file',
|
||||
id => $values->{$pk[0]},
|
||||
cn => $colname,
|
||||
db => $dbname,
|
||||
src => ( $self->{file_use_path} ? 'path' : 'db' ),
|
||||
fname => $fname
|
||||
},
|
||||
[qw( do id cn db src )]
|
||||
);
|
||||
$out .= qq! <font $self->{font}><font size=1><i><a href="$url">download</a></i></font></font>!;
|
||||
$url = _reparam_url(
|
||||
$self->{url},
|
||||
{
|
||||
do => 'view_file',
|
||||
id => $values->{$pk[0]},
|
||||
cn => $colname,
|
||||
db => $dbname,
|
||||
src => ( $self->{file_use_path} ? 'path' : 'db' ),
|
||||
fname => $fname
|
||||
},
|
||||
[qw( do id cn db src )]
|
||||
);
|
||||
$out .= qq! <font $self->{font}><font size=1><i><a href="$url" target=_blank>view</a></i></font></font>!;
|
||||
}
|
||||
$out .= qq~ <input type=checkbox name="$opts->{name}_del" value="delete"> Delete~;
|
||||
}
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
$out .= qq~<p><input type="file" name="$opts->{name}"$class>~;
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub text {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a text field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
return qq~<input type="text" name="$name" value="$def" size="$size"$class>~;
|
||||
}
|
||||
|
||||
sub password {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a password field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my $def;
|
||||
if ( $opts->{blank} ) { $def = '' } # keep the password element blank
|
||||
elsif (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
return qq~<input type="password" name="$name" value="$def" size="$size"$class>~;
|
||||
}
|
||||
|
||||
sub textarea {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a textarea.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my ($cols, $rows) = (ref $size) ? (@{$size}) : ($size, 4);
|
||||
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
return qq~<textarea rows="$rows" cols="$cols" name="$name"$class>$def</textarea>~;
|
||||
}
|
||||
|
||||
sub display_text {
|
||||
# ---------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $opts = shift or return $self->error ("BADARGS", "FATAL", "No hash ref passed to form creator display_text");
|
||||
my $values = shift;
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to view creator display_text (" . (caller())[2] . ")" );
|
||||
my $val = exists $opts->{value} ? $opts->{value} : (exists $def->{default} ? $def->{default} : '');
|
||||
my $pval = $val;
|
||||
defined $val or ($val = '');
|
||||
_escape(\$val);
|
||||
|
||||
# If they are using checkbox/radio/selects then we map form_names => form_values.
|
||||
if (ref $def->{form_names} and ref $def->{form_values}) {
|
||||
if (@{$def->{form_names}} and @{$def->{form_values}}) {
|
||||
my %map = map { $def->{form_names}->[$_] => $def->{form_values}->[$_] } (0 .. $#{$def->{form_names}});
|
||||
my @keys = split /\Q$INPUT_SEPARATOR\E|\n/, $val;
|
||||
$val = '';
|
||||
|
||||
foreach (@keys) {
|
||||
$val .= $map{$_} ? $map{$_} : $_;
|
||||
$val .= "<br>";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($def->{form_type} and uc $def->{form_type} eq 'FILE' and not $self->{hide_downloads} and $self->{url}) {
|
||||
$pval or return $val;
|
||||
|
||||
my @parts = split /\./, $opts->{name};
|
||||
my $name = pop @parts;
|
||||
my $dbname = shift @parts || $self->{db}->name;
|
||||
my $prefix = $self->{db}->prefix;
|
||||
$dbname =~ s,^$prefix,, if ($prefix);
|
||||
my $colname = $opts->{name}; $colname =~ s,^$dbname\.,,g;
|
||||
|
||||
my @pk = $self->{db}->pk; @pk == 1 or return;
|
||||
my $url = _reparam_url( $self->{url}, { do => 'download_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] );
|
||||
$val .= qq! <font $self->{font}><font size=1><i><a href="$url">download</a></i></font></font>!;
|
||||
|
||||
$url = _reparam_url( $self->{url}, { do => 'view_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] );
|
||||
$val .= qq! <font $self->{font}><font size=1><i><a href="$url" target=_blank>view</a></i></font></font>!;
|
||||
}
|
||||
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _reparam_url {
|
||||
# ---------------------------------------------------------------
|
||||
my $orig_url = shift;
|
||||
my $add = shift || {};
|
||||
my $remove = shift || [];
|
||||
my %params = ();
|
||||
my $new_url = $orig_url;
|
||||
|
||||
# get the original parameters
|
||||
my $qloc = index( $orig_url, '?');
|
||||
if ( $qloc > 0 ) {
|
||||
require GT::CGI;
|
||||
$new_url = substr( $orig_url, 0, $qloc );
|
||||
my $base_parms = substr( $orig_url, $qloc+1 );
|
||||
$base_parms = GT::CGI::unescape($base_parms);
|
||||
|
||||
# now parse the parameters
|
||||
foreach my $param ( grep $_, split /[&;]/, $base_parms ) {
|
||||
my $eloc = index( $param, '=' );
|
||||
$eloc < 0 and push( @{$params{$param} ||= []}, undef ), next;
|
||||
my $key = substr( $param, 0, $eloc );
|
||||
my $value = substr( $param, $eloc+1 );
|
||||
push( @{$params{$key} ||= []}, $value);
|
||||
}
|
||||
}
|
||||
|
||||
# delete a few parameters
|
||||
foreach my $param ( @$remove ) { delete $params{$param}; }
|
||||
|
||||
# add a few parameters
|
||||
foreach my $key ( keys %$add ) {
|
||||
push( @{$params{$key} ||= []}, $add->{$key});
|
||||
}
|
||||
|
||||
# put everything together
|
||||
require GT::CGI;
|
||||
my @params;
|
||||
foreach my $key ( keys %params ) {
|
||||
foreach my $value ( @{$params{$key}} ) {
|
||||
push @params, GT::CGI::escape($key).'='.GT::CGI::escape($value);
|
||||
}
|
||||
}
|
||||
$new_url .= "?" . join( '&', @params );
|
||||
return $new_url;
|
||||
}
|
||||
|
||||
sub toolbar {
|
||||
# ---------------------------------------------------------------
|
||||
# Display/calculate a "next hits" toolbar.
|
||||
#
|
||||
my $class = shift;
|
||||
my ($nh, $maxhits, $numhits, $script) = @_;
|
||||
my ($next_url, $max_page, $next_hit, $prev_hit, $left, $right, $upper, $lower, $first, $url, $last, $i);
|
||||
|
||||
# Return if there shouldn't be a speedbar.
|
||||
return unless ($numhits > $maxhits);
|
||||
|
||||
# Strip nh=\d out of the query string, as we need to append it on. Try and keep
|
||||
# the url looking nice (i.e. no double ;&, or extra ?.
|
||||
$script =~ s/[&;]nh=\d+([&;]?)/$1/;
|
||||
$script =~ s/\?nh=\d+[&;]?/\?/;
|
||||
($script =~ /\?/) or ($script .= "?");
|
||||
$script =~ s/&/&/g;
|
||||
$next_hit = $nh + 1;
|
||||
$prev_hit = $nh - 1;
|
||||
$maxhits ||= 25;
|
||||
$max_page = int ($numhits / $maxhits) + (($numhits % $maxhits) ? 1 : 0);
|
||||
|
||||
# First, set how many pages we have on the left and the right.
|
||||
$left = $nh; $right = int($numhits/$maxhits) - $nh;
|
||||
# Then work out what page number we can go above and below.
|
||||
($left > 7) ? ($lower = $left - 7) : ($lower = 1);
|
||||
($right > 7) ? ($upper = $nh + 7) : ($upper = int($numhits/$maxhits) + 1);
|
||||
# Finally, adjust those page numbers if we are near an endpoint.
|
||||
(7 - $nh >= 0) and ($upper = $upper + (8 - $nh));
|
||||
($nh > ($numhits/$maxhits - 7)) and ($lower = $lower - ($nh - int($numhits/$maxhits - 7) - 1));
|
||||
$url = "";
|
||||
# Then let's go through the pages and build the HTML.
|
||||
($nh > 1) and ($url .= qq~<a href="$script;nh=1">[<<]</a> ~);
|
||||
($nh > 1) and ($url .= qq~<a href="$script;nh=$prev_hit">[<]</a> ~);
|
||||
for ($i = 1; $i <= int($numhits/$maxhits) + 1; $i++) {
|
||||
if ($i < $lower) { $url .= " ... "; $i = ($lower-1); next; }
|
||||
if ($i > $upper) { $url .= " ... "; last; }
|
||||
($i == $nh) ?
|
||||
($url .= qq~$i ~) :
|
||||
($url .= qq~<a href="$script&nh=$i">$i</a> ~);
|
||||
if ($i * $maxhits == $numhits) { $nh == $i and $next_hit = $i; last; }
|
||||
}
|
||||
$url .= qq~<a href="$script;nh=$next_hit">[>]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
|
||||
$url .= qq~<a href="$script;nh=$max_page">[>>]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub escape {
|
||||
# ---------------------------------------------------------------
|
||||
# Public wrapper to private method.
|
||||
#
|
||||
return _escape ($_[1]);
|
||||
}
|
||||
|
||||
# ================================================================================ #
|
||||
# SEARCH WIDGETS #
|
||||
# ================================================================================ #
|
||||
|
||||
sub _mk_search_opts {
|
||||
# ---------------------------------------------------------------
|
||||
# Create the search options boxes based on type.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opts = shift or return $self->error ("BADARGS", "FATAL", "No hash ref passed to form creator _mk_search_opts");
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to form creator _mk_search_opts");
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to form creator _mk_search_opts");
|
||||
my $val = '';
|
||||
CASE: {
|
||||
exists $opts->{value} and $val = $opts->{value}, last CASE;
|
||||
exists $self->{input}->{"$name-opt"} and $val = $self->{input}->{"$name-opt"}, last CASE;
|
||||
$opts->{pk} and $val = '=', last CASE;
|
||||
$opts->{unique} and $val = '=', last CASE;
|
||||
}
|
||||
$val = '>' if $val eq '>';
|
||||
$val = '<' if $val eq '<';
|
||||
|
||||
my $type = $def->{type};
|
||||
|
||||
my ($hash, $so);
|
||||
CASE: {
|
||||
($type =~ /INT|FLOAT|DOUBLE|DECIMAL/i)
|
||||
and $hash = { 'LIKE' => 'Like', '=' => 'Exact Match', '<>' => 'Not Equal', '>' => 'Greater Than', '<' => 'Less Than'},
|
||||
$so = [ 'LIKE', '=', '<>', '>', '<' ], last CASE;
|
||||
($type =~ /CHAR/i)
|
||||
and $hash = { 'LIKE' => 'Like', '=' => 'Exact Match', '<>' => 'Not Equal', },
|
||||
$so = [ 'LIKE', '=', '<>' ], last CASE;
|
||||
($type =~ /DATE|TIME/i)
|
||||
and $hash = { '=' => 'Exact Match', '<>' => 'Not Equal', '>' => 'Greater Than', '<' => 'Less Than'},
|
||||
$so = [ '=', '>', '<', '<>' ], last CASE;
|
||||
}
|
||||
|
||||
if ($hash) {
|
||||
return $self->select( { name => "$name-opt", values => $hash, sort_order => $so, value => $val, def => $def, blank => 0 } );
|
||||
}
|
||||
else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# ================================================================================ #
|
||||
# UTILS #
|
||||
# ================================================================================ #
|
||||
|
||||
sub _escape {
|
||||
# ---------------------------------------------------------------
|
||||
# Escape HTML quotes and < and >.
|
||||
#
|
||||
my $t = shift || '';
|
||||
$$t =~ s/&/&/g;
|
||||
$$t =~ s/"/"/g;
|
||||
$$t =~ s/</</g;
|
||||
$$t =~ s/>/>/g;
|
||||
}
|
||||
|
||||
sub _get_time {
|
||||
# ---------------------------------------------------------------
|
||||
# Return current time for timestamp field.
|
||||
#
|
||||
my ($self, $col) = @_;
|
||||
my ($sec,$min,$hr,$day,$mon,$yr) = (localtime())[0..5];
|
||||
my $val;
|
||||
$mon++; $yr = $yr + 1900;
|
||||
($sec < 10) and ($sec = "0$sec"); ($min < 10) and ($min = "0$min"); ($hr < 10) and ($hr = "0$hr");
|
||||
($day < 10) and ($day = "0$day"); ($mon < 10) and ($mon = "0$mon");
|
||||
CASE: {
|
||||
($col->{type} =~ /DATETIME|TIMESTAMP/) and ($val = "$yr-$mon-$day $hr:$min:$sec"), last CASE;
|
||||
($col->{type} =~ /DATE/) and ($val = "$yr-$mon-$day"), last CASE;
|
||||
($col->{type} =~ /YEAR/) and ($val = "$yr"), last CASE;
|
||||
}
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _get_multi {
|
||||
my ($self, $opts) = @_;
|
||||
my ($names, $values) = ([], []);
|
||||
$opts->{def} ||= $self->{db}->{schema}->{cols}->{$opts->{name}};
|
||||
|
||||
# Deep copy $opts->{def} => $def
|
||||
my $def = {};
|
||||
while (my ($k, $v) = each %{$opts->{def}}) {
|
||||
if (! ref $v) {
|
||||
$def->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$def->{$k} = {};
|
||||
foreach my $k1 (keys %{$opts->{def}->{$k}}) { $def->{$k}->{$k1} = $opts->{def}->{$k}->{$k1}; }
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$def->{$k} = [];
|
||||
foreach my $v1 (@{$opts->{def}->{$k}}) { push @{$def->{$k}}, $v1; }
|
||||
}
|
||||
else { $def->{$k} = $v; }
|
||||
}
|
||||
if (
|
||||
(exists $def->{form_names}) and
|
||||
(ref ($def->{form_names}) eq 'ARRAY') and
|
||||
(@{$def->{form_names}})
|
||||
)
|
||||
{
|
||||
$names = $def->{form_names};
|
||||
}
|
||||
elsif (
|
||||
(exists $def->{values}) and
|
||||
(ref ($def->{values}) eq 'ARRAY') and
|
||||
(@{$def->{values}})
|
||||
)
|
||||
{
|
||||
$names = $def->{values};
|
||||
}
|
||||
|
||||
# Get the values.
|
||||
if (
|
||||
(exists $def->{form_values}) and
|
||||
(ref ($def->{form_values}) eq 'ARRAY') and
|
||||
(@{$def->{form_values}})
|
||||
)
|
||||
{
|
||||
$values = $def->{form_values};
|
||||
}
|
||||
elsif (
|
||||
(exists $def->{values}) and
|
||||
(ref ($def->{values}) eq 'ARRAY') and
|
||||
(@{$def->{values}})
|
||||
)
|
||||
{
|
||||
$values = $def->{values};
|
||||
}
|
||||
|
||||
# Can pass in a hash here.
|
||||
if (
|
||||
(exists $opts->{values}) and
|
||||
(ref ($opts->{values}) eq 'HASH') and
|
||||
(keys %{$opts->{values}})
|
||||
)
|
||||
{
|
||||
@{$names} = keys %{$opts->{values}};
|
||||
@{$values} = values %{$opts->{values}};
|
||||
}
|
||||
|
||||
@{$names} or @{$names} = @{$values};
|
||||
@{$values} or @{$values} = @{$names};
|
||||
|
||||
return ($names, $values);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# Options for display forms/views:
|
||||
# hide_timestamp => 1 # Do not display timestamp fields
|
||||
# search_opts => 1 # Add search options boxes.
|
||||
# multiple => 1 # Prepend $multiple- to column names.
|
||||
# defaults => 1 # Use .def defaults.
|
||||
# values => {} # hash ref of values to use (overrides input)
|
||||
# table => 'string' # table properties, defaults to 0 border.
|
||||
# tr => 'string' # table row properties, defaults to none.
|
||||
# td => 'string' # table cell properties, defaults to just aligns.
|
||||
# extra_table => 0 # disable wrap form in extra table for looks.
|
||||
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
||||
# val_font => 'string' # font to use for values, defaults to $FONT.
|
||||
# hide => [] # display fields as hidden tags.
|
||||
# view => [] # display fields as html with hidden tags as well.
|
||||
# skip => [] # don't display array of column names.
|
||||
278
site/glist/lib/GT/SQL/Display/HTML/Relation.pm
Normal file
278
site/glist/lib/GT/SQL/Display/HTML/Relation.pm
Normal file
@@ -0,0 +1,278 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: Relation.pm,v 1.18 2004/08/28 03:53:45 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML::Relation;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS/;
|
||||
use GT::SQL::Display::HTML;
|
||||
|
||||
@ISA = qw/GT::SQL::Display::HTML/;
|
||||
$FONT = 'face="Tahoma,Arial,Helvetica" size=2';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
$ATTRIBS = {
|
||||
db => undef,
|
||||
input => undef,
|
||||
code => {},
|
||||
mode => '',
|
||||
font => $FONT,
|
||||
hide_timestamp => 0,
|
||||
view_key => 0,
|
||||
defaults => 0,
|
||||
search_opts => 0,
|
||||
values => {},
|
||||
multiple => 0,
|
||||
table => 'border=0 width=500',
|
||||
tr => '',
|
||||
td => 'valign=top align=left',
|
||||
extra_table => 1,
|
||||
col_font => $FONT,
|
||||
val_font => $FONT,
|
||||
hide => [],
|
||||
skip => [],
|
||||
view => [],
|
||||
disp_form => 1,
|
||||
disp_html => 0,
|
||||
file_field => 0,
|
||||
file_delete => 0,
|
||||
file_use_path => 0,
|
||||
};
|
||||
|
||||
sub display {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opts = shift;
|
||||
$self->reset_opts;
|
||||
$opts->{disp_form} = 0;
|
||||
$opts->{disp_html} = 1;
|
||||
return $self->_display ($opts || ());
|
||||
}
|
||||
|
||||
sub _display {
|
||||
# ---------------------------------------------------------------
|
||||
# Handles displaying of a form or a record.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash and primary key
|
||||
$self->{pk} = [$self->{db}->pk] unless $self->{pk};
|
||||
$self->{cols} = $self->{db}->ordered_columns;
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}}) if ($self->{pk});
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @ntables = values %{$self->{db}->{tables}};
|
||||
my (@tmp, @tables);
|
||||
for my $t (@ntables) {
|
||||
my @cols = $t->ordered_columns;
|
||||
my %fk = $t->fk;
|
||||
my %cols = $t->cols;
|
||||
my $name = $t->name;
|
||||
my $found = 0;
|
||||
COL: foreach my $col_name (@cols) {
|
||||
if (exists $self->{values}->{$col_name}) {
|
||||
$self->{values}->{$name . '.' . $col_name} = delete $self->{values}->{$col_name};
|
||||
}
|
||||
$self->{cols}->{$name . '.' . $col_name} = $cols{$col_name};
|
||||
FK: for (keys %fk) {
|
||||
if (exists $self->{db}->{tables}->{$_}) {
|
||||
if (exists $fk{$_}->{$col_name}) {
|
||||
$found = 1;
|
||||
last FK;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
$found ? (push (@tmp, $t)) : (@tables = ($t));
|
||||
}
|
||||
push @tables, @tmp;
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Set the table widths depending on if we need a third column.
|
||||
my ($cwidth, $vwidth) = ('30%', '70%');
|
||||
if ($self->{search_opts}) { $cwidth = "30%"; $vwidth = "60%" }
|
||||
|
||||
for my $table (@tables) {
|
||||
$out .= $self->mk_table (
|
||||
table => $table,
|
||||
values => $values,
|
||||
cwidth => $cwidth,
|
||||
vwidth => $vwidth
|
||||
);
|
||||
}
|
||||
$out .= '<br>';
|
||||
|
||||
foreach (@{$self->{hide}}) {
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$_" : $_;
|
||||
my $val = $values->{$_};
|
||||
if (exists $self->{cols}->{$_}->{time_check} and $self->{cols}->{$_}->{time_check}) {
|
||||
$val ||= $self->_get_time ($self->{cols}->{$_});
|
||||
}
|
||||
defined $val or ($val = '');
|
||||
GT::SQL::Display::HTML::_escape(\$val);
|
||||
$out .= qq~<input type="hidden" name="$field_name" value="$val">~;
|
||||
}
|
||||
$self->{extra_table} and ($out .= "</td></tr></table>\n");
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub mk_table {
|
||||
my $self = shift;
|
||||
my %opt = @_;
|
||||
|
||||
my $out = '';
|
||||
$self->{extra_table} and ($out .= "<p><table border=1 cellpadding=0 cellspacing=0><tr><td>");
|
||||
my $cols = $opt{table}->cols;
|
||||
my $name = $opt{table}->name;
|
||||
|
||||
$out .= qq(
|
||||
<table $self->{table}>
|
||||
<tr><td colspan=3 bgcolor=navy>
|
||||
<FONT FACE="MS Sans Serif, arial,helvetica" size=1 COLOR="#FFFFFF">$name</font>
|
||||
</td></tr>
|
||||
);
|
||||
my @cols = $opt{table}->ordered_columns;
|
||||
my %fk = $opt{table}->fk;
|
||||
|
||||
COL: foreach my $col_name (@cols) {
|
||||
$out .= $self->mk_row (%opt, col_name => $col_name, fk => \%fk);
|
||||
}
|
||||
$out .= "</table>\n";
|
||||
$out .= "</table></p>\n" if $self->{extra_table};
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub mk_row {
|
||||
my $self = shift;
|
||||
my %opt = @_;
|
||||
my $out = '';
|
||||
for (keys %{$opt{fk}}) {
|
||||
if (exists $self->{db}->{tables}->{$_}) {
|
||||
(exists $opt{fk}->{$_}->{$opt{col_name}}) and return '';
|
||||
}
|
||||
}
|
||||
my $col = $opt{table}->name . '.' . $opt{col_name};
|
||||
|
||||
# Run any code refs that have been setup.
|
||||
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $opt{values});
|
||||
return '';
|
||||
}
|
||||
return '' if $self->_skip ($col);
|
||||
|
||||
# Set the form name (using increment for multiple if requested) and also the display name.
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
|
||||
my $display_name = exists ($self->{cols}->{$col}->{form_display}) ? $self->{cols}->{$col}->{form_display} : $col;
|
||||
my $value = $opt{values}->{$col};
|
||||
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
|
||||
|
||||
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and return '';
|
||||
$out .= "<tr $self->{tr}><td $self->{td} width='$opt{cwidth}'><font $self->{col_font}>$display_name</font></td><td $self->{td} width='$opt{vwidth}'><font $self->{val_font}>";
|
||||
|
||||
# Get the column display subroutine
|
||||
$out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value }, $opt{values}, $self );
|
||||
|
||||
$out .= "</font></td>";
|
||||
|
||||
# Display any search options if requested.
|
||||
if ($self->{search_opts}) {
|
||||
my $is_pk = 0;
|
||||
for (@{$self->{pk}}) {
|
||||
$is_pk = 1, last if ($_ eq $col);
|
||||
}
|
||||
|
||||
$out .= qq~<td $self->{td} width="10%"><font $self->{val_font}>~;
|
||||
$out .= $self->_mk_search_opts({
|
||||
name => $field_name,
|
||||
def => $self->{cols}->{$col},
|
||||
pk => $is_pk
|
||||
}) || ' ';
|
||||
$out .= "</font></td>";
|
||||
}
|
||||
$out .= "\n";
|
||||
return $out;
|
||||
|
||||
}
|
||||
|
||||
sub _get_defaults {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns default values for fields. Bases it on what's passed in,
|
||||
# cgi input, def file defaults, otherwise blank.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my @ntables = values %{$self->{db}->{tables}};
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
my $c = $self->{cols};
|
||||
my $values = {};
|
||||
foreach my $col (@cols) {
|
||||
my $value = '';
|
||||
if (exists $self->{values}->{$col}) { $value = $self->{values}->{$col} }
|
||||
elsif (exists $self->{input}->{$col}) { $value = $self->{input}->{$col} }
|
||||
elsif ($self->{defaults} and exists $c->{$col}->{default}) {
|
||||
if ($c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
(defined $c->{$col}->{default} and $c->{$col}->{default} =~ /0000/)
|
||||
? ($value = $self->_get_time($c->{$col}))
|
||||
: ($value = $c->{$col}->{default});
|
||||
}
|
||||
else {
|
||||
$value = $c->{$col}->{default};
|
||||
}
|
||||
}
|
||||
elsif ($self->{defaults} and $c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
$value = $self->_get_time($c->{$col});
|
||||
}
|
||||
$values->{$col} = $value;
|
||||
}
|
||||
return $values;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
# Options for display forms/views:
|
||||
# hide_timestamp => 1 # Do not display timestamp fields.
|
||||
# search_opts => 1 # Add search options boxes.
|
||||
# multiple => 1 # Prepend $multiple- to column names.
|
||||
# defaults => 1 # Use .def defaults.
|
||||
# values => {} # hash ref of values to use (overrides input)
|
||||
# table => 'string' # table properties, defaults to 0 border.
|
||||
# tr => 'string' # table row properties, defaults to none.
|
||||
# td => 'string' # table cell properties, defaults to just aligns.
|
||||
# extra_table => 0 # disable wrap form in extra table for looks.
|
||||
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
||||
# val_font => 'string' # font to use for values, defaults to $FONT.
|
||||
# hide => [] # display fields as hidden tags.
|
||||
# view => [] # display fields as html with hidden tags as well.
|
||||
# skip => [] # don't display array of column names.
|
||||
|
||||
=cut
|
||||
289
site/glist/lib/GT/SQL/Display/HTML/Table.pm
Normal file
289
site/glist/lib/GT/SQL/Display/HTML/Table.pm
Normal file
@@ -0,0 +1,289 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: Table.pm,v 1.26 2004/10/01 21:52:12 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML::Table;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS/;
|
||||
use GT::SQL::Display::HTML;
|
||||
|
||||
@ISA = qw/GT::SQL::Display::HTML/;
|
||||
$FONT = 'face="Tahoma,Arial,Helvetica" size=2';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
$ATTRIBS = {
|
||||
db => undef,
|
||||
input => undef,
|
||||
code => {},
|
||||
font => $FONT,
|
||||
hide_timestamp => 0,
|
||||
view_key => 0,
|
||||
defaults => 0,
|
||||
search_opts => 0,
|
||||
values => {},
|
||||
multiple => 0,
|
||||
table => 'border=0 width=500',
|
||||
tr => '',
|
||||
mode => '',
|
||||
td => 'valign=top align=left',
|
||||
extra_table => 1,
|
||||
col_font => $FONT,
|
||||
val_font => $FONT,
|
||||
hide => [],
|
||||
skip => [],
|
||||
view => [],
|
||||
disp_form => 1,
|
||||
disp_html => 0,
|
||||
file_field => 0,
|
||||
file_delete => 0,
|
||||
file_use_path => 0
|
||||
};
|
||||
|
||||
|
||||
sub display_row {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record row as html.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{disp_form} = 0;
|
||||
$opts->{disp_html} = 1;
|
||||
return $self->_display_row ($opts || ());
|
||||
}
|
||||
|
||||
sub display_row_cols {
|
||||
# ---------------------------------------------------------------
|
||||
# returns the <td></td> for each of the title names for columns
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash and primary key
|
||||
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
|
||||
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
my $script = GT::CGI->url();
|
||||
$script =~ s/[\&;]?sb=([^&;]*)//g;
|
||||
my $sb = $1;
|
||||
$script =~ s/[\&;]?so=(ASC|DESC)//g;
|
||||
my $so = $1;
|
||||
|
||||
foreach my $col (@cols) {
|
||||
$out .= qq!\n\t<td><font $self->{col_font}><b>!;
|
||||
$out .= qq!<a href="$script&sb=$col&so=! . ( ( ( $col eq $sb ) and $so eq 'ASC' ) ? 'DESC' : 'ASC' ) . qq!">!;
|
||||
$out .= exists $self->{db}->{schema}->{cols}->{$col}->{form_display} ? $self->{db}->{schema}->{cols}->{$col}->{form_display} : $col;
|
||||
$out .= ( ( $col eq $sb ) ? ( ($so eq 'ASC') ? " ^" : " v" ) : '' ) . "</a>";
|
||||
$out .= qq!</b></font></td>\n!;
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub _display_row {
|
||||
# ---------------------------------------------------------------
|
||||
# Handles displaying of a form or a record.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash and primary key
|
||||
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
|
||||
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
foreach my $col (@cols) {
|
||||
|
||||
# Run any code refs that have been setup.
|
||||
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values);
|
||||
next;
|
||||
}
|
||||
next if $self->_skip ($col);
|
||||
|
||||
# Set the form name (using increment for multiple if requested) and also the display name.
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
|
||||
my $display_name = exists $self->{cols}->{$col}->{form_display} ? $self->{cols}->{$col}->{form_display} : $col;
|
||||
my $value = $values->{$col};
|
||||
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
|
||||
|
||||
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and next;
|
||||
|
||||
$out .= qq!\n\t<td valign=texttop><font $self->{col_font}>!;
|
||||
|
||||
# Get the column display subroutine
|
||||
$out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value });
|
||||
|
||||
$out .= qq!</font></td>\n!;
|
||||
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub display {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as html.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{disp_form} = 0;
|
||||
$opts->{disp_html} = 1;
|
||||
return $self->_display ($opts || ());
|
||||
}
|
||||
|
||||
sub _display {
|
||||
# ---------------------------------------------------------------
|
||||
# Handles displaying of a form or a record.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash, primary keys, and unique columns
|
||||
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
|
||||
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
|
||||
|
||||
# Opening table.
|
||||
$self->{extra_table} and ($out .= "<table border=1 cellpadding=0 cellspacing=0><tr><td>");
|
||||
$out .= "<table $self->{table}>";
|
||||
|
||||
# Set the table widths depending on if we need a third column.
|
||||
my ($cwidth, $vwidth);
|
||||
if ($self->{search_opts}) { $cwidth = "30%"; $vwidth = "60%" }
|
||||
else { $cwidth = "30%"; $vwidth = "70%" }
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
foreach my $col (@cols) {
|
||||
|
||||
# Run any code refs that have been setup.
|
||||
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values);
|
||||
next;
|
||||
}
|
||||
next if $self->_skip ($col);
|
||||
|
||||
# Set the form name (using increment for multiple if requested) and also the display name.
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
|
||||
my $display_name = (exists $self->{cols}->{$col}->{form_display} and length $self->{cols}->{$col}->{form_display})
|
||||
? $self->{cols}->{$col}->{form_display} : $col;
|
||||
my $value = $values->{$col};
|
||||
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
|
||||
|
||||
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and next;
|
||||
$out .= "<tr $self->{tr}><td $self->{td} width='$cwidth'><font $self->{col_font}>$display_name</font></td><td $self->{td} width='$vwidth'><font $self->{val_font}>";
|
||||
|
||||
# Get the column display subroutine
|
||||
my $o = $self->$disp(
|
||||
{
|
||||
name => (defined $field_name ? $field_name : ''),
|
||||
def => $self->{cols}->{$col},
|
||||
value => (defined $value ? $value : '')
|
||||
},
|
||||
($values || {}),
|
||||
$self
|
||||
);
|
||||
$out .= $o if defined $o;
|
||||
$out .= "</font></td>";
|
||||
|
||||
# Display any search options if requested.
|
||||
if ($self->{search_opts}) {
|
||||
$out .= qq~<td $self->{td} width="10%"><font $self->{val_font}>~;
|
||||
$out .= $self->_mk_search_opts({
|
||||
name => $field_name,
|
||||
def => $self->{cols}->{$col},
|
||||
pk => $self->{db}->_is_pk($col),
|
||||
unique => $self->{db}->_is_unique($col)
|
||||
}) || ' ';
|
||||
$out .= "</font></td>";
|
||||
}
|
||||
$out .= "\n";
|
||||
}
|
||||
$out .= "</table>\n";
|
||||
|
||||
my %seen;
|
||||
foreach (@{$self->{hide}}) {
|
||||
next if $seen{$_}++;
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$_" : $_;
|
||||
my $val = $values->{$_};
|
||||
if (exists $self->{cols}->{$_}->{time_check} and $self->{cols}->{$_}->{time_check}) {
|
||||
$val ||= $self->_get_time ($self->{cols}->{$_});
|
||||
}
|
||||
defined $val or ($val = '');
|
||||
GT::SQL::Display::HTML::_escape(\$val);
|
||||
$out .= qq~<input type="hidden" name="$field_name" value="$val">~;
|
||||
}
|
||||
$self->{extra_table} and ($out .= "</td></tr></table>\n");
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
# Options for display forms/views:
|
||||
# hide_timestamp => 1 # Do not display timestamp fields.
|
||||
# search_opts => 1 # Add search options boxes.
|
||||
# multiple => 1 # Prepend $multiple- to column names.
|
||||
# defaults => 1 # Use .def defaults.
|
||||
# values => {} # hash ref of values to use (overrides input)
|
||||
# table => 'string' # table properties, defaults to 0 border.
|
||||
# tr => 'string' # table row properties, defaults to none.
|
||||
# td => 'string' # table cell properties, defaults to just aligns.
|
||||
# extra_table => 0 # disable wrap form in extra table for looks.
|
||||
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
||||
# val_font => 'string' # font to use for values, defaults to $FONT.
|
||||
# hide => [] # display fields as hidden tags.
|
||||
# view => [] # display fields as html with hidden tags as well.
|
||||
# skip => [] # don't display array of column names.
|
||||
|
||||
=cut
|
||||
897
site/glist/lib/GT/SQL/Driver.pm
Normal file
897
site/glist/lib/GT/SQL/Driver.pm
Normal file
@@ -0,0 +1,897 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver
|
||||
# CVS Info :
|
||||
# $Id: Driver.pm,v 2.5 2005/02/25 03:37:29 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Overview: This implements a driver class.
|
||||
#
|
||||
|
||||
package GT::SQL::Driver;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use GT::SQL::Table;
|
||||
use GT::AutoLoader;
|
||||
use GT::SQL::Driver::Types;
|
||||
use GT::SQL::Driver::debug;
|
||||
use Exporter();
|
||||
require GT::SQL::Driver::sth;
|
||||
use vars qw/%CONN @ISA $DEBUG $VERSION $ERROR_MESSAGE $ATTRIBS %QUERY_MAP/;
|
||||
|
||||
use constant PROTOCOL => 2;
|
||||
|
||||
$ATTRIBS = {
|
||||
name => '',
|
||||
schema => '',
|
||||
dbh => '',
|
||||
connect => {}
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 2.5 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::debug/;
|
||||
|
||||
%QUERY_MAP = (
|
||||
# QUERY => METHOD (will be prefixed with '_prepare_' or '_execute_')
|
||||
CREATE => 'create',
|
||||
INSERT => 'insert',
|
||||
ALTER => 'alter',
|
||||
SELECT => 'select',
|
||||
UPDATE => 'update',
|
||||
DROP => 'drop',
|
||||
DELETE => 'delete',
|
||||
DESCRIBE => 'describe',
|
||||
'SHOW TABLES' => 'show_tables',
|
||||
'SHOW INDEX' => 'show_index'
|
||||
);
|
||||
|
||||
$DBI::errstr if 0;
|
||||
|
||||
sub load_driver {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Loads a sub-driver (i.e. GT::SQL::Driver::MYSQL, GT::SQL::Driver::PG, etc.),
|
||||
# and creates and returns a new driver object. The first argument should be
|
||||
# the name of the driver (e.g. 'PG'), and the remaining arguments are passed to
|
||||
# new() - which could well be handled by the driver.
|
||||
#
|
||||
my ($class, $driver, @opts) = @_;
|
||||
|
||||
# Old GT::SQL versions had an 'ODBC' driver that wasn't an ODBC driver, but an
|
||||
# MSSQL driver that used ODBC.
|
||||
$driver = 'MSSQL' if $driver eq 'ODBC';
|
||||
|
||||
my $pkg = "GT::SQL::Driver::$driver";
|
||||
my $lib_path = $INC{'GT/SQL/Driver.pm'};
|
||||
$lib_path =~ s|GT/SQL/Driver\.pm$||;
|
||||
{
|
||||
# Ensure that the driver is loaded from the same location as GT/SQL/Driver.pm
|
||||
local @INC = ($lib_path, @INC);
|
||||
require "GT/SQL/Driver/$driver.pm";
|
||||
}
|
||||
|
||||
my $protocol = $pkg->protocol_version;
|
||||
return $class->fatal(DRIVERPROTOCOL => PROTOCOL, $protocol) if $protocol != PROTOCOL;
|
||||
|
||||
return $pkg->new(@opts);
|
||||
}
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Generic new() method for drivers to inherit; load_driver() should be used
|
||||
# instead to get a driver object.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {}, $class;
|
||||
my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => "$class->new(HASH REF or HASH); invalid parameter: '@_'");
|
||||
|
||||
# Otherwise we need to make sure we have a schema.
|
||||
$opts->{schema} and ref $opts->{schema} or return $self->fatal(BADARGS => "$class->new(HASH REF or HASH); must specify schema and name");
|
||||
|
||||
$self->{name} = $opts->{name};
|
||||
$self->{schema} = $opts->{schema};
|
||||
$self->{connect} = $opts->{connect};
|
||||
$self->{_debug} = $opts->{debug} || $DEBUG;
|
||||
$self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL';
|
||||
$self->{dbh} = undef;
|
||||
$self->{hints} = { $self->hints };
|
||||
$self->debug("New driver object loaded from table: $self->{name}.") if ($self->{_debug} > 2);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# This method is designed to be subclassed to provide "hints" for simple, small
|
||||
# differences between drivers, which simplifies the code over using a subclass.
|
||||
# It returns a hash of hints, with values of "1" unless otherwise indicated.
|
||||
# Currently supported hints are:
|
||||
# case_map # Corrects ->fetchrow_hashref column case when the database doesn't
|
||||
# prefix_indexes # Indexes will be prefixed with the table name (including the table's prefix)
|
||||
# fix_index_dbprefix # Look for erroneous (db_prefix)(index) when dropping indexes
|
||||
# now # Specifies an SQL value to use instead of NOW() (for 'time_check' columns, among other things)
|
||||
# bind # An array ref of: [\%BIND_HASH, ('COLUMNTYPE' => $bind_type, 'TYPE2' => $bind_type2, ...)] for drivers that need special placeholder binding for certain column types
|
||||
# ai # Contains a string to use for an AI column; or a code reference that is passed ($table, $column) and returns the string, or an array reference of queries to run to create the ai sequence after the column/table has been created
|
||||
# drop_pk_constraint # use ALTER TABLE ... DROP CONSTRAINT pkeyname to drop a primary key
|
||||
sub hints { () }
|
||||
# Removing the () breaks under 5.00404, as it will return @_ in list context
|
||||
|
||||
$COMPILE{protocol_version} = __LINE__ . <<'END_OF_SUB';
|
||||
sub protocol_version {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This checks the GT::SQL::Driver protocol, and dies if the versions aren't
|
||||
# equal. The protocol version only changes for major driver changes such as
|
||||
# the v2.000 version of this module, which had the drivers do their own queries
|
||||
# (as opposed to the previous hack of having drivers trying to return alternate
|
||||
# versions of MySQL's queries). All protocol v2 and above drivers are required
|
||||
# to override this - any driver that does not is, by definition, a protocol v1
|
||||
# driver.
|
||||
#
|
||||
# The current protocol version is defined by the PROTOCOL constant - but
|
||||
# drivers that haven't overridden protocol_version() are, by definition, v1.
|
||||
#
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub available_drivers {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a list of available GT::SQL::Driver::* drivers
|
||||
#
|
||||
my $driver_path = $INC{'GT/SQL/Driver.pm'};
|
||||
$driver_path =~ s/\.pm$//;
|
||||
my $dh = \do { local *DH; *DH };
|
||||
my @drivers;
|
||||
opendir $dh, $driver_path or return ();
|
||||
while (defined(my $driver = readdir $dh)) {
|
||||
# By convention, only all-uppercase modules are accepted as GT::SQL drivers
|
||||
next unless $driver =~ /^([A-Z_][A-Z0-9_]*)\.pm$/;
|
||||
push @drivers, $1;
|
||||
}
|
||||
@drivers;
|
||||
}
|
||||
|
||||
sub connect {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the current database handle.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{dbh} and return $self->{dbh};
|
||||
|
||||
eval { require DBI };
|
||||
if ($@) {
|
||||
return $self->warn(CANTCONNECT => "DBI module not installed. You must install the perl database module DBI from: http://www.perl.com/CPAN/modules/by-module/DBI");
|
||||
}
|
||||
|
||||
# Make sure we have a database, otherwise probably an error.
|
||||
exists $self->{connect}->{database} or return $self->fatal(CANTCONNECT => "No connection string passed to tbl->connect, make sure your table object got a connection hash.");
|
||||
keys %{$self->{schema}} or return $self->fatal(CANTCONNECT => "Unable to connect to database without a valid schema.");
|
||||
|
||||
my $dsn = $self->dsn($self->{connect});
|
||||
my $conn_key = "$dsn\0$self->{connect}->{login}\0$self->{connect}->{password}";
|
||||
if (defined $CONN{$conn_key}) {
|
||||
$self->{dbh} = $CONN{$conn_key};
|
||||
$self->debug("Using stored connection: $dsn") if ($self->{_debug} > 1);
|
||||
return $CONN{$conn_key};
|
||||
}
|
||||
|
||||
# Connect to the database.
|
||||
$self->debug("Connecting to database with: '$dsn', '$self->{connect}->{login}', '******'") if ($self->{_debug} > 1);
|
||||
my $res = eval {
|
||||
$CONN{$conn_key} = DBI->connect($dsn, $self->{connect}->{login}, $self->{connect}->{password}, { RaiseError => $self->{connect}->{RaiseError}, PrintError => $self->{connect}->{PrintError}, AutoCommit => 1 })
|
||||
or die "$DBI::errstr\n";
|
||||
1;
|
||||
};
|
||||
$res or return $self->warn(CANTCONNECT => "$@");
|
||||
|
||||
$self->{dbh} = $CONN{$conn_key};
|
||||
$self->debug("Connected successfully to database.") if $self->{_debug} > 1;
|
||||
|
||||
return $self->{dbh};
|
||||
}
|
||||
|
||||
$COMPILE{dsn} = __LINE__ . <<'END_OF_SUB';
|
||||
sub dsn {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the data source name used by DBI to connect to the database.
|
||||
# Since this is database-dependant, this is just a stub.
|
||||
#
|
||||
require Carp;
|
||||
Carp::croak("Driver has no dsn()");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{prepare_raw} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prepare_raw {
|
||||
# ---------------------------------------------------------------
|
||||
# Returns a raw sth object.
|
||||
# WARNING: MAKE SURE YOUR SQL IS PORTABLE AS NO ALTERATIONS WILL
|
||||
# BE MADE! ALSO YOU MUST MANUALLY CALL ->finish ON THESE!
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
$self->debug("Preparing RAW query: $query") if $self->{_debug} > 1;
|
||||
my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query);
|
||||
$self->debug("RAW STH is prepared: $query") if $self->{_debug} > 1;
|
||||
return $sth;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{prepare} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prepare {
|
||||
# ---------------------------------------------------------------
|
||||
# We can override whatever type of queries we need to alter by replacing
|
||||
# the _prepare_* functions.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if (! defined $query) {
|
||||
return $self->warn(CANTPREPARE => "", "Empty Query");
|
||||
}
|
||||
|
||||
# For any drivers that need hacked-in limit support (currently MS SQL and Oracle):
|
||||
delete @$self{qw/_limit _lim_offset _lim_rows/};
|
||||
|
||||
if (my $now = $self->{hints}->{now}) {
|
||||
$query =~ s/\bNOW\(\)/$now/g;
|
||||
}
|
||||
|
||||
if ($query =~ /^\s*SHOW\s+TABLES\s*(?:;\s*)?$/i) {
|
||||
$self->{do} = 'SHOW TABLES';
|
||||
}
|
||||
elsif ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+\w+\s*(?:;\s*)?$/i) {
|
||||
# See 'Driver-specific notes' below
|
||||
$self->{do} = 'SHOW INDEX';
|
||||
}
|
||||
else {
|
||||
$self->{do} = uc +($query =~ /(\w+)/)[0];
|
||||
}
|
||||
if (my $meth = $QUERY_MAP{$self->{do}}) {
|
||||
$meth = "_prepare_$meth";
|
||||
$query = $self->$meth($query) or return;
|
||||
}
|
||||
|
||||
$self->{query} = $query;
|
||||
$self->debug("Preparing query: $query") if $self->{_debug} > 1;
|
||||
|
||||
$self->{sth} = $self->{dbh}->prepare($query)
|
||||
or return $self->warn(CANTPREPARE => $query, $DBI::errstr);
|
||||
|
||||
my $pkg = ref($self) . '::sth';
|
||||
$self->debug("CREATING $pkg OBJECT") if $self->{_debug} > 2;
|
||||
return $pkg->new($self);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Define one generic prepare, and alias all the specific _prepare_* functions to it
|
||||
sub _generic_prepare { $_[1] }
|
||||
for (*_prepare_create, *_prepare_insert, *_prepare_alter, *_prepare_select, *_prepare_update, *_prepare_drop, *_prepare_delete, *_prepare_describe) {
|
||||
$_ = \&_generic_prepare;
|
||||
}
|
||||
# Driver-specific notes:
|
||||
# 'SHOW TABLES'
|
||||
# The driver should return single-column rows of non-system tables in the
|
||||
# database. The name of the column is not important, and users of SHOW TABLE
|
||||
# should not depend on it (i.e. do not use ->fetchrow_hashref)
|
||||
*_prepare_show_tables = \&_generic_prepare;
|
||||
# 'SHOW INDEX FROM table'
|
||||
# Drivers should return one row per column per index, having at least the keys:
|
||||
# - index_name: the name of the index
|
||||
# - index_column: the name of the column
|
||||
# - index_unique: 1 if the index is unique, 0 otherwise
|
||||
# - index_primary: 1 if the column is a primary key, 0 otherwise
|
||||
#
|
||||
# The rows must be grouped by index, and ordered by the position of the column
|
||||
# within said groupings.
|
||||
#
|
||||
# So, for a unique index named 'unique1' on columns 'col1', 'col2', 'col3', and
|
||||
# a normal index named 'index1' on 'col3', 'col4', and a primary key on
|
||||
# 'colpk', you should get (at a minimum; extra columns are permitted):
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | index_name | index_column | index_unique | index_primary |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | unique1 | col1 | 1 | 0 |
|
||||
# | unique1 | col2 | 1 | 0 |
|
||||
# | unique1 | col3 | 1 | 0 |
|
||||
# | index1 | col3 | 0 | 0 |
|
||||
# | index1 | col4 | 0 | 0 |
|
||||
# | PRIMARY | colpk | 1 | 1 |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# 'PRIMARY' above should be changed by drivers whose databases have named
|
||||
# primary keys, otherwise using 'PRIMARY' for the primary key is recommended.
|
||||
#
|
||||
# Any other information may be returned; users of this query mapping should
|
||||
# always use ->fetchrow_hashref, and access the above four keys for
|
||||
# portability.
|
||||
#
|
||||
# Note that index_primary results may overlap other indexes for some databases
|
||||
# - Oracle, in particular, will bind a primary key onto an existing index if
|
||||
# possible. In such a case, you'll get the index indicated normally, but some
|
||||
# of the columns may make up the primary key. For example, the following
|
||||
# result would indicate that there is one index on col1, col2, col3, and that
|
||||
# there is a primary key made up of (col1, col2):
|
||||
#
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | index_name | index_column | index_unique | index_primary |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | index1 | col1 | 0 | 1 |
|
||||
# | index1 | col2 | 0 | 1 |
|
||||
# | index1 | col3 | 0 | 0 |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
#
|
||||
# Currently, results such as the above are known to occur in Oracle databases
|
||||
# where a primary key was added to an already-indexed column after creating the
|
||||
# table - other databases give primary keys an independant index.
|
||||
#
|
||||
# Although _prepare_show_index is defined here, no drivers actually satisfy the
|
||||
# above without some query result remapping, and as such all currently override
|
||||
# either this or _execute_show_index.
|
||||
*_prepare_show_index = \&_generic_prepare;
|
||||
|
||||
$COMPILE{extract_index_name} = __LINE__ . <<'END_OF_SUB';
|
||||
sub extract_index_name {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes an table name and database index name (which could be prefixed, if the
|
||||
# database uses prefixes) and returns the GT::SQL index name (i.e. without
|
||||
# prefix).
|
||||
my ($self, $table, $index) = @_;
|
||||
if ($self->{hints}->{prefix_indexes}) {
|
||||
$index =~ s/^\Q$table\E(?=.)//i;
|
||||
}
|
||||
$index;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub disconnect {
|
||||
# -------------------------------------------------------------------
|
||||
# Disconnect from the database.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{dbh} and $self->{dbh}->disconnect;
|
||||
}
|
||||
|
||||
sub reset_env {
|
||||
# -------------------------------------------------------------------
|
||||
# Remove all database connections that aren't still alive
|
||||
#
|
||||
@GT::SQL::Driver::debug::QUERY_STACK = ();
|
||||
for my $dsn (keys %CONN) {
|
||||
next if ($CONN{$dsn} and $CONN{$dsn}->ping);
|
||||
$CONN{$dsn}->disconnect if ($CONN{$dsn});
|
||||
delete $CONN{$dsn};
|
||||
}
|
||||
}
|
||||
|
||||
sub do {
|
||||
# -------------------------------------------------------------------
|
||||
# Do a query.
|
||||
#
|
||||
my $self = shift;
|
||||
($self->prepare(@_) or return)->execute;
|
||||
}
|
||||
|
||||
$COMPILE{do_raw_transaction} = __LINE__ . <<'END_OF_SUB';
|
||||
sub do_raw_transaction {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Do a series of queries as a single transaction - note that this is only
|
||||
# supported under DBI >= 1.20; older versions of DBI result in the queries
|
||||
# being performed without a transaction.
|
||||
# This subroutine should be passed a list of queries; the queries will be run
|
||||
# in order. Each query may optionally be an array reference where the first
|
||||
# element is the query, and remaining elements are placeholders to use when
|
||||
# executing the query. Furthermore, you may pass a reference to the string
|
||||
# or array reference to specify a non-critical query.
|
||||
#
|
||||
# For example:
|
||||
# $self->do_raw_transaction(
|
||||
# "QUERY1",
|
||||
# \["QUERY2 ?", $value],
|
||||
# \"QUERY3",
|
||||
# ["QUERY4 ?, ?", $value1, $value2]
|
||||
# );
|
||||
#
|
||||
# This will attempt to run the 4 queries, and will abort if query 1 or 4 do not
|
||||
# succeed.
|
||||
#
|
||||
# Also note that this is ONLY meant to be used by individual drivers as it
|
||||
# assumes the queries passed in are ready to run without any rewriting. As
|
||||
# such, any use outside of individual drivers should be considered an error.
|
||||
#
|
||||
# Returns '1' on success, undef on failure of any query (excepting non-critical
|
||||
# queries, see above).
|
||||
#
|
||||
my ($self, @queries) = @_;
|
||||
|
||||
my $transaction = $DBI::VERSION >= 1.20;
|
||||
$self->{dbh}->begin_work if $transaction;
|
||||
|
||||
$self->debug("Begin query transaction") if $self->{_debug};
|
||||
$self->debug("Transaction not possible; DBI version < 1.20") if $self->{_debug} and not $transaction;
|
||||
|
||||
my $time;
|
||||
$time = Time::HiRes::time() if $self->{_debug} and exists $INC{"Time/HiRes.pm"};
|
||||
for (@queries) {
|
||||
my $critical = not(ref eq 'SCALAR' or ref eq 'REF');
|
||||
my $q = $critical ? $_ : $$_;
|
||||
my ($query, @ph) = ref $q ? @$q : $q;
|
||||
if ($self->{_debug}) {
|
||||
my $debugquery = GT::SQL::Driver::debug->replace_placeholders($query, @ph);
|
||||
$self->debug("Executing query $debugquery");
|
||||
}
|
||||
my $did = $self->{dbh}->do($query, undef, @ph);
|
||||
if (!$did and $critical) {
|
||||
$self->warn(CANTEXECUTE => $query => $DBI::errstr);
|
||||
$self->debug("Critical query failed, transaction aborted; performing transaction rollback")
|
||||
if $self->{_debug} and $transaction;
|
||||
$self->{dbh}->rollback if $transaction;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
$self->debug("Transaction complete; committing") if $self->{_debug};
|
||||
$self->{dbh}->commit if $transaction;
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Transaction execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub quote {
|
||||
# -----------------------------------------------------------
|
||||
# This subroutines quotes (or not) a value.
|
||||
#
|
||||
my $val = pop;
|
||||
return 'NULL' if not defined $val;
|
||||
return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE';
|
||||
(values %CONN)[0]->quote($val);
|
||||
}
|
||||
|
||||
$COMPILE{create_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates a table.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->connect or return;
|
||||
|
||||
my $table = $self->{name};
|
||||
|
||||
# Figure out the order of the create, and then build the create statement.
|
||||
my %pos = map { $_ => $self->{schema}->{cols}->{$_}->{pos} } keys %{$self->{schema}->{cols}};
|
||||
my (@field_defs, $ai_queries);
|
||||
for my $field (sort { $pos{$a} <=> $pos{$b} } keys %{$self->{schema}->{cols}}) {
|
||||
my %field_def = map { defined $self->{schema}->{cols}->{$field}->{$_} ? ($_ => $self->{schema}->{cols}->{$field}->{$_}) : () } keys %{$self->{schema}->{cols}->{$field}};
|
||||
my $is_ai = $self->{schema}->{ai} && $field eq $self->{schema}->{ai};
|
||||
delete $field_def{default} if $is_ai;
|
||||
my $def = $field . ' ' . ($self->column_sql(\%field_def) or return);
|
||||
if ($is_ai) {
|
||||
my $ai = $self->{hints}->{ai} || 'AUTO_INCREMENT';
|
||||
$ai = $ai->($table, $field) if ref $ai eq 'CODE';
|
||||
if (ref $ai eq 'ARRAY') {
|
||||
$ai_queries = $ai;
|
||||
}
|
||||
else {
|
||||
$def .= " $ai";
|
||||
}
|
||||
}
|
||||
push @field_defs, $def;
|
||||
}
|
||||
|
||||
# Add the primary key.
|
||||
if (@{$self->{schema}->{pk}}) {
|
||||
push @field_defs, "PRIMARY KEY (" . join(",", @{$self->{schema}->{pk}}) . ")";
|
||||
}
|
||||
|
||||
# Create the table
|
||||
my $create_query = "\n\tCREATE TABLE $table (\n\t\t";
|
||||
$create_query .= join ",\n\t\t", @field_defs;
|
||||
$create_query .= "\n\t)";
|
||||
|
||||
$self->do($create_query) or return;
|
||||
|
||||
# If the database needs separate queries to set up the auto-increment, run them
|
||||
if ($ai_queries) {
|
||||
for (@$ai_queries) {
|
||||
$self->do($_);
|
||||
}
|
||||
}
|
||||
|
||||
# Create the table's indexes
|
||||
for my $type (qw/index unique/) {
|
||||
my $create_index = "create_$type";
|
||||
while (my ($index_name, $index) = each %{$self->{schema}->{$type}}) {
|
||||
$self->$create_index($table => $index_name => @$index) if @$index;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{column_sql} = __LINE__ . <<'END_OF_SUB';
|
||||
sub column_sql {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Converts a column definition into an SQL string used in the create table
|
||||
# statement, and (for some drivers) when adding a new column to a table.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
|
||||
ref $opts eq 'HASH' or return $self->fatal(BADARGS => '$obj->column_sql (HASH_REF)');
|
||||
$opts->{type} or return $self->fatal(BADARGS => 'Column definition does not have a SQL type defined');
|
||||
|
||||
my $pkg = ref($self) . '::Types';
|
||||
my $type = uc $opts->{type};
|
||||
|
||||
if ($pkg->can($type)) {
|
||||
$self->debug("Using driver specific SQL for type $opts->{type}") if $self->{_debug} > 1;
|
||||
}
|
||||
elsif (GT::SQL::Driver::Types->can($type)) {
|
||||
$pkg = 'GT::SQL::Driver::Types';
|
||||
}
|
||||
else {
|
||||
return $self->fatal(BADTYPE => $opts->{type});
|
||||
}
|
||||
$pkg->$type({%$opts});
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{insert} = __LINE__ . <<'END_OF_SUB';
|
||||
sub insert {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This subroutine, using a couple driver hints, handles insertions for every
|
||||
# driver currently supported.
|
||||
#
|
||||
my ($self, $input) = @_;
|
||||
|
||||
my (@names, @values, @placeholders, @binds);
|
||||
my %got;
|
||||
my $ai = $self->{schema}->{ai};
|
||||
my $bind = $self->{hints}->{bind};
|
||||
my $cols = $self->{schema}->{cols};
|
||||
while (my ($col, $val) = each %$input) {
|
||||
++$got{$col};
|
||||
next if $ai and $col eq $ai and !$val;
|
||||
push @names, $col;
|
||||
my $def = $cols->{$col};
|
||||
if ($def->{time_check} and (not defined $val or $val eq '' or $val eq 'NOW()')) {
|
||||
push @values, $self->{hints}->{now} || 'NOW()';
|
||||
}
|
||||
elsif ($def->{type} =~ /DATE/ and (not defined $val or $val eq '')) {
|
||||
push @values, 'NULL';
|
||||
}
|
||||
elsif (ref $val eq 'SCALAR' or ref $val eq 'LVALUE') {
|
||||
push @values, $$val;
|
||||
}
|
||||
else {
|
||||
push @placeholders, $val;
|
||||
push @values, '?';
|
||||
if ($bind and defined $val) {
|
||||
for (my $i = 1; $i < @$bind; $i += 2) {
|
||||
if ($def->{type} =~ /$bind->[$i]/) {
|
||||
push @binds, [scalar @placeholders, $col, $bind->[$i+1]];
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Update any timestamp columns to current time.
|
||||
for my $col (keys %$cols) {
|
||||
next unless not $got{$col} and $cols->{$col}->{time_check};
|
||||
push @names, $col;
|
||||
push @values, $self->{hints}->{now} || 'NOW()';
|
||||
$got{$col} = 1;
|
||||
}
|
||||
|
||||
# Add an auto increment field if required
|
||||
if ($ai and not $input->{$ai}) {
|
||||
my @ai_insert = $self->ai_insert($ai);
|
||||
if (@ai_insert) {
|
||||
push @names, $ai_insert[0];
|
||||
push @values, $ai_insert[1];
|
||||
}
|
||||
}
|
||||
|
||||
# Fill in any missing defaults
|
||||
for my $col (keys %$cols) {
|
||||
next if $ai and $col eq $ai
|
||||
or $got{$col}
|
||||
or not exists $cols->{$col}->{default};
|
||||
my $val = $cols->{$col}->{default};
|
||||
push @names, $col;
|
||||
push @values, '?';
|
||||
push @placeholders, $val;
|
||||
$got{$col} = 1;
|
||||
if ($bind and defined $val) {
|
||||
my $def = $cols->{$col};
|
||||
for (my $i = 1; $i < @$bind; $i += 2) {
|
||||
if ($def->{type} =~ /$bind->[$i]/) {
|
||||
push @binds, [scalar @placeholders, $col, $bind->[$i+1]];
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Create the SQL and statement handle.
|
||||
my $query = "INSERT INTO $self->{name} (";
|
||||
$query .= join ',', @names;
|
||||
$query .= ") VALUES (";
|
||||
$query .= join ',', @values;
|
||||
$query .= ")";
|
||||
|
||||
$bind->[0]->{$query} = \@binds if $bind;
|
||||
|
||||
my $sth = $self->prepare($query) or return;
|
||||
$sth->execute(@placeholders) or return;
|
||||
$sth;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub ai_insert {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a column name and value to use for the AI column when inserting a
|
||||
# row. If this returns an empty list, no value will be inserted. This will
|
||||
# only be called when the table has an auto-increment column, so checking is
|
||||
# not necessary. The sole argument passed in is the name of the column.
|
||||
#
|
||||
my ($self, $ai) = @_;
|
||||
return $ai, 'NULL';
|
||||
}
|
||||
|
||||
$COMPILE{insert_multiple} = __LINE__ . <<'END_OF_SUB';
|
||||
sub insert_multiple {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Performs a multiple-insertion. By default, this is simply done as multiple
|
||||
# executes on a single insertion, and as a single transaction if under
|
||||
# DBI >= 1.20.
|
||||
#
|
||||
my ($self, $cols, $args) = @_;
|
||||
$self->{dbh}->begin_work if $DBI::VERSION >= 1.20;
|
||||
my $count;
|
||||
for my $val (@$args) {
|
||||
my %set;
|
||||
for my $i (0 .. $#$cols) {
|
||||
$set{$cols->[$i]} = $val->[$i];
|
||||
}
|
||||
++$count if $self->insert(\%set);
|
||||
}
|
||||
$self->{dbh}->commit if $DBI::VERSION >= 1.20;
|
||||
$count;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub update {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $set, $where) = @_;
|
||||
|
||||
my $c = $self->{schema}->{cols};
|
||||
my %set;
|
||||
|
||||
for my $cond (@{$set->{cond}}) {
|
||||
if (ref $cond eq 'ARRAY') {
|
||||
$set{$cond->[0]}++ if exists $c->{$cond->[0]} and $c->{$cond->[0]}->{time_check};
|
||||
}
|
||||
}
|
||||
for my $col (keys %$c) {
|
||||
next unless not $set{$col} and $c->{$col}->{time_check};
|
||||
$set->add($col, '=', \($self->{hints}->{now} || 'NOW()'));
|
||||
}
|
||||
|
||||
my ($sql_set, $set_vals, $set_cols) = $set->sql(1);
|
||||
my ($sql_where, $where_vals, $where_cols) = $where->sql(1);
|
||||
my $i = 1;
|
||||
|
||||
# Set up binds, if necessary
|
||||
my @binds;
|
||||
my $bind = $self->{hints}->{bind};
|
||||
if ($bind) {
|
||||
for my $col (@$set_cols) {
|
||||
next unless exists $c->{$col};
|
||||
for (my $j = 1; $j < @$bind; $j += 2) {
|
||||
if ($c->{$col}->{type} =~ /$bind->[$j]/) {
|
||||
push @binds, [scalar $i, $col, $bind->[$j+1]];
|
||||
last;
|
||||
}
|
||||
}
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
|
||||
my $query = "UPDATE $self->{name} SET $sql_set";
|
||||
$query .= " WHERE $sql_where" if $sql_where;
|
||||
|
||||
$bind->[0]->{$query} = \@binds if $bind;
|
||||
|
||||
my $sth = $self->prepare($query) or return;
|
||||
$sth->execute(@$set_vals, @$where_vals) or return;
|
||||
$sth;
|
||||
}
|
||||
|
||||
sub delete {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $where) = @_;
|
||||
my ($sql_where, $where_vals) = $where ? $where->sql(1) : ();
|
||||
my $sql = "DELETE FROM $self->{name}";
|
||||
$sql .= " WHERE $sql_where" if $sql_where;
|
||||
|
||||
my $sth = $self->prepare($sql) or return;
|
||||
$sth->execute(@$where_vals) or return;
|
||||
$sth;
|
||||
}
|
||||
|
||||
sub select {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $field_arr, $where, $opts) = @_;
|
||||
|
||||
my ($fields, $opt_clause) = ('', '');
|
||||
if (ref $field_arr and @$field_arr) {
|
||||
$fields = join ",", @$field_arr;
|
||||
}
|
||||
else {
|
||||
$fields = '*';
|
||||
}
|
||||
my ($sql_where, $where_vals) = $where->sql(1);
|
||||
$sql_where and ($sql_where = " WHERE $sql_where");
|
||||
if ($opts) {
|
||||
for my $opt (@$opts) {
|
||||
next if (! defined $opt);
|
||||
$opt_clause .= " $opt";
|
||||
}
|
||||
}
|
||||
my $sql = "SELECT $fields FROM " . $self->{name};
|
||||
$sql .= $sql_where if $sql_where;
|
||||
$sql .= $opt_clause if $opt_clause;
|
||||
my $sth = $self->prepare($sql) or return;
|
||||
$sth->execute(@$where_vals) or return;
|
||||
$sth;
|
||||
}
|
||||
|
||||
$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops the table passed in.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
$self->do("DROP TABLE $table");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{column_exists} = __LINE__ . <<'END_OF_SUB';
|
||||
sub column_exists {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns true or false value depending on whether the column exists in the
|
||||
# table. This defaults to a DESCRIBE of the table, then looks for the column
|
||||
# in the DESCRIBE results - but many databases probably have a much more
|
||||
# efficient alternative.
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->prepare("DESCRIBE $table") or return;
|
||||
$sth->execute or return;
|
||||
my $found;
|
||||
while (my ($col) = $sth->fetchrow) {
|
||||
$found = 1, last if $col eq $column;
|
||||
}
|
||||
$found;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{add_column} = __LINE__ . <<'END_OF_SUB';
|
||||
sub add_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds a column to a table.
|
||||
#
|
||||
my ($self, $table, $column, $def) = @_;
|
||||
$self->do("ALTER TABLE $table ADD $column $def");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{drop_column} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a column from a table.
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
$self->do("ALTER TABLE $table DROP $column");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{alter_column} = __LINE__ . <<'END_OF_SUB';
|
||||
sub alter_column {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Changes a column. Takes table name, column name, definition for the new
|
||||
# column (string), and the old column definition (hash ref). The new column
|
||||
# definition should already be set in the table object
|
||||
# ($self->{table}->{schema}->{cols}->{$column_name}).
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
$self->do("ALTER TABLE $table CHANGE $column $column $new_def");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{create_index} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Adds an index - checks driver hints for whether or not to prefix the index
|
||||
# with the prefixed table name.
|
||||
#
|
||||
my ($self, $table, $index_name, @index_cols) = @_;
|
||||
$index_name = $table . $index_name if $self->{hints}->{prefix_indexes};
|
||||
$self->do("CREATE INDEX $index_name ON $table (" . join(",", @index_cols) . ")");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{create_unique} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_unique {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Adds a unique index to a table, using the prefixed table name as a prefix.
|
||||
#
|
||||
my ($self, $table, $unique_name, @unique_cols) = @_;
|
||||
$unique_name = $table . $unique_name if $self->{hints}->{prefix_indexes};
|
||||
$self->do("CREATE UNIQUE INDEX $unique_name ON $table (" . join(",", @unique_cols) . ")");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{drop_index} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Drops an index.
|
||||
#
|
||||
my ($self, $table, $index_name) = @_;
|
||||
$index_name = $table . $index_name if $self->{hints}->{prefix_indexes};
|
||||
my $dropped = $self->do("DROP INDEX $index_name");
|
||||
$dropped ||= $self->do("DROP INDEX $self->{connect}->{PREFIX}$index_name") if $self->{hints}->{fix_index_dbprefix};
|
||||
$dropped;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{create_pk} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_pk {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds a primary key to a table.
|
||||
#
|
||||
my ($self, $table, @cols) = @_;
|
||||
$self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(",", @cols) . ")");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{drop_pk} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_pk {
|
||||
# -------------------------------------------------------------------
|
||||
# Drop a primary key.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
my $do;
|
||||
if ($self->{hints}->{drop_pk_constraint}) {
|
||||
# To drop a primary key in ODBC or Pg, you drop the primary key
|
||||
# constraint, which implicitly drops the index implicitly created by a
|
||||
# primary key.
|
||||
my $sth = $self->prepare("SHOW INDEX FROM $table") or return;
|
||||
$sth->execute or return;
|
||||
|
||||
my $pk_constraint;
|
||||
while (my $index = $sth->fetchrow_hashref) {
|
||||
if ($index->{index_primary}) {
|
||||
$pk_constraint = $index->{index_name};
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
$pk_constraint or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table");
|
||||
|
||||
$do = "ALTER TABLE $table DROP CONSTRAINT $pk_constraint";
|
||||
}
|
||||
else {
|
||||
$do = "ALTER TABLE $table DROP PRIMARY KEY";
|
||||
}
|
||||
$self->do($do);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
521
site/glist/lib/GT/SQL/Driver/MSSQL.pm
Normal file
521
site/glist/lib/GT/SQL/Driver/MSSQL.pm
Normal file
@@ -0,0 +1,521 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::MSSQL
|
||||
# CVS Info :
|
||||
# $Id: MSSQL.pm,v 2.6 2005/06/28 23:36:43 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: MSSQL driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::MSSQL;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE %BINDS/;
|
||||
use DBI qw/:sql_types/;
|
||||
use GT::SQL::Driver;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub connect {
|
||||
# ------------------------------------------------------------------
|
||||
# Need to set some session preferences.
|
||||
#
|
||||
my $self = shift;
|
||||
my $dbh = $self->SUPER::connect(@_) or return;
|
||||
|
||||
# Set max read properties for DBI
|
||||
$dbh->{LongReadLen} = 1_048_576;
|
||||
|
||||
# Newer DBD::ODBC sets this to 0 which can cause cast errors
|
||||
$dbh->{odbc_default_bind_type} = SQL_VARCHAR;
|
||||
|
||||
$dbh->do("SET QUOTED_IDENTIFIER ON");
|
||||
$dbh->do("SET ANSI_NULLS ON");
|
||||
$dbh->do("SET ANSI_PADDING OFF");
|
||||
$dbh->do("SET ANSI_WARNINGS OFF");
|
||||
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
sub dsn {
|
||||
# -------------------------------------------------------------------
|
||||
# Override the default create dsn, with our own. Creates DSN like:
|
||||
# DBI:ODBC:DSN
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
|
||||
$self->{driver} = $connect->{driver} = 'ODBC';
|
||||
|
||||
return "DBI:$connect->{driver}:$connect->{database}";
|
||||
}
|
||||
|
||||
sub hints {
|
||||
fix_index_dbprefix => 1,
|
||||
case_map => 1,
|
||||
bind => [
|
||||
\%BINDS,
|
||||
'TEXT' => DBI::SQL_LONGVARCHAR,
|
||||
'DATE|TIME' => DBI::SQL_VARCHAR
|
||||
],
|
||||
now => 'GETDATE()',
|
||||
ai => 'IDENTITY(1,1)',
|
||||
drop_pk_constraint => 1
|
||||
}
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Track limits as ODBC has no built-in limit support; this driver hacks it in.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
|
||||
my ($limit, $offset);
|
||||
|
||||
# Look for either PG or MySQL limits
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/($limit, $offset) = ($1, $2); ''/ie
|
||||
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/($limit, $offset) = ($2, $1); ''/ie
|
||||
or $query =~ s/\bLIMIT\s+(\d+)\s*(?:,\s*(\d+))?/($limit, $offset) = ($2 || $1, $2 ? $1 : 0); ''/ie;
|
||||
|
||||
if ($limit) {
|
||||
$self->{_limit} = 1;
|
||||
$self->{_lim_offset} = $offset;
|
||||
my $top = $limit + $offset;
|
||||
$query =~ s/(SELECT(?:\s+DISTINCT)?)/$1 TOP $top/i;
|
||||
if (!$offset) {
|
||||
delete @$self{qw/_limit _lim_offset/};
|
||||
}
|
||||
}
|
||||
return $query;
|
||||
}
|
||||
|
||||
sub _prepare_describe {
|
||||
# -----------------------------------------------------------------------------
|
||||
# For compatibility with old code, 'DESCRIBE TABLE' is mapped to something that
|
||||
# looks something like a MySQL 'DESCRIBE TABLE' result.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /DESCRIBE\s+(\w+)/i) {
|
||||
return <<QUERY;
|
||||
SELECT
|
||||
c.name AS "Field",
|
||||
CASE
|
||||
WHEN t.name LIKE '%int' THEN t.name + '(' + CAST(t.prec AS VARCHAR) + ')'
|
||||
WHEN t.name LIKE '%char' THEN t.name + '(' + CAST(c.length AS VARCHAR) + ')'
|
||||
WHEN t.name = 'decimal' THEN t.name + '(' + CAST(c.prec AS VARCHAR) + ',' + CAST(c.scale AS VARCHAR) + ')'
|
||||
WHEN t.name = 'float' THEN 'double'
|
||||
ELSE t.name
|
||||
END AS "Type",
|
||||
ISNULL(c.collation, 'binary') AS "Collation",
|
||||
CASE WHEN c.isnullable = 1 THEN 'YES' ELSE '' END AS "Null",
|
||||
(
|
||||
SELECT TOP 1
|
||||
CASE
|
||||
WHEN m.text LIKE '(''%' THEN SUBSTRING(m.text, 3, LEN(m.text) - (CASE WHEN m.text LIKE '%'')' THEN 4 ELSE 2 END))
|
||||
WHEN m.text LIKE '(%' THEN SUBSTRING(m.text, 2, LEN(m.text) - (CASE WHEN m.text LIKE '%)' THEN 2 ELSE 1 END))
|
||||
ELSE m.text
|
||||
END
|
||||
FROM syscomments m, sysobjects d
|
||||
WHERE m.id = d.id AND d.xtype = 'D' AND d.info = c.colid AND d.parent_obj = o.id
|
||||
) AS "Default",
|
||||
|
||||
CASE WHEN c.status & 0x80 = 0x80 THEN 'auto_increment' ELSE '' END AS "Extra"
|
||||
FROM
|
||||
syscolumns c, systypes t, sysobjects o
|
||||
WHERE
|
||||
c.id = o.id AND
|
||||
o.name = '$1' AND
|
||||
o.type = 'U' AND
|
||||
c.xtype = t.xtype
|
||||
ORDER BY
|
||||
c.colid
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported DESCRIBE query");
|
||||
}
|
||||
# The following could be used above for "Key" - but it really isn't that useful
|
||||
# considering there's a working SHOW INDEX:
|
||||
# (
|
||||
# SELECT
|
||||
# CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END
|
||||
# FROM sysindexes i, sysindexkeys k
|
||||
# WHERE
|
||||
# i.indid = 1 AND i.id = o.id AND k.id = i.id AND k.indid = i.indid AND
|
||||
# k.colid = c.colid
|
||||
# ) AS "Key",
|
||||
}
|
||||
|
||||
sub column_exists {
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->{dbh}->prepare(<<EXISTS);
|
||||
SELECT
|
||||
COUNT(*)
|
||||
FROM syscolumns c, sysobjects o
|
||||
WHERE
|
||||
c.id = o.id AND
|
||||
o.type = 'U' AND
|
||||
o.name = ? AND
|
||||
c.name = ?
|
||||
EXISTS
|
||||
$sth->execute($table, $column);
|
||||
|
||||
return scalar $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub _prepare_show_tables {
|
||||
# -----------------------------------------------------------------------------
|
||||
# MS SQL's version of MySQL's 'SHOW TABLES'; there is also 'sp_tables', but
|
||||
# that returns more information (and more tables - it includes system tables)
|
||||
# than we want.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{do} = 'SELECT';
|
||||
"SELECT name as table_name FROM sysobjects WHERE xtype = 'U'";
|
||||
}
|
||||
|
||||
sub _prepare_show_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# See the 'Driver-specific notes' comment in GT::SQL::Driver
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
|
||||
$self->{do} = 'SELECT';
|
||||
return <<QUERY;
|
||||
SELECT
|
||||
sysindexes.name AS index_name,
|
||||
syscolumns.name AS index_column,
|
||||
INDEXPROPERTY(sysindexes.id, sysindexes.name, 'IsUnique') AS index_unique,
|
||||
CASE
|
||||
WHEN sysindexes.indid = 1 AND (
|
||||
SELECT COUNT(*) FROM sysconstraints
|
||||
WHERE sysconstraints.id = sysobjects.id AND sysconstraints.status & 7 = 1
|
||||
) > 0 THEN 1
|
||||
ELSE 0
|
||||
END AS index_primary
|
||||
FROM
|
||||
sysindexes, sysobjects, sysindexkeys, syscolumns
|
||||
WHERE
|
||||
sysindexes.indid >= 1 AND sysindexes.indid < 255 AND
|
||||
sysindexes.id = sysobjects.id AND sysindexes.id = sysindexkeys.id AND sysindexes.id = syscolumns.id AND
|
||||
sysindexkeys.colid = syscolumns.colid AND
|
||||
sysindexes.status = 0 AND
|
||||
sysindexes.indid = sysindexkeys.indid AND
|
||||
sysobjects.xtype = 'U' AND sysobjects.name = '$1'
|
||||
ORDER BY
|
||||
sysindexkeys.indid, sysindexkeys.keyno
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query");
|
||||
}
|
||||
}
|
||||
|
||||
# MS SQL shouldn't have the AI column in the insert list
|
||||
sub ai_insert { () }
|
||||
|
||||
# Returns a list of default constraints given a table and column
|
||||
sub _defaults {
|
||||
my ($self, $table_name, $column_name) = @_;
|
||||
my $query = <<" QUERY";
|
||||
SELECT o.name
|
||||
FROM sysconstraints d, sysobjects t, syscolumns c, sysobjects o
|
||||
WHERE d.status & 5 = 5 -- status with '5' bit set indicates a default constraint
|
||||
AND d.id = t.id -- constraint table to table
|
||||
AND c.id = t.id -- column's table to table
|
||||
AND d.colid = c.colid -- constraint column to column
|
||||
AND d.constid = o.id -- constraint id to object
|
||||
AND t.name = '$table_name' -- the table we're looking for
|
||||
AND c.name = '$column_name' -- the column we're looking for
|
||||
QUERY
|
||||
my $sth = $self->{dbh}->prepare($query)
|
||||
or return $self->warn(CANTPREPARE => $query, $DBI::errstr);
|
||||
$sth->execute()
|
||||
or return $self->warn(CANTEXECUTE => $query, $DBI::errstr);
|
||||
|
||||
my @defaults;
|
||||
while (my $default = $sth->fetchrow) {
|
||||
push @defaults, $default;
|
||||
}
|
||||
return @defaults;
|
||||
}
|
||||
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Generates the SQL to drop a column.
|
||||
#
|
||||
my ($self, $table, $column, $old_col) = @_;
|
||||
|
||||
my @queries;
|
||||
|
||||
# Delete any indexes on the column, as MSSQL does not do this automatically
|
||||
my $sth = $self->prepare("SHOW INDEX FROM $table");
|
||||
$sth->execute;
|
||||
my %drop_index;
|
||||
while (my $index = $sth->fetchrow_hashref) {
|
||||
if ($index->{index_column} eq $column) {
|
||||
$drop_index{$index->{index_name}}++;
|
||||
}
|
||||
}
|
||||
push @queries, map "DROP INDEX $table.$_", keys %drop_index;
|
||||
|
||||
for ($self->_defaults($table, $column)) {
|
||||
# Drop any default constraints
|
||||
push @queries, "ALTER TABLE $table DROP CONSTRAINT $_";
|
||||
}
|
||||
|
||||
push @queries, "ALTER TABLE $table DROP COLUMN $column";
|
||||
|
||||
$self->do_raw_transaction(@queries);
|
||||
}
|
||||
|
||||
sub alter_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Changes a column in a table.
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
|
||||
# make a copy so as not to clobber the original reference
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
|
||||
if ($col{type} =~ /TEXT$/i) {
|
||||
# You can't alter a TEXT column in MSSQL, so we have to create an
|
||||
# entirely new column, copy the data, drop the old one, then rename the
|
||||
# new one using sp_rename.
|
||||
my $tmpcol = "tempcol__" . time . "__" . ('a' .. 'z', 'A' .. 'Z')[rand 52];
|
||||
|
||||
# We don't have to worry about dropping indexes because TEXT's can't be indexed.
|
||||
my @constraints = $self->_defaults($table, $column);
|
||||
|
||||
# Added columns must have a default, which unfortunately cannot be a column, so
|
||||
# if the definition doesn't already have a default, add a fake one. We use ''
|
||||
# for the default - though not allowed by GT::SQL, it _is_ allowed by MSSQL.
|
||||
my $no_default;
|
||||
if (not defined $col{default}) {
|
||||
$col{default} = '';
|
||||
$new_def = $self->column_sql(\%col);
|
||||
$no_default = 1;
|
||||
}
|
||||
|
||||
# This cannot be done in one single transaction as the columns won't
|
||||
# completely exist yet, as far as MSSQL is concerned.
|
||||
$self->do("ALTER TABLE $table ADD $tmpcol $new_def") or return;
|
||||
|
||||
push @constraints, $self->_defaults($table, $tmpcol) if $no_default;
|
||||
|
||||
my @q = "UPDATE $table SET $tmpcol = $column";
|
||||
push @q, map "ALTER TABLE $table DROP CONSTRAINT $_", @constraints;
|
||||
push @q, "ALTER TABLE $table DROP COLUMN $column";
|
||||
|
||||
$self->do_raw_transaction(@q) or return;
|
||||
|
||||
$self->do("sp_rename '$table.$tmpcol', '$column'") or return;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# An ALTER COLUMN in MS SQL cannot contain a default, so if a default is
|
||||
# specified that isn't the same as the old one, we drop the default
|
||||
# constraint and add a new one.
|
||||
my $new_default = delete $col{default};
|
||||
my $old_default = $old_col->{default};
|
||||
|
||||
my $default_changed = (
|
||||
defined $new_default and defined $old_default and $new_default ne $old_default
|
||||
or
|
||||
defined $new_default ne defined $old_default
|
||||
);
|
||||
|
||||
my @queries;
|
||||
|
||||
if ($default_changed) {
|
||||
if (defined $old_default) {
|
||||
push @queries, map "ALTER TABLE $table DROP CONSTRAINT $_", $self->_defaults($table, $column);
|
||||
}
|
||||
if (defined $new_default) {
|
||||
push @queries, "ALTER TABLE $table ADD CONSTRAINT default_${table}_$column DEFAULT " . $self->quote($new_default) . " FOR $column";
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $new_default) {
|
||||
# Rewrite the column def without the DEFAULT (an ALTER COLUMN cannot contain a default in MSSQL)
|
||||
$new_def = $self->column_sql(\%col);
|
||||
}
|
||||
|
||||
push @queries, "ALTER TABLE $table ALTER COLUMN $column $new_def";
|
||||
|
||||
return @queries > 1
|
||||
? $self->do_raw_transaction(@queries)
|
||||
: $self->do($queries[0]);
|
||||
}
|
||||
|
||||
sub drop_index {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops an index. Versions of this module prior to 2.0 were quite broken -
|
||||
# first, the index naming was (database prefix)(index name) in some places, and
|
||||
# (prefixed table name)(index name) in others. Furthermore, no prefixing of
|
||||
# indexes is needed at all as, like MySQL, indexes are per-table. As such,
|
||||
# this driver now looks for all three types of index when attempting to remove
|
||||
# existing indexes.
|
||||
#
|
||||
my ($self, $table, $index_name) = @_;
|
||||
|
||||
return $self->do("DROP INDEX $table.$index_name")
|
||||
or $self->do("DROP INDEX $table.$table$index_name")
|
||||
or $self->do("DROP INDEX $table.$self->{connect}->{PREFIX}$index_name");
|
||||
}
|
||||
|
||||
sub extract_index_name {
|
||||
# -----------------------------------------------------------------------------
|
||||
my ($self, $table, $index) = @_;
|
||||
$index =~ s/^\Q$table\E(?=.)//i # broken (tablename)(index name) format
|
||||
or $index =~ s/^\Q$self->{connect}->{PREFIX}\E(?=.)//i; # broken (prefix)(index name) format;
|
||||
$index;
|
||||
}
|
||||
|
||||
|
||||
package GT::SQL::Driver::MSSQL::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $DEBUG/;
|
||||
use GT::SQL::Driver::sth;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Retrieves the current sequence.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{_insert_id} if $self->{_insert_id};
|
||||
|
||||
my $sth = $self->{dbh}->prepare('SELECT @@IDENTITY') or return $self->fatal(CANTPREPARE => 'SELECT @@IDENTITY', $DBI::errstr);
|
||||
$sth->execute or return $self->fatal(CANTEXECUTE => 'SELECT @@IDENTITY', $DBI::errstr);
|
||||
$self->{_insert_id} = $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub execute {
|
||||
# -------------------------------------------------------------------
|
||||
# Fetch off only rows we are interested in.
|
||||
#
|
||||
my $self = shift;
|
||||
if ($self->{_need_preparing}) {
|
||||
$self->{sth} = $self->{dbh}->prepare($self->{query}) or return $self->warn(CANTPREPARE => $self->{query}, $DBI::errstr);
|
||||
}
|
||||
if (my $binds = $GT::SQL::Driver::MSSQL::BINDS{$self->{query}}) {
|
||||
for my $bind (@$binds) {
|
||||
my ($index, $col, $type) = @$bind;
|
||||
$self->{sth}->bind_param($index, $_[$index-1], $type);
|
||||
}
|
||||
}
|
||||
else {
|
||||
# We need to look for any values longer than 8000 characters and bind_param them
|
||||
# to SQL_LONGVARCHAR's to avoid an implicit rebinding that results in a
|
||||
# "Can't rebind placeholder x" error.
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if (defined $_[$i] and length $_[$i] > 8000) {
|
||||
$self->{sth}->bind_param($i+1, $_[$i], DBI::SQL_LONGVARCHAR);
|
||||
}
|
||||
}
|
||||
}
|
||||
my $time;
|
||||
if ($self->{_debug}) {
|
||||
$self->last_query($self->{query}, @_);
|
||||
my $stack = '';
|
||||
if ($self->{_debug} > 1) {
|
||||
$stack = GT::Base->stack_trace(1,1);
|
||||
$stack =~ s/<br>/\n /g;
|
||||
$stack =~ s/ / /g;
|
||||
$stack = "\n $stack\n"
|
||||
}
|
||||
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
|
||||
$self->debug("Executing query: $query$stack");
|
||||
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
|
||||
}
|
||||
|
||||
my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
$self->{_names} = $self->{_results} = $self->{_insert_id} = undef;
|
||||
|
||||
# Attempting to access ->{NAME} is not allowed for queries that don't actually
|
||||
# returning anything (such as 'ALTER TABLE foo ADD COLUMN a INT'); as such, try
|
||||
# to avoid them here. The eval is there just in case a query runs that isn't
|
||||
# caught.
|
||||
unless ($self->{do} =~ /^(?:ALTER|CREATE|INSERT|UPDATE|DROP|DELETE|SP_RENAME)$/) {
|
||||
eval {
|
||||
$self->{_names} = $self->{sth}->{NAME};
|
||||
};
|
||||
}
|
||||
|
||||
# Limit the results if needed.
|
||||
if ($self->{do} eq 'SELECT' or $self->{do} eq 'DESCRIBE') {
|
||||
my $none;
|
||||
if ($self->{_limit}) {
|
||||
my $begin = $self->{_lim_offset} || 0;
|
||||
for (1 .. $begin) {
|
||||
# Discard any leading rows that we don't care about
|
||||
$self->{sth}->fetchrow_arrayref or $none = 1, last;
|
||||
}
|
||||
}
|
||||
$self->{_results} = $none ? [] : $self->{sth}->fetchall_arrayref;
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
elsif ($self->{query} =~ /^\s*sp_/) {
|
||||
$self->{_results} = $self->{sth}->fetchall_arrayref;
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
else {
|
||||
$self->{rows} = $self->{sth}->rows;
|
||||
}
|
||||
$self->{sth}->finish;
|
||||
$self->{_need_preparing} = 1;
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
return $rc;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------ #
|
||||
# DATA TYPE MAPPINGS
|
||||
# ------------------------------------------------------------------------------------------------ #
|
||||
package GT::SQL::Driver::MSSQL::Types;
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use Carp qw/croak/;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
# MSSQL has a TINYINT type, however it is always unsigned, so only use it if
|
||||
# the column is _meant_ to be unsigned - otherwise use SMALLINT, which is
|
||||
# always signed.
|
||||
sub TINYINT {
|
||||
my ($class, $args) = @_;
|
||||
my $type = $args->{unsigned} ? 'TINYINT' : 'SMALLINT';
|
||||
$class->base($args, $type);
|
||||
}
|
||||
|
||||
# Though MSSQL supports a CHAR type, it can't be used because it doesn't trim
|
||||
# trailing spaces, and that would most likely break things designed to work
|
||||
# with the way 'CHAR's currently work.
|
||||
|
||||
sub DATE { $_[0]->base($_[1], 'DATETIME') }
|
||||
sub TIMESTAMP { $_[0]->base($_[1], 'DATETIME') }
|
||||
sub TIME { croak "MSSQL does not support 'TIME' columns" }
|
||||
sub YEAR { $_[0]->base($_[1], 'DATETIME') }
|
||||
|
||||
# MSSQL doesn't support BLOB's, but has binary 'IMAGE' and 'VARBINARY' types -
|
||||
# the one (rather large) caveat to these being that they require escaping and
|
||||
# unescaping of input and output.
|
||||
|
||||
1;
|
||||
226
site/glist/lib/GT/SQL/Driver/MYSQL.pm
Normal file
226
site/glist/lib/GT/SQL/Driver/MYSQL.pm
Normal file
@@ -0,0 +1,226 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::MYSQL
|
||||
# CVS Info :
|
||||
# $Id: MYSQL.pm,v 2.1 2005/04/14 00:56:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: MySQL driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::MYSQL;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE/;
|
||||
use GT::SQL::Driver;
|
||||
use DBD::mysql 1.19_03;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub dsn {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Creates the data source name used by DBI to connect to the database.
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
my $dsn;
|
||||
|
||||
$connect->{driver} ||= 'mysql';
|
||||
$connect->{host} ||= 'localhost';
|
||||
$self->{driver} = $connect->{driver};
|
||||
|
||||
$dsn = "DBI:$connect->{driver}:";
|
||||
$dsn .= join ';', map { $connect->{$_} ? "$_=$connect->{$_}" : () } qw/database host port/;
|
||||
return $dsn;
|
||||
}
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Prepares a query; rewrites PG-style LIMIT x OFFSET y into MySQL's confusing
|
||||
# LIMIT y, n
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/LIMIT $2, $1/i
|
||||
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/LIMIT $1, $2/i;
|
||||
$query;
|
||||
}
|
||||
|
||||
sub insert_multiple {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Performs a multiple-insertion. We have to watch the maximum query length,
|
||||
# performing multiple queries if necessary.
|
||||
#
|
||||
my ($self, $cols, $args) = @_;
|
||||
|
||||
my $has_ai;
|
||||
$has_ai = grep $_ eq $self->{schema}->{ai}, @$cols if $self->{schema}->{ai};
|
||||
|
||||
my $names = join ",", @$cols;
|
||||
$names .= ",$self->{schema}->{ai}" if $self->{schema}->{ai} and not $has_ai;
|
||||
|
||||
my $ret;
|
||||
my $values = '';
|
||||
for (@$args) {
|
||||
my $new_val;
|
||||
$new_val = "(" . join(",", map GT::SQL::Driver::quote($_), @$_);
|
||||
$new_val .= ",NULL" if $self->{schema}->{ai} and not $has_ai;
|
||||
$new_val .= ")";
|
||||
|
||||
if ($values and length($values) + length($new_val) > 1_000_000) {
|
||||
++$ret if $self->do("INSERT INTO $self->{name} ($names) VALUES $values");
|
||||
$values = '';
|
||||
}
|
||||
$values .= "," if $values;
|
||||
$values .= $new_val;
|
||||
}
|
||||
if ($values) {
|
||||
++$ret if $self->do("INSERT INTO $self->{name} ($names) VALUES $values");
|
||||
}
|
||||
$ret;
|
||||
}
|
||||
|
||||
# If making a nullable TEXT column not null, make sure we update existing NULL
|
||||
# columns to get the default value.
|
||||
sub alter_column {
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
if ($col{type} =~ /TEXT$/i
|
||||
and $col{not_null}
|
||||
and not $old_col->{not_null}
|
||||
and defined $col{default}
|
||||
and not defined $old_col->{default}) {
|
||||
$self->{dbh}->do("UPDATE $table SET $column = ? WHERE $column IS NULL", undef, $col{default});
|
||||
}
|
||||
return $self->SUPER::alter_column(@_[1 .. $#_])
|
||||
}
|
||||
|
||||
sub create_index {
|
||||
my ($self, $table, $index_name, @index_cols) = @_;
|
||||
$self->do("ALTER TABLE $table ADD INDEX $index_name (" . join(',', @index_cols) . ")");
|
||||
}
|
||||
|
||||
sub create_unique {
|
||||
my ($self, $table, $index_name, @index_cols) = @_;
|
||||
$self->do("ALTER TABLE $table ADD UNIQUE $index_name (" . join(',', @index_cols) . ")");
|
||||
}
|
||||
|
||||
sub drop_index {
|
||||
my ($self, $table, $index_name) = @_;
|
||||
$self->do("ALTER TABLE $table DROP INDEX $index_name");
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::MYSQL::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE/;
|
||||
use GT::SQL::Driver::sth;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Catch mysql's auto increment field.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{sth}->{mysql_insertid} || $self->{sth}->{insertid};
|
||||
}
|
||||
|
||||
sub rows { shift->{sth}->rows }
|
||||
|
||||
sub _execute_show_index {
|
||||
my $self = shift;
|
||||
$self->{sth}->execute or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
|
||||
my @results;
|
||||
|
||||
# Mysql columns are: Table Non_unique Key_name Seq_in_index Column_name Collation Cardinality Sub_part Packed Null Index_type Comment
|
||||
my @names = @{$self->row_names};
|
||||
# We need to add index_name, index_column, index_unique, index_primary (see GT::SQL::Driver)
|
||||
push @names, qw/index_name index_column index_unique index_primary/ unless $self->{_names};
|
||||
while (my $row = $self->{sth}->fetchrow_arrayref) {
|
||||
my %h = map { $names[$_] => $row->[$_] } 0 .. $#$row;
|
||||
push @results, [@$row, $h{Key_name}, $h{Column_name}, $h{Non_unique} ? 0 : 1, $h{Key_name} eq 'PRIMARY' ? 1 : 0];
|
||||
}
|
||||
|
||||
$self->{rows} = @results;
|
||||
$self->{_names} = \@names;
|
||||
$self->{_results} = \@results;
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::MYSQL::Types;
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
# Integers. MySQL supports non-standard unsigned and zerofill properties;
|
||||
# unsigned, though unportable, is supported here, however zerofill - whose
|
||||
# usefulness is dubious at best - is not.
|
||||
sub TINYINT { $_[0]->base($_[1], 'TINYINT', ['unsigned']) }
|
||||
sub SMALLINT { $_[0]->base($_[1], 'SMALLINT', ['unsigned']) }
|
||||
sub MEDIUMINT { $_[0]->base($_[1], 'MEDIUMINT', ['unsigned']) }
|
||||
sub INT { $_[0]->base($_[1], 'INT', ['unsigned']) }
|
||||
sub BIGINT { $_[0]->base($_[1], 'BIGINT', ['unsigned']) }
|
||||
|
||||
# Floats - MySQL's 'REAL' is really a 64-bit floating point number, while for
|
||||
# everything else 'REAL' is a 32-bit floating point number, so we override the
|
||||
# defaults here to FLOAT.
|
||||
sub FLOAT { $_[0]->base($_[1], 'FLOAT') }
|
||||
sub REAL { $_[0]->base($_[1], 'FLOAT') }
|
||||
|
||||
sub CHAR {
|
||||
my ($class, $args, $out) = @_;
|
||||
$args->{size} = 255 unless $args->{size} and $args->{size} <= 255;
|
||||
|
||||
$out ||= 'CHAR';
|
||||
$out .= "($args->{size})";
|
||||
$out .= ' BINARY' if $args->{binary}; # MySQL-only
|
||||
|
||||
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
|
||||
$out .= ' NOT NULL' if $args->{not_null};
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub TEXT {
|
||||
my ($class, $args) = @_;
|
||||
my $type = 'LONGTEXT';
|
||||
delete $args->{default}; # MySQL is the only driver that doesn't support defaults on TEXT's
|
||||
if ($args->{size}) {
|
||||
if ($args->{size} < 256) {
|
||||
$type = 'TINYTEXT';
|
||||
}
|
||||
elsif ($args->{size} < 65536) {
|
||||
$type = 'TEXT';
|
||||
}
|
||||
elsif ($args->{size} < 16777216) {
|
||||
$type = 'MEDIUMTEXT';
|
||||
}
|
||||
}
|
||||
|
||||
$class->base($args, $type);
|
||||
}
|
||||
|
||||
# MySQL supports ENUM; the generic ENUM is mapped to a VARCHAR
|
||||
sub ENUM {
|
||||
my ($class, $args) = @_;
|
||||
@{$args->{'values'}} or return;
|
||||
my $out = 'ENUM(' . join(",", map GT::SQL::Driver->quote($_), @{$args->{values}}) . ')';
|
||||
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
|
||||
$out .= ' NOT NULL' if $args->{not_null};
|
||||
$out;
|
||||
}
|
||||
|
||||
sub BLOB {
|
||||
my ($class, $attrib, $blob) = @_;
|
||||
delete $attrib->{default};
|
||||
$class->base($attrib, $blob || 'BLOB');
|
||||
}
|
||||
|
||||
1;
|
||||
541
site/glist/lib/GT/SQL/Driver/ORACLE.pm
Normal file
541
site/glist/lib/GT/SQL/Driver/ORACLE.pm
Normal file
@@ -0,0 +1,541 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::ORACLE
|
||||
# CVS Info :
|
||||
# $Id: ORACLE.pm,v 2.1 2005/02/01 02:01:18 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Oracle 8+ driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::ORACLE;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $ERRORS %BINDS/;
|
||||
|
||||
use DBD::Oracle qw/:ora_types/;
|
||||
use GT::SQL::Driver;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub connect {
|
||||
# ------------------------------------------------------------------
|
||||
# Need to set some session preferences.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# ORACLE_HOME must be set for the DBD::Oracle driver to function properly.
|
||||
return $self->warn('NOORACLEHOME') unless exists $ENV{ORACLE_HOME};
|
||||
|
||||
my $dbh = $self->SUPER::connect(@_) or return;
|
||||
|
||||
# Set the date format to same format as other drivers use.
|
||||
$dbh->do("ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'")
|
||||
or return $self->fatal(NONLSDATE => $DBI::errstr);
|
||||
|
||||
# Set max read properties for DBI.
|
||||
$dbh->{LongReadLen} = 1_048_576;
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
sub dsn {
|
||||
# -------------------------------------------------------------------
|
||||
# Oracle DSN looks like:
|
||||
# DBI:Oracle:host=HOST;port=POST;sid=SID
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
|
||||
$connect->{driver} ||= 'Oracle';
|
||||
$connect->{host} ||= 'localhost';
|
||||
$self->{driver} = $connect->{driver};
|
||||
|
||||
my $dsn = "DBI:$connect->{driver}:";
|
||||
$dsn .= "host=$connect->{host}";
|
||||
$dsn .= ";port=$connect->{port}" if $connect->{port};
|
||||
$dsn .= ";sid=$connect->{database}";
|
||||
|
||||
return $dsn;
|
||||
}
|
||||
|
||||
sub hints {
|
||||
case_map => 1,
|
||||
prefix_indexes => 1,
|
||||
bind => [
|
||||
\%BINDS,
|
||||
'TEXT' => ORA_CLOB,
|
||||
'BLOB' => ORA_BLOB
|
||||
],
|
||||
now => 'SYSDATE',
|
||||
ai => sub {
|
||||
my ($table, $column) = @_;
|
||||
my $seq = "${table}_seq";
|
||||
my @q;
|
||||
push @q, \"DROP SEQUENCE $seq";
|
||||
push @q, "CREATE SEQUENCE $seq INCREMENT BY 1 START WITH 1 NOCYCLE";
|
||||
\@q;
|
||||
}
|
||||
}
|
||||
|
||||
sub prepare {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Clear our limit counters. Oracle does not have built-in limit support, so it
|
||||
# is handled here by fetching all the results that were asked for into _results
|
||||
# and our own fetchrow methods work off that.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
|
||||
# Oracle uses "SUBSTR" instead of "SUBSTRING"
|
||||
$query =~ s/\bSUBSTRING\(/SUBSTR(/gi;
|
||||
|
||||
$self->SUPER::prepare($query);
|
||||
}
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Need to store what the requested result set; no built in LIMIT support like
|
||||
# mysql.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
|
||||
my ($limit, $offset);
|
||||
|
||||
# Handle either PG or MySQL limits
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/($limit, $offset) = ($1, $2); ''/ie
|
||||
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/($limit, $offset) = ($2, $1); ''/ie
|
||||
or $query =~ s/\bLIMIT\s+(\d+)\s*(?:,\s*(\d+))?/($limit, $offset) = ($2 || $1, $2 ? $1 : 0); ''/ie;
|
||||
|
||||
if ($limit) {
|
||||
$self->{_limit} = 1;
|
||||
$self->{_lim_rows} = $limit;
|
||||
$self->{_lim_offset} = $offset;
|
||||
}
|
||||
|
||||
# LEFT OUTER JOIN is not supported, instead:
|
||||
# ... FROM Table1, Table2 WHERE col1 = col2(+) ...
|
||||
$query =~ s{FROM\s+(\w+)\s+LEFT OUTER JOIN\s+(\w+)\s+ON\s+([\w.]+)\s*=\s*([\w.]+)(\s+WHERE\s+)?}{
|
||||
my ($table1, $table2, $col1, $col2, $where) = ($1, $2, $3, $4, $5);
|
||||
my $from_where = "FROM $table1, $table2 WHERE ";
|
||||
$from_where .= index($col1, "$table1.") == 0
|
||||
? "$col1 = $col2(+)"
|
||||
: "$col2 = $col1(+)";
|
||||
$from_where .= " AND " if $where;
|
||||
$from_where;
|
||||
}ie;
|
||||
|
||||
$query;
|
||||
}
|
||||
|
||||
sub _prepare_describe {
|
||||
# ------------------------------------------------------------------
|
||||
# Oracle supports USER_TAB_COLUMNS to get information
|
||||
# about a table.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /DESCRIBE\s+(\w+)/i) {
|
||||
return <<" QUERY";
|
||||
SELECT COLUMN_NAME, DATA_TYPE, DATA_LENGTH, DATA_PRECISION, DATA_SCALE, NULLABLE, DATA_DEFAULT
|
||||
FROM USER_TAB_COLUMNS
|
||||
WHERE TABLE_NAME = '\U$1\E'
|
||||
ORDER BY COLUMN_ID
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Cannot get properties from db_tab_columns");
|
||||
}
|
||||
}
|
||||
|
||||
sub column_exists {
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->{dbh}->prepare(<<EXISTS);
|
||||
SELECT COUNT(*)
|
||||
FROM USER_TAB_COLUMNS
|
||||
WHERE TABLE_NAME = ? AND COLUMN_NAME = ?
|
||||
EXISTS
|
||||
$sth->execute(uc $table, uc $column);
|
||||
|
||||
return scalar $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub _prepare_show_tables {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Oracle's equivelant to SHOW TABLES
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{do} = 'SELECT';
|
||||
'SELECT table_name FROM USER_TABLES ORDER BY table_name';
|
||||
}
|
||||
|
||||
sub _prepare_show_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Get an index list; see 'Driver-specific notes' comment in GT::SQL::Driver
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
|
||||
# The below isn't quite perfect - Oracle 8 doesn't support CASE (9 does), so
|
||||
# the 'index_unique' still has to be mapped to a 1/0 value in execute(). Also
|
||||
# worth noting is that primary keys in Oracle don't always get their own index
|
||||
# - in particular, when adding a primary key to a table using a column that is
|
||||
# already indexed, the primary key will simply use the existing index instead
|
||||
# of creating a new one.
|
||||
return <<QUERY;
|
||||
SELECT
|
||||
ic.index_name AS "index_name",
|
||||
ic.column_name AS "index_column",
|
||||
(
|
||||
SELECT COUNT(*) FROM user_constraints c, user_cons_columns cc
|
||||
WHERE c.index_name = i.index_name AND c.constraint_name = cc.constraint_name
|
||||
AND c.constraint_type = 'P' AND cc.column_name = ic.column_name
|
||||
) "index_primary",
|
||||
uniqueness AS "index_unique"
|
||||
FROM
|
||||
user_ind_columns ic,
|
||||
user_indexes i
|
||||
WHERE
|
||||
ic.index_name = i.index_name AND
|
||||
LOWER(ic.table_name) = '\L$1\E'
|
||||
ORDER BY
|
||||
ic.index_name,
|
||||
ic.column_position
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query");
|
||||
}
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a table, including a sequence if necessary
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $seq = uc "${table}_seq";
|
||||
my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '$seq'");
|
||||
$sth->execute();
|
||||
if (my $seq_name = $sth->fetchrow) {
|
||||
my $sth = $self->{dbh}->prepare("DROP SEQUENCE $seq");
|
||||
$sth->execute or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq", $GT::SQL::error);
|
||||
}
|
||||
return $self->SUPER::drop_table($table);
|
||||
}
|
||||
|
||||
sub ai_insert {
|
||||
my ($self, $ai) = @_;
|
||||
return $ai, "$self->{name}_seq.NEXTVAL";
|
||||
}
|
||||
|
||||
sub alter_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Changes a column. Takes table name, column name, and new column definition.
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
|
||||
# make a copy so the original reference doesn't get clobbered
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
|
||||
# If the default value was removed, then make sure that the default constraint
|
||||
# from the previous instance is deactivated.
|
||||
if (not exists $col{default} and defined $old_col->{default} and length $old_col->{default}) {
|
||||
$col{default} = \'NULL';
|
||||
}
|
||||
|
||||
# Oracle doesn't like being told to make an already NOT NULL column NOT NULL:
|
||||
if ($col{not_null} and $old_col->{not_null}) {
|
||||
delete $col{not_null};
|
||||
}
|
||||
|
||||
$new_def = $self->column_sql(\%col);
|
||||
|
||||
# But it needs an explicit NULL to drop the field's NOT NULL
|
||||
if (not $col{not_null} and $old_col->{not_null}) {
|
||||
$new_def .= ' NULL';
|
||||
}
|
||||
|
||||
# Oracle doesn't need the data type, and won't accept it on CLOB/BLOB columns
|
||||
$new_def =~ s/^[BC]LOB ?//;
|
||||
$new_def or return 1; # If the def is empty now, there really isn't anything to be done.
|
||||
|
||||
$self->do("ALTER TABLE $table MODIFY $column $new_def");
|
||||
}
|
||||
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a column
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
$self->do("ALTER TABLE $table DROP COLUMN $column");
|
||||
}
|
||||
|
||||
sub create_pk {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds a primary key to a table.
|
||||
#
|
||||
my ($self, $table, @cols) = @_;
|
||||
$self->create_index($table, "${table}_pkey", @cols);
|
||||
$self->do("ALTER TABLE $table ADD CONSTRAINT ${table}_pkey PRIMARY KEY (" . join(",", @cols) . ")");
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::ORACLE::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $DEBUG/;
|
||||
use GT::SQL::Driver::sth;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Retrieves the current sequence.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{_insert_id} if $self->{_insert_id};
|
||||
|
||||
my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i;
|
||||
$table ||= $self->{name};
|
||||
my $seq = $table . "_seq.CURRVAL";
|
||||
my $query = "SELECT $seq FROM $table";
|
||||
my $sth = $self->{dbh}->prepare($query) or return $self->fatal(CANTPREPARE => $query, $DBI::errstr);
|
||||
$sth->execute or return $self->fatal(CANTEXECUTE => $query, $DBI::errstr);
|
||||
my ($id) = $sth->fetchrow_array;
|
||||
$self->{_insert_id} = $id;
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub execute {
|
||||
# -------------------------------------------------------------------
|
||||
# Fetch off only desired rows.
|
||||
#
|
||||
my $self = shift;
|
||||
my $time;
|
||||
if ($self->{_debug}) {
|
||||
$self->last_query($self->{query}, @_);
|
||||
my $stack = '';
|
||||
if ($self->{_debug} > 1) {
|
||||
$stack = GT::Base->stack_trace(1,1);
|
||||
$stack =~ s/<br>/\n /g;
|
||||
$stack =~ s/ / /g;
|
||||
$stack = "\n $stack\n"
|
||||
}
|
||||
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
|
||||
$self->debug("Executing query: $query$stack");
|
||||
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
|
||||
}
|
||||
if ($GT::SQL::Driver::ORACLE::BINDS{$self->{query}}) {
|
||||
for my $bind (@{$GT::SQL::Driver::ORACLE::BINDS{$self->{query}}}) {
|
||||
my ($index, $col, $type) = @$bind;
|
||||
$self->{sth}->bind_param($index, $_[$index - 1], { ora_type => $type, ora_field => $col });
|
||||
}
|
||||
}
|
||||
my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
$self->{_results} = [];
|
||||
$self->{_insert_id} = '';
|
||||
$self->{_names} = $self->{sth}->{NAME};
|
||||
if ($self->{do} eq 'SELECT') {
|
||||
$self->{_lim_cnt} = 0;
|
||||
if ($self->{_limit}) {
|
||||
my $begin = $self->{_lim_offset} || 0;
|
||||
my $end = $begin + $self->{_lim_rows};
|
||||
my $i = -1;
|
||||
while (my $rec = $self->{sth}->fetchrow_arrayref) {
|
||||
$i++;
|
||||
next if $i < $begin;
|
||||
last if $i >= $end;
|
||||
push @{$self->{_results}}, [@$rec]; # Must copy as ref is reused in DBI.
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{_results} = $self->{sth}->fetchall_arrayref;
|
||||
}
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
elsif ($self->{do} eq 'SHOW INDEX') {
|
||||
$self->{_names} = $self->{sth}->{NAME_lc};
|
||||
$self->{_results} = $self->{sth}->fetchall_arrayref;
|
||||
my $i = 0;
|
||||
for (@{$self->{_names}}) { last if $_ eq 'index_unique'; $i++ }
|
||||
for (@{$self->{_results}}) {
|
||||
$_->[$i] = uc($_->[$i]) eq 'UNIQUE' ? 1 : 0;
|
||||
}
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
elsif ($self->{do} eq 'DESCRIBE') {
|
||||
$rc = $self->_fixup_describe();
|
||||
}
|
||||
else {
|
||||
$self->{rows} = $self->{sth}->rows;
|
||||
}
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
return $rc;
|
||||
}
|
||||
|
||||
sub _fixup_describe {
|
||||
# ---------------------------------------------------------------
|
||||
# Converts output of 'sp_columns tablename' into similiar results
|
||||
# of mysql's describe tablename.
|
||||
#
|
||||
my $self = shift;
|
||||
my @results;
|
||||
|
||||
# Mysql Cols are: Field, Type, Null, Key, Default, Extra
|
||||
my $table = uc $self->{name};
|
||||
while (my $col = $self->{sth}->fetchrow_hashref) {
|
||||
my ($table, $field, $type, $size, $prec, $scale) = @$col{qw/TABLE_NAME COLUMN_NAME DATA_TYPE DATA_LENGTH DATA_PRECISION DATA_SCALE/};
|
||||
my $null = $col->{NULLABLE} eq 'Y';
|
||||
my $default = (not defined $col->{DATA_DEFAULT} or $col->{DATA_DEFAULT} =~ /^''\s*/) ? '' : $col->{DATA_DEFAULT};
|
||||
|
||||
$size = length $default if length $default > $size;
|
||||
|
||||
if ($type =~ /VARCHAR2|CHAR/) {
|
||||
$type = "varchar($size)";
|
||||
}
|
||||
elsif ($type =~ /NUMBER/ and !$scale) {
|
||||
if ($prec) {
|
||||
$type =
|
||||
$prec >= 11 ? 'bigint' :
|
||||
$prec >= 9 ? 'int' :
|
||||
$prec >= 6 ? 'mediumint' :
|
||||
$prec >= 4 ? 'smallint' :
|
||||
'tinyint';
|
||||
}
|
||||
else {
|
||||
$type = 'bigint';
|
||||
}
|
||||
}
|
||||
elsif ($type =~ /NUMBER/ and length $prec and length $scale) {
|
||||
$type = "decimal($prec, $scale)";
|
||||
}
|
||||
elsif ($type =~ /FLOAT/) {
|
||||
$type = (!$prec or $prec > 23) ? 'double' : 'real';
|
||||
}
|
||||
elsif ($type =~ /LONG|CLOB|NCLOB/) {
|
||||
$type = 'text';
|
||||
}
|
||||
elsif ($type =~ /DATE/) {
|
||||
$type = 'datetime';
|
||||
}
|
||||
|
||||
$type = lc $type;
|
||||
$default =~ s,^NULL\s*,,;
|
||||
$default =~ s,^\(?'(.*)'\)?\s*$,$1,;
|
||||
$null = $null ? 'YES' : '';
|
||||
push @results, [$field, $type, $null, '', $default, ''];
|
||||
}
|
||||
( $#results < 0 ) and return;
|
||||
|
||||
# Fetch the Primary key
|
||||
my $que_pk = <<" QUERY";
|
||||
SELECT COL.COLUMN_NAME
|
||||
FROM USER_CONS_COLUMNS COL, USER_CONSTRAINTS CON
|
||||
WHERE COL.TABLE_NAME = '\U$table\E'
|
||||
AND COL.TABLE_NAME = CON.TABLE_NAME
|
||||
AND COL.CONSTRAINT_NAME = CON.CONSTRAINT_NAME
|
||||
AND CON.CONSTRAINT_TYPE='P'
|
||||
QUERY
|
||||
my $sth_pk = $self->{dbh}->prepare($que_pk);
|
||||
$sth_pk->execute;
|
||||
my $indexes = {};
|
||||
while ( my $col = $sth_pk->fetchrow_array ) {
|
||||
$indexes->{$col} = "PRI";
|
||||
}
|
||||
$sth_pk->finish;
|
||||
|
||||
# Fetch the index information.
|
||||
my $que_idx = <<" QUERY";
|
||||
SELECT *
|
||||
FROM USER_INDEXES IND, USER_IND_COLUMNS COL
|
||||
WHERE IND.TABLE_NAME = '\U$table\E'
|
||||
AND IND.TABLE_NAME = COL.TABLE_NAME
|
||||
AND IND.INDEX_NAME = COL.INDEX_NAME
|
||||
QUERY
|
||||
|
||||
my $sth_idx = $self->{dbh}->prepare($que_idx);
|
||||
$sth_idx->execute;
|
||||
while ( my $col = $sth_idx->fetchrow_hashref ) {
|
||||
my $key = $col->{UNIQUENESS} =~ /UNIQUE/ ? 'UNIQUE' : 'MUL';
|
||||
exists $indexes->{$col->{COLUMN_NAME}} or $indexes->{$col->{COLUMN_NAME}} = $key;
|
||||
}
|
||||
|
||||
for my $result (@results) {
|
||||
if (defined $indexes->{$result->[0]}) {
|
||||
$result->[3] = $indexes->{$result->[0]};
|
||||
if ($result->[1] =~ /int/) { # Set extra
|
||||
my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '\U$table\E_SEQ'");
|
||||
$sth->execute;
|
||||
$result->[5] = 'auto_increment' if $sth->fetchrow;
|
||||
$sth->finish;
|
||||
}
|
||||
}
|
||||
}
|
||||
$sth_idx->finish;
|
||||
$self->{_results} = \@results;
|
||||
$self->{_names} = [qw/Field Type Null Key Default Extra/];
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub finish {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
delete $GT::SQL::Driver::ORACLE::BINDS{$self->{query}};
|
||||
$self->SUPER::finish;
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# DATA TYPE MAPPINGS
|
||||
# -----------------------------------------------------------------------------
|
||||
|
||||
package GT::SQL::Driver::ORACLE::Types;
|
||||
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use Carp qw/croak/;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
# Quoting table and/or column names gives case-sensitivity to the table and
|
||||
# column names in Oracle - however, because this needs to be compatible with
|
||||
# older versions of this driver that didn't properly handle table/column case,
|
||||
# we can't use that to our advantage, as all the old unquoted tables/columns
|
||||
# would be upper-case - TABLE or COLUMN will be the name in the database, and
|
||||
# "Table" or "column" would not exist. It would, however, still be nice to
|
||||
# support this at some point:
|
||||
# sub base {
|
||||
# my ($class, $args, $name, $attribs) = @_;
|
||||
# $class->SUPER::base($args, qq{"$name"}, $attribs);
|
||||
# }
|
||||
|
||||
sub TINYINT { $_[0]->base($_[1], 'NUMBER(3)') }
|
||||
sub SMALLINT { $_[0]->base($_[1], 'NUMBER(5)') }
|
||||
sub MEDIUMINT { $_[0]->base($_[1], 'NUMBER(8)') }
|
||||
sub INT { $_[0]->base($_[1], 'NUMBER(10)') }
|
||||
sub BIGINT { $_[0]->base($_[1], 'NUMBER(19)') }
|
||||
sub REAL { $_[0]->base($_[1], 'FLOAT(23)') }
|
||||
sub DOUBLE { $_[0]->base($_[1], 'FLOAT(52)') }
|
||||
|
||||
sub DATETIME { $_[0]->base($_[1], 'DATE') }
|
||||
sub TIMESTAMP { $_[0]->base($_[1], 'DATE') }
|
||||
sub TIME { croak "Oracle does not support 'TIME' columns\n" }
|
||||
sub YEAR { croak "Oracle does not support 'YEAR' columns\n" }
|
||||
|
||||
sub CHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
|
||||
sub VARCHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
|
||||
sub TEXT { $_[0]->base($_[1], 'CLOB') }
|
||||
sub BLOB { delete $_[1]->{default}; $_[0]->base($_[1], 'BLOB') }
|
||||
|
||||
1;
|
||||
643
site/glist/lib/GT/SQL/Driver/PG.pm
Normal file
643
site/glist/lib/GT/SQL/Driver/PG.pm
Normal file
@@ -0,0 +1,643 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::PG
|
||||
# CVS Info :
|
||||
# $Id: PG.pm,v 2.2 2005/02/01 02:00:47 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: PostgreSQL driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::PG;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE/;
|
||||
use GT::SQL::Driver;
|
||||
use GT::AutoLoader;
|
||||
use DBI();
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub dsn {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Creates a postgres-specific DSN, such as:
|
||||
# DBI:Pg:dbname=database;host=some_hostname
|
||||
# host is omitted if set to 'localhost', so that 'localhost' can be used for a
|
||||
# non-network connection. If you really want to connect to localhost, use
|
||||
# 127.0.0.1.
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
|
||||
$connect->{driver} ||= 'Pg';
|
||||
$connect->{host} ||= 'localhost';
|
||||
$self->{driver} = $connect->{driver};
|
||||
|
||||
my $dsn = "DBI:$connect->{driver}:";
|
||||
$dsn .= "dbname=$connect->{database}";
|
||||
$dsn .= ";host=$connect->{host}" unless $connect->{host} eq 'localhost';
|
||||
$dsn .= ";port=$connect->{port}" if $connect->{port};
|
||||
|
||||
return $dsn;
|
||||
}
|
||||
|
||||
sub hints {
|
||||
prefix_indexes => 1,
|
||||
fix_index_dbprefix => 1,
|
||||
case_map => 1,
|
||||
ai => sub {
|
||||
my ($table, $column) = @_;
|
||||
my $seq = "${table}_seq";
|
||||
my @q;
|
||||
push @q, \"DROP SEQUENCE $seq";
|
||||
push @q, "CREATE SEQUENCE $seq INCREMENT 1 START 1";
|
||||
\@q;
|
||||
},
|
||||
drop_pk_constraint => 1
|
||||
}
|
||||
|
||||
$COMPILE{_version} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _version {
|
||||
my $self = shift;
|
||||
return $self->{pg_version} if $self->{pg_version};
|
||||
my $ver = $self->{dbh}->get_info(18); # SQL_DBMS_VERSION
|
||||
if ($ver) {
|
||||
local $^W;
|
||||
$ver = sprintf "%.2f", $ver;
|
||||
}
|
||||
return $self->{pg_version} = $ver;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Rewrite MySQL-style LIMIT y,x into PG's nicer LIMIT x OFFSET y format
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s*,\s*(\d+)/LIMIT $2 OFFSET $1/i;
|
||||
$query;
|
||||
}
|
||||
|
||||
sub _prepare_describe {
|
||||
# ------------------------------------------------------------------
|
||||
# Postgres-specific describe code
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
$query =~ /DESCRIBE\s*(\w+)/i
|
||||
or return $self->warn(CANTPREPARE => $query, "Invalid describe query: $query");
|
||||
|
||||
# atttypmod contains the scale and precision, but has to be extracted using bit operations:
|
||||
my $prec_bits = 2**26-2**15-1; # bits 16 through 26 give the precision (given a max prec of 1000)
|
||||
my $scale_bits = 2**10-1; # bits 1 through 10 give the scale + 4 (given a max scale of 1000)
|
||||
|
||||
<<QUERY
|
||||
SELECT
|
||||
a.attname as "Field",
|
||||
CASE
|
||||
WHEN t.typname = 'int4' THEN 'int(10)'
|
||||
WHEN t.typname = 'int2' THEN 'smallint(5)'
|
||||
WHEN t.typname = 'int8' THEN 'bigint(19)'
|
||||
WHEN t.typname = 'float4' THEN 'real'
|
||||
WHEN t.typname = 'float8' THEN 'double'
|
||||
WHEN t.typname = 'bpchar' THEN 'char(' || (a.atttypmod - 4) || ')'
|
||||
WHEN t.typname = 'varchar' THEN 'varchar(' || (a.atttypmod - 4) || ')'
|
||||
WHEN t.typname = 'numeric' THEN 'decimal(' || ((atttypmod & $prec_bits)>>16) || ',' || ((a.atttypmod & $scale_bits)-4) || ')'
|
||||
ELSE t.typname
|
||||
END AS "Type",
|
||||
CASE WHEN a.attnotnull = 't' THEN '' ELSE 'YES' END AS "Null",
|
||||
(
|
||||
SELECT
|
||||
CASE
|
||||
WHEN adsrc SIMILAR TO '''%''::[a-zA-Z0-9]+' THEN substring(adsrc from '''#"%#"''::[a-zA-Z0-9]+' for '#')
|
||||
WHEN adsrc SIMILAR TO '[0-9.e+-]+' THEN adsrc
|
||||
ELSE NULL
|
||||
END
|
||||
FROM pg_attrdef
|
||||
WHERE adrelid = c.relfilenode AND adnum = a.attnum
|
||||
) AS "Default",
|
||||
(
|
||||
SELECT
|
||||
CASE WHEN d.adsrc LIKE 'nextval(%)' THEN 'auto_increment' ELSE '' END
|
||||
FROM pg_attrdef d
|
||||
WHERE d.adrelid = c.relfilenode AND adnum = a.attnum
|
||||
) AS "Extra"
|
||||
FROM
|
||||
pg_class c, pg_attribute a, pg_type t
|
||||
WHERE
|
||||
a.atttypid = t.oid AND a.attrelid = c.oid AND
|
||||
relkind = 'r' AND
|
||||
a.attnum > 0 AND
|
||||
c.relname = '\L$1\E'
|
||||
ORDER BY
|
||||
a.attnum
|
||||
QUERY
|
||||
|
||||
# The following could be used above for Key - but it's left off because SHOW
|
||||
# INDEX is much more useful:
|
||||
# (
|
||||
# SELECT CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END
|
||||
# FROM pg_index keyi, pg_class keyc, pg_attribute keya
|
||||
# WHERE keyi.indexrelid = keyc.oid AND keya.attrelid = keyc.oid and keyi.indrelid = c.oid
|
||||
# and indisprimary = 't' and keya.attname = a.attname
|
||||
# ) AS "Key",
|
||||
}
|
||||
|
||||
sub column_exists {
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->{dbh}->prepare(<<EXISTS);
|
||||
SELECT
|
||||
COUNT(*)
|
||||
FROM
|
||||
pg_class c, pg_attribute a
|
||||
WHERE
|
||||
a.attrelid = c.oid AND
|
||||
c.relkind = 'r' AND a.attnum > 0 AND
|
||||
c.relname = ? AND a.attname = ?
|
||||
EXISTS
|
||||
$sth->execute(lc $table, lc $column);
|
||||
|
||||
return scalar $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub _prepare_show_tables {
|
||||
# -----------------------------------------------------------------------------
|
||||
# pg-specific 'SHOW TABLES'-equivelant
|
||||
#
|
||||
<<' QUERY';
|
||||
SELECT relname AS tables
|
||||
FROM pg_class
|
||||
WHERE relkind = 'r' AND NOT (relname LIKE 'pg_%' OR relname LIKE 'sql_%')
|
||||
ORDER BY relname
|
||||
QUERY
|
||||
}
|
||||
|
||||
sub _prepare_show_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Get index list
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
unless ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query");
|
||||
}
|
||||
<<" QUERY";
|
||||
SELECT
|
||||
c.relname AS index_name,
|
||||
attname AS index_column,
|
||||
CASE WHEN indisunique = 't' THEN 1 ELSE 0 END AS index_unique,
|
||||
CASE WHEN indisprimary = 't' THEN 1 ELSE 0 END AS index_primary
|
||||
FROM
|
||||
pg_index i,
|
||||
pg_class c,
|
||||
pg_class t,
|
||||
pg_attribute a
|
||||
WHERE
|
||||
i.indexrelid = c.oid AND
|
||||
a.attrelid = c.oid AND
|
||||
i.indrelid = t.oid AND
|
||||
t.relname = '\L$1\E'
|
||||
ORDER BY
|
||||
i.indexrelid, a.attnum
|
||||
QUERY
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Drops the table passed in - drops a sequence if needed. Takes a second
|
||||
# argument that, if true, causes the sequence _not_ to be dropped - used when
|
||||
# the table is being recreated.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $sth = $self->{dbh}->prepare("SELECT relname FROM pg_class WHERE relkind = 'S' AND relname = '\L$table\E_seq'");
|
||||
$sth->execute();
|
||||
if (my $seq_name = $sth->fetchrow) {
|
||||
$self->do("DROP SEQUENCE $seq_name")
|
||||
or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq_name", $GT::SQL::error);
|
||||
}
|
||||
return $self->SUPER::drop_table($table);
|
||||
}
|
||||
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a column from a table.
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
|
||||
my $ver = $self->_version();
|
||||
|
||||
# Postgresql 7.3 and above support ALTER TABLE $table DROP $column
|
||||
return $self->SUPER::drop_column($table, $column) if $ver and $ver >= 7.03;
|
||||
|
||||
$self->_recreate_table();
|
||||
}
|
||||
|
||||
$COMPILE{_recreate_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _recreate_table {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Adds/removes/changes a column, but very expensively as it involves recreating
|
||||
# and copying the entire table. Takes argument pairs, currently:
|
||||
#
|
||||
# with => 'adding_this_column' # optional
|
||||
#
|
||||
# Keep in mind that the various columns depend on the {cols} hash of the table
|
||||
# having been updated to reflect the change.
|
||||
#
|
||||
# We absolutely require DBI 1.20 in this subroutine for transaction support.
|
||||
# However, we won't get here if using PG >= 7.3, so you can have either an
|
||||
# outdated PG, or an outdated DBI, but not both.
|
||||
#
|
||||
my ($self, %opts) = @_;
|
||||
|
||||
DBI->require_version(1.20);
|
||||
my $ver = $self->_version;
|
||||
|
||||
my $table = $self->{name} or $self->fatal(BADARGS => 'No table specified');
|
||||
|
||||
my $cols = $self->{schema}->{cols};
|
||||
my %pos = map { $_ => $cols->{$_}->{pos} } keys %$cols;
|
||||
|
||||
my (@copy_cols, @select_cols);
|
||||
for (keys %$cols) {
|
||||
push @copy_cols, "$_ " . $self->column_sql($cols->{$_});
|
||||
push @select_cols, $_;
|
||||
}
|
||||
|
||||
if ($opts{with}) { # a column was added, so we can't select it from the old table
|
||||
@select_cols = grep $_ ne $opts{with}, @select_cols;
|
||||
}
|
||||
|
||||
$self->{dbh}->begin_work;
|
||||
|
||||
my $temptable = "GTTemp" . substr(time, -4) . int rand 10000;
|
||||
my $select_cols = join ', ', @select_cols;
|
||||
my $lock = "LOCK TABLE $table";
|
||||
my $createtemp = "CREATE TABLE $temptable AS SELECT * FROM $table";
|
||||
|
||||
my $insert = "INSERT INTO $table ( $select_cols ) SELECT $select_cols FROM $temptable";
|
||||
my $drop_temp = "DROP TABLE $temptable";
|
||||
|
||||
for my $precreate ($lock, $createtemp) {
|
||||
unless ($self->{dbh}->do($precreate)) {
|
||||
$self->warn(CANTEXECUTE => $precreate => $DBI::errstr);
|
||||
$self->{dbh}->rollback;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
unless ($self->drop_table($table)) {
|
||||
$self->{dbh}->rollback;
|
||||
return undef;
|
||||
}
|
||||
|
||||
unless ($self->create_table) {
|
||||
$self->{dbh}->rollback;
|
||||
return undef;
|
||||
}
|
||||
|
||||
for my $postcreate ($insert, $drop_temp) {
|
||||
unless ($self->{dbh}->do($postcreate)) {
|
||||
$self->warn(CANTEXECUTE => $postcreate => $DBI::errstr);
|
||||
$self->{dbh}->rollback;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
$self->{dbh}->commit;
|
||||
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub alter_column {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Changes a column in a table. The actual path done depends on multiple
|
||||
# things, including your version of postgres. The following are supported
|
||||
# _without_ recreating the table; anything more complicated requires the table
|
||||
# be recreated via _recreate_table().
|
||||
#
|
||||
# - changing/dropping a default, with >= 7.0 (doesn't require DBI >= 1.20,
|
||||
# everything else does)
|
||||
# - adding/dropping a not null contraint, with >= 7.3
|
||||
# - any other changes, with >= 7.3, by adding a new column, copying data into
|
||||
# it, dropping the old column
|
||||
#
|
||||
# Anything else calls _recreate_table(), which also requires DBI 1.20, but is
|
||||
# much more involved as the table has to be dropped and recreated.
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
|
||||
my $ver = $self->_version;
|
||||
return $self->_recreate_table() if $ver < 7;
|
||||
|
||||
my $cols = $self->{schema}->{cols};
|
||||
my $new_col = $cols->{$column};
|
||||
|
||||
my @onoff = qw/not_null/; # true/false attributes
|
||||
my @changeable = qw/default size scale precision/; # changeable attributes
|
||||
my %add = map { ($new_col->{$_} and not $old_col->{$_}) ? ($_ => 1) : () } @onoff;
|
||||
my %rem = map { ($old_col->{$_} and not $new_col->{$_}) ? ($_ => 1) : () } @onoff;
|
||||
my %change = map { (
|
||||
exists $new_col->{$_} and exists $old_col->{$_} # exists in both old and new
|
||||
and (
|
||||
defined($new_col->{$_}) ne defined($old_col->{$_}) # one is undef, the other isn't
|
||||
or
|
||||
defined $new_col->{$_} and defined $old_col->{$_} and $new_col->{$_} ne $old_col->{$_} # both are defined, but !=
|
||||
)
|
||||
) ? ($_ => 1) : () } @changeable;
|
||||
|
||||
{
|
||||
my %add_changeable = map { (exists $new_col->{$_} and not exists $old_col->{$_}) ? ($_ => 1) : () } @changeable;
|
||||
my %rem_changeable = map { (exists $old_col->{$_} and not exists $new_col->{$_}) ? ($_ => 1) : () } @changeable;
|
||||
%add = (%add, %add_changeable);
|
||||
%rem = (%rem, %rem_changeable);
|
||||
}
|
||||
|
||||
if ($ver < 7.03) {
|
||||
# In 7.0 - 7.2, defaults can be added/dropped/changed, but anything
|
||||
# more complicated needs a table recreation
|
||||
if (
|
||||
keys %change == 1 and exists $change{default} and not keys %add and not keys %rem # Changed a default
|
||||
or keys %add == 1 and exists $add{default} and not keys %change and not keys %rem # Added a default
|
||||
or keys %rem == 1 and exists $rem{default} and not keys %change and not keys %add # Dropped a default
|
||||
) {
|
||||
my $query = "ALTER TABLE $table ALTER COLUMN $column ";
|
||||
my $ph;
|
||||
if ($add{default} or $change{default}) {
|
||||
$query .= "SET DEFAULT ?";
|
||||
$ph = $new_col->{default};
|
||||
}
|
||||
else {
|
||||
$query .= "DROP DEFAULT";
|
||||
}
|
||||
$self->{dbh}->do($query, defined $ph ? (undef, $ph) : ())
|
||||
or return $self->warn(CANTEXECUTE => $query => $DBI::errstr);
|
||||
return 1;
|
||||
}
|
||||
return $self->_recreate_table();
|
||||
}
|
||||
|
||||
# PG 7.3 or later
|
||||
|
||||
if (
|
||||
keys %rem == 1 and $rem{not_null} and not keys %add and not keys %change # DROP NOT NULL
|
||||
or keys %add == 1 and $add{not_null} and not keys %rem and not keys %change # SET NOT NULL
|
||||
) {
|
||||
# All we're doing is changing a not_null constraint
|
||||
my $query = "ALTER TABLE $table ALTER COLUMN $column ";
|
||||
$query .= $rem{not_null} ? 'DROP' : 'SET';
|
||||
$query .= ' NOT NULL';
|
||||
$self->{dbh}->do($query)
|
||||
or return $self->warn(CANTEXECUTE => $query => $DBI::errstr);
|
||||
return 1;
|
||||
}
|
||||
|
||||
if (keys(%change) - ($change{default} ? 1 : 0) - (($ver >= 8 and $change{type}) ? 1 : 0) == 0 # No changes other than 'default' (and type, for PG >= 8)
|
||||
and keys(%add) - ($add{default} ? 1 : 0) - ($add{not_null} ? 1 : 0) == 0 # No adds other than default or not_null
|
||||
and keys(%rem) - ($rem{default} ? 1 : 0) - ($rem{not_null} ? 1 : 0) == 0 # No rems other than default or not_null
|
||||
) {
|
||||
my @query;
|
||||
# Change type (PG 8+ only)
|
||||
if ($ver >= 8 and $change{type}) {
|
||||
push @query, "ALTER TABLE $table ALTER COLUMN $column TYPE $new_col->{type}";
|
||||
}
|
||||
|
||||
# Change default
|
||||
if ($add{default} or $change{default}) {
|
||||
push @query, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $new_col->{default}];
|
||||
}
|
||||
elsif ($rem{default}) {
|
||||
push @query, "ALTER TABLE $table ALTER COLUMN $column DROP DEFAULT";
|
||||
}
|
||||
|
||||
# Change not_null
|
||||
if ($rem{not_null}) {
|
||||
push @query, "ALTER TABLE $table ALTER COLUMN $column DROP NOT NULL";
|
||||
}
|
||||
elsif ($add{not_null}) {
|
||||
if ($add{default}) {
|
||||
push @query, ["UPDATE $table SET $column = ? WHERE $column IS NULL", $new_col->{default}];
|
||||
}
|
||||
push @query, "ALTER TABLE $table ALTER COLUMN $column SET NOT NULL";
|
||||
}
|
||||
|
||||
return $self->do_raw_transaction(@query);
|
||||
}
|
||||
|
||||
# We've got more complex changes than PG's ALTER COLUMN can handle; we need
|
||||
# to add a new column, copy the data, drop the old column, and rename the
|
||||
# new one to the old name.
|
||||
my (@queries, %index, %unique);
|
||||
|
||||
push @queries, "LOCK TABLE $table";
|
||||
my %add_def = %$new_col;
|
||||
my $not_null = delete $add_def{not_null};
|
||||
my $default = delete $add_def{default};
|
||||
my $add_def = $self->column_sql(\%add_def);
|
||||
my $tmpcol = 'GTTemp' . substr(time, -4) . int(rand 10000);
|
||||
push @queries, "ALTER TABLE $table ADD COLUMN $tmpcol $add_def";
|
||||
push @queries, "UPDATE $table SET $tmpcol = $column";
|
||||
push @queries, ["UPDATE $table SET $tmpcol = ? WHERE $tmpcol IS NULL", $default] if $add{not_null} and defined $default;
|
||||
push @queries, ["ALTER TABLE $table ALTER COLUMN $tmpcol SET DEFAULT ?", $default] if defined $default;
|
||||
push @queries, "ALTER TABLE $table ALTER COLUMN $tmpcol SET NOT NULL" if $not_null;
|
||||
push @queries, "ALTER TABLE $table DROP COLUMN $column";
|
||||
push @queries, "ALTER TABLE $table RENAME COLUMN $tmpcol TO $column";
|
||||
|
||||
for my $type (qw/index unique/) {
|
||||
while (my ($index, $columns) = each %{$new_col->{$type}}) {
|
||||
my $recreate;
|
||||
for (@$columns) {
|
||||
if ($_ eq $column) {
|
||||
$recreate = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
next unless $recreate;
|
||||
if ($type eq 'index') {
|
||||
$index{$index} = $columns;
|
||||
}
|
||||
else {
|
||||
$unique{$index} = $columns;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$self->do_raw_transaction(@queries);
|
||||
|
||||
while (my ($index, $columns) = each %index) {
|
||||
$self->create_index($table, $index, @$columns);
|
||||
}
|
||||
while (my ($index, $columns) = each %unique) {
|
||||
$self->create_unique($table, $index, @$columns);
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub add_column {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Adds a new column to the table.
|
||||
#
|
||||
my ($self, $table, $column, $def) = @_;
|
||||
|
||||
# make a copy so the original reference doesn't get clobbered
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
|
||||
# Defaults and not_null have to be set _after_ adding the column.
|
||||
my $default = delete $col{default};
|
||||
my $not_null = delete $col{not_null};
|
||||
|
||||
my $ver = $self->_version;
|
||||
|
||||
return $self->_recreate_table(with => $column)
|
||||
if $ver < 7 and defined $default or $ver < 7.03 and $not_null;
|
||||
|
||||
my @queries;
|
||||
|
||||
if (defined $default or $not_null) {
|
||||
$def = $self->column_sql(\%col);
|
||||
}
|
||||
|
||||
push @queries, ["ALTER TABLE $table ADD $column $def"];
|
||||
|
||||
push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $default] if defined $default;
|
||||
push @queries, ["UPDATE $table SET $column = ?", $default] if defined $default and $not_null;
|
||||
push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET NOT NULL"] if $not_null;
|
||||
|
||||
$self->do_raw_transaction(@queries);
|
||||
}
|
||||
|
||||
sub create_pk {
|
||||
my ($self, $table, @cols) = @_;
|
||||
my $ver = $self->_version;
|
||||
if ($ver < 7.2) {
|
||||
return $self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(',', @cols) . ")");
|
||||
}
|
||||
else {
|
||||
# ALTER TABLE ... ADD PRIMARY KEY (...) was added in PG 7.2 - on prior
|
||||
# versions we have to recreate the entire table.
|
||||
return $self->_recreate_table();
|
||||
}
|
||||
}
|
||||
|
||||
sub drop_pk {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Drop a primary key. Look for the primary key, then call drop_index with it.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $sth = $self->prepare("SHOW INDEX FROM $table") or return;
|
||||
$sth->execute or return;
|
||||
my $pk_name;
|
||||
while (my $index = $sth->fetchrow_hashref) {
|
||||
if ($index->{index_primary}) {
|
||||
$pk_name = $index->{index_name};
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
$pk_name or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table");
|
||||
|
||||
$self->do("ALTER TABLE $table DROP CONSTRAINT $pk_name");
|
||||
}
|
||||
|
||||
sub ai_insert {
|
||||
my ($self, $ai) = @_;
|
||||
return $ai, "NEXTVAL('$self->{name}_seq')";
|
||||
}
|
||||
|
||||
sub insert_multiple {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Performs multiple insertions in a single transaction, for much better speed.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# ->begin_work and ->commit were not added until 1.20
|
||||
return $self->SUPER::insert_multiple(@_) if $DBI::VERSION < 1.20;
|
||||
|
||||
$self->{dbh}->begin_work;
|
||||
my ($cols, $args) = @_;
|
||||
|
||||
my $names = join ",", @$cols, $self->{schema}->{ai} || ();
|
||||
|
||||
my $ret;
|
||||
my $ai_insert = $self->{schema}->{ai} ? "NEXTVAL('$self->{name}_seq')" : undef;
|
||||
|
||||
my $query = "INSERT INTO $self->{name} ($names) VALUES (" . join(',', ('?') x @$cols, $ai_insert || ()) . ')';
|
||||
my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query);
|
||||
for (@$args) {
|
||||
if ($sth->execute(@$_)) {
|
||||
++$ret;
|
||||
}
|
||||
else {
|
||||
$self->warn(CANTEXECUTE => $query);
|
||||
}
|
||||
}
|
||||
$self->{dbh}->commit;
|
||||
$ret;
|
||||
}
|
||||
|
||||
sub quote {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This subroutines quotes (or not) a value. Postgres can't handle any text
|
||||
# fields containing null characters, so this has to go beyond the ordinary
|
||||
# quote() in GT::SQL::Driver by stripping out null characters.
|
||||
#
|
||||
my $val = pop;
|
||||
return 'NULL' if not defined $val;
|
||||
return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE';
|
||||
$val =~ y/\x00//d;
|
||||
(values %GT::SQL::Driver::CONN)[0]->quote($val);
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::PG::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE/;
|
||||
use GT::SQL::Driver;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Retrieves the current sequence.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i;
|
||||
$table ||= $self->{name};
|
||||
|
||||
my $query = "SELECT CURRVAL('${table}_seq')";
|
||||
my $sth = $self->{dbh}->prepare($query) or return $self->fatal(CANTPREPARE => $query => $DBI::errstr);
|
||||
$sth->execute or return $self->fatal(CANTEXECUTE => $query => $DBI::errstr);
|
||||
my $id = $sth->fetchrow;
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------ #
|
||||
# DATA TYPE MAPPINGS
|
||||
# ------------------------------------------------------------------------------------------------ #
|
||||
package GT::SQL::Driver::PG::Types;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use Carp qw/croak/;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
sub DATETIME { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') }
|
||||
sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') }
|
||||
sub TIME { $_[0]->base($_[1], 'TIME WITHOUT TIME ZONE') }
|
||||
sub YEAR { croak "PostgreSQL does not support 'YEAR' columns" }
|
||||
|
||||
# Postgres doesn't have BLOB's, but has a binary 'BYTEA' type - the one (big)
|
||||
# caveat to this type, however, is that it requires escaping for any input, and
|
||||
# unescaping for any output.
|
||||
|
||||
1;
|
||||
191
site/glist/lib/GT/SQL/Driver/Types.pm
Normal file
191
site/glist/lib/GT/SQL/Driver/Types.pm
Normal file
@@ -0,0 +1,191 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::Types
|
||||
# CVS Info :
|
||||
# $Id: Types.pm,v 2.1 2004/09/07 20:56:59 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements subroutines for each type to convert into SQL string.
|
||||
# See GT::SQL::Types for documentation
|
||||
#
|
||||
# Supported types are:
|
||||
# TINYINT SMALLINT MEDIUMINT INT INTEGER BIGINT - 8, 16, 24, 32, 32, 64 bits
|
||||
# REAL FLOAT DOUBLE - 32, 32, 64 bits
|
||||
# DECIMAL - decimal precision
|
||||
# DATE DATETIME TIMESTAMP TIME YEAR - for storing dates/times/etc.
|
||||
# CHAR VARCHAR - 1-255 characters, CHAR typically takes a fixed amount of space
|
||||
# TEXT - up to 2GB-1 text data; takes a 'size' parameter which /may/ change to smaller type
|
||||
# TINYTEXT SMALLTEXT MEDIUMTEXT LONGTEXT - TEXT with 255, 64KB-1, 16MB-1, 2GB-1 size values, respectively
|
||||
# TINYBLOB BLOB MEDIUMBLOB LONGBLOB - Heavily deprecrated, somewhat-binary data types with 255, 65535, 16777215, 2GB sizes
|
||||
# ENUM - MySQL-only type, implemented as CHAR by everything else; discouraged for portability reasons.
|
||||
# FILE - GT::SQL pseudo-type
|
||||
|
||||
package GT::SQL::Driver::Types;
|
||||
use vars qw/$VERSION @EXPORT_OK $ERROR_MESSAGE @ISA/;
|
||||
use strict;
|
||||
use Exporter();
|
||||
use GT::Base();
|
||||
|
||||
*import = \&Exporter::import;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = 'GT::Base';
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/;
|
||||
@EXPORT_OK = qw/base/;
|
||||
|
||||
sub base {
|
||||
# ------------------------------------------------------------------
|
||||
# Base function takes care of most of the types that don't require
|
||||
# much special formatting.
|
||||
#
|
||||
my ($class, $args, $name, $attribs) = @_;
|
||||
$attribs ||= [];
|
||||
my $out = $name;
|
||||
for my $attrib (@$attribs) {
|
||||
$out .= ' ' . $attrib if $args->{$attrib};
|
||||
}
|
||||
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
|
||||
$out .= ' NOT NULL' if $args->{not_null};
|
||||
$out;
|
||||
}
|
||||
|
||||
# Integers. None of the following are supported by Oracle, which can only
|
||||
# define integer types by the number of digits supported (see
|
||||
# GT/SQL/Driver/ORACLE.pm), and TINYINT and MEDIUMINT are only supported by
|
||||
# MySQL (though MS SQL will use it's unsigned TINYINT type if the unsigned
|
||||
# attribute is also passed in). All int types are signed - an 'unsigned'
|
||||
# column attribute can be used to /suggest/ that the integer type be unsigned -
|
||||
# but it is only for some databases and/or INT types, and so not guaranteed.
|
||||
sub TINYINT { $_[0]->base($_[1], 'SMALLINT') } # 8-bit int
|
||||
sub SMALLINT { $_[0]->base($_[1], 'SMALLINT') } # 16-bit int
|
||||
sub MEDIUMINT { $_[0]->base($_[1], 'INT') } # 24-bit int
|
||||
sub INT { $_[0]->base($_[1], 'INT') } # 32-bit int
|
||||
sub BIGINT { $_[0]->base($_[1], 'BIGINT') } # 64-bit int
|
||||
|
||||
sub INTEGER { $_[0]->INT($_[1]) } # alias for INT, above
|
||||
|
||||
# Floating point numbers
|
||||
sub DOUBLE { $_[0]->base($_[1], 'DOUBLE PRECISION') } # 64-bit float (52 bit precision)
|
||||
sub REAL { $_[0]->base($_[1], 'REAL') } # 32-bit float (23 bit precision), despite what MySQL thinks
|
||||
sub FLOAT { $_[0]->REAL($_[1]) } # alias for REAL
|
||||
|
||||
sub DECIMAL {
|
||||
# ------------------------------------------------------------------
|
||||
# Takes care of DECIMAL's precision.
|
||||
#
|
||||
my ($class, $args, $out, $attribs) = @_;
|
||||
$out ||= 'DECIMAL';
|
||||
$attribs ||= [];
|
||||
|
||||
# 'scale' and 'precision' are the proper names, but a prior version used
|
||||
# the unfortunate 'display' and 'decimal' names, which have no relevant
|
||||
# meaning in SQL.
|
||||
my $scale = defined $args->{scale} ? $args->{scale} : defined $args->{decimal} ? $args->{decimal} : undef;
|
||||
my $precision = defined $args->{precision} ? $args->{precision} : defined $args->{display} ? $args->{display} : undef;
|
||||
|
||||
$scale ||= 0;
|
||||
$precision ||= 10;
|
||||
|
||||
$out .= "($precision, $scale)";
|
||||
|
||||
for my $attrib (@$attribs) {
|
||||
$out .= ' ' . $attrib if $args->{$attrib};
|
||||
}
|
||||
defined $args->{default} and $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default});
|
||||
$args->{not_null} and $out .= ' NOT NULL';
|
||||
return $out;
|
||||
}
|
||||
|
||||
# Dates - just about every database seems to do things differently here.
|
||||
sub DATE { $_[0]->base($_[1], 'DATE') }
|
||||
sub DATETIME { $_[0]->base($_[1], 'DATETIME') }
|
||||
sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP') }
|
||||
sub TIME { $_[0]->base($_[1], 'TIME') }
|
||||
sub YEAR { $_[0]->base($_[1], 'YEAR') }
|
||||
|
||||
# Everything (even Oracle) supports CHAR for sizes from 1 to at least 255.
|
||||
# Everything except Oracle handles VARCHAR's - Oracle, having deprecated
|
||||
# VARCHAR's, uses VARCHAR2's. However, only MySQL supports the 'BINARY'
|
||||
# attribute to turn this into a "binary" char (meaning, really,
|
||||
# case-insensitive, not binary) - for everything else, a "binary" argument is
|
||||
# simply ignored.
|
||||
sub CHAR {
|
||||
my ($class, $args, $out) = @_;
|
||||
# Important the set the size before calling BINARY, because BINARY's
|
||||
# behaviour is different for sizes <= 255.
|
||||
$args->{size} = 255 unless $args->{size} and $args->{size} <= 255;
|
||||
|
||||
# See the CHAR notes in GT::SQL::Types regarding why we default to VARCHAR
|
||||
$out ||= 'VARCHAR';
|
||||
$out .= "($args->{size})";
|
||||
|
||||
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
|
||||
$out .= ' NOT NULL' if $args->{not_null};
|
||||
return $out;
|
||||
}
|
||||
sub VARCHAR { $_[0]->CHAR($_[1], 'VARCHAR') }
|
||||
|
||||
# By default, all TEXT types are mapped to 'TEXT'; drivers can override this to
|
||||
# provide different types based on the 'size' attribute.
|
||||
sub TEXT {
|
||||
my ($class, $attrib) = @_;
|
||||
$class->base($attrib, 'TEXT')
|
||||
}
|
||||
|
||||
# .+TEXT is for compatibility with old code, and should be considered
|
||||
# deprecated. Takes the args hash and the size desired.
|
||||
sub _OLD_TEXT {
|
||||
my ($class, $args, $size) = @_;
|
||||
$args = {$args ? %$args : ()};
|
||||
$args->{size} = $size unless $args->{size} and $args->{size} < $size;
|
||||
$class->TEXT($args);
|
||||
}
|
||||
sub TINYTEXT { $_[0]->_OLD_TEXT($_[1] => 255) }
|
||||
sub SMALLTEXT { $_[0]->_OLD_TEXT($_[1] => 65535) }
|
||||
sub MEDIUMTEXT { $_[0]->_OLD_TEXT($_[1] => 16777215) }
|
||||
sub LONGTEXT { $_[0]->_OLD_TEXT($_[1] => 2147483647) }
|
||||
|
||||
# The BLOB* columns below are heavily deprecated - they're still here just in
|
||||
# case someone is still using them. Storing binary data inside an SQL row is
|
||||
# generally a poor idea; a much better approach is to store a pointer to the
|
||||
# data (such as a filename) in the database, and the actual data in a file.
|
||||
#
|
||||
# As such, the default behaviour is to fatal if BLOB's are used - only drivers
|
||||
# that supported BLOB's prior to protocol v2 should override this. Should a
|
||||
# binary type be desired in the future, a 'BINARY' pseudo-type is recommended.
|
||||
sub BLOB {
|
||||
my ($driver) = $_[0] =~ /([^:]+)$/;
|
||||
$driver = $driver eq 'PG' ? 'Postgres' : $driver eq 'ORACLE' ? 'Oracle' : $driver eq 'MYSQL' ? 'MySQL' : $driver;
|
||||
$_[0]->fatal(DRIVERTYPE => $driver => 'BLOB')
|
||||
}
|
||||
sub TINYBLOB { $_[0]->BLOB($_[1], 'TINYBLOB') }
|
||||
sub MEDIUMBLOB { $_[0]->BLOB($_[1], 'MEDIUMBLOB') }
|
||||
sub LONGBLOB { $_[0]->BLOB($_[1], 'LONGBLOB') }
|
||||
|
||||
# Enums - a non-standard SQL type implemented only by MySQL - the default
|
||||
# implementation is to implement it as a CHAR (or TEXT if the longest value is
|
||||
# more than 255 characters - but in that case, are you really sure you want to
|
||||
# use this type?)
|
||||
sub ENUM {
|
||||
my ($class, $args) = @_;
|
||||
my $max = 0;
|
||||
@{$args->{'values'}} or return;
|
||||
for my $val (@{$args->{'values'}}) {
|
||||
my $len = length $val;
|
||||
$max = $len if $len > $max;
|
||||
}
|
||||
my $meth = $max > 255 ? 'TEXT' : 'CHAR';
|
||||
$class->$meth({ size => $max, default => $args->{default}, not_null => $args->{not_null} });
|
||||
}
|
||||
|
||||
# File handling
|
||||
sub FILE {
|
||||
my ($class, $args) = @_;
|
||||
$class->VARCHAR({ binary => 1, size => $args->{size}, not_null => $args->{not_null} });
|
||||
}
|
||||
|
||||
1;
|
||||
175
site/glist/lib/GT/SQL/Driver/debug.pm
Normal file
175
site/glist/lib/GT/SQL/Driver/debug.pm
Normal file
@@ -0,0 +1,175 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::debug
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: debug.pm,v 2.0 2004/08/28 03:51:31 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# GT::SQL::Driver debugging module
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::debug;
|
||||
use strict;
|
||||
|
||||
use strict;
|
||||
use GT::AutoLoader;
|
||||
use vars qw/$LAST_QUERY @QUERY_STACK @STACK_TRACE $QUERY_STACK_SIZE @ISA/;
|
||||
@ISA = qw(GT::Base);
|
||||
$QUERY_STACK_SIZE = 100;
|
||||
|
||||
$COMPILE{last_query} = __LINE__ . <<'END_OF_SUB';
|
||||
sub last_query {
|
||||
# -------------------------------------------------------------------
|
||||
# Get, or set the last query.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->error('NEEDDEBUG', 'WARN') if (! $self->{_debug});
|
||||
|
||||
@_ > 0 or return $LAST_QUERY || '';
|
||||
|
||||
$LAST_QUERY = shift;
|
||||
$LAST_QUERY = GT::SQL::Driver::debug->replace_placeholders($LAST_QUERY, @_) if (@_);
|
||||
|
||||
# Display stack traces if requested via debug level.
|
||||
my $stack = '';
|
||||
if ($self->{_debug} > 2) {
|
||||
($stack, $LAST_QUERY) = js_stack(3, $LAST_QUERY);
|
||||
}
|
||||
elsif ($self->{_debug} > 1) {
|
||||
package DB;
|
||||
my $i = 2;
|
||||
my $ls = defined $ENV{REQUEST_METHOD} ? '<br>' : "\n";
|
||||
my $spc = defined $ENV{REQUEST_METHOD} ? ' ' : ' ';
|
||||
while (my ($file, $line, $sub, $args) = (caller($i++))[1,2,3,4]) {
|
||||
my @args;
|
||||
for (@DB::args) {
|
||||
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
|
||||
my $print = $@ ? \$_ : $_;
|
||||
push @args, defined $print ? $print : '[undef]';
|
||||
}
|
||||
if (@args) {
|
||||
my $args = join ", ", @args;
|
||||
$args =~ s/\n\s*\n/\n/g;
|
||||
$args =~ s/\n/\n$spc$spc$spc$spc/g;
|
||||
$stack .= qq!$sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!;
|
||||
}
|
||||
else {
|
||||
$stack .= qq!$sub called at $file line $line with no arguments.$ls!;
|
||||
}
|
||||
}
|
||||
}
|
||||
push @QUERY_STACK, $LAST_QUERY;
|
||||
push @STACK_TRACE, "<blockquote>\n" . $stack . "\n</blockquote>\n" if ($self->{_debug} and $stack);
|
||||
|
||||
# Pesistance such as Mod_Perl
|
||||
@QUERY_STACK > $QUERY_STACK_SIZE and shift @QUERY_STACK;
|
||||
@STACK_TRACE > $QUERY_STACK_SIZE and shift @STACK_TRACE;
|
||||
|
||||
return $LAST_QUERY || '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{js_stack} = __LINE__ . <<'END_OF_SUB';
|
||||
sub js_stack {
|
||||
# -------------------------------------------------------------------
|
||||
# Create a nicely formatted javascript browser that (unfortunately)
|
||||
# only works in ie, netscape sucks.
|
||||
#
|
||||
my ($sp, $title) = @_;
|
||||
|
||||
my $nb = @QUERY_STACK;
|
||||
my ($stack, $dump_out);
|
||||
{
|
||||
package DB;
|
||||
require GT::Dumper;
|
||||
my $i = 0;
|
||||
|
||||
while (my ($file, $line, $sub, $args) = (caller($sp++))[1,2,3,4]) {
|
||||
if (@DB::args) {
|
||||
$args = "with arguments<br> ";
|
||||
my @args;
|
||||
for (@DB::args) {
|
||||
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
|
||||
my $print = $@ ? \$_ : $_;
|
||||
my $arg = defined $print ? $print : '[undef]';
|
||||
|
||||
$args .= "<a href='#a$nb$i'>$arg</a>, ";
|
||||
my $dump = GT::Dumper::Dumper($arg);
|
||||
$dump_out .= qq~
|
||||
<a name="a$nb$i"></a>
|
||||
<a href="#top">Top</a>
|
||||
<pre>$dump</pre>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
chop $args; chop $args;
|
||||
}
|
||||
else {
|
||||
$args = "with no arguments";
|
||||
}
|
||||
$stack .= qq!<li>$sub called at $file line $line $args.<br></li>\n!;
|
||||
}
|
||||
}
|
||||
$stack =~ s/\\/\\\\/g;
|
||||
$stack =~ s/[\n\r]+/\\n/g;
|
||||
$stack =~ s/'/\\'/g;
|
||||
$stack =~ s,script,sc'+'ript,g;
|
||||
|
||||
$dump_out =~ s/\\/\\\\/g;
|
||||
$dump_out =~ s/[\n\r]+/\\n/g;
|
||||
|
||||
$dump_out =~ s/'/\\'/g;
|
||||
$dump_out =~ s,script,sc'+'ript,g;
|
||||
|
||||
my $var = <<HTML;
|
||||
<script language="JavaScript">
|
||||
function my$nb () {
|
||||
msg = window.open('','my$nb','resizable=yes,width=700,height=500,scrollbars=yes');
|
||||
msg.document.write('<html><body><a name="top"></a>STACK TRACE<BR><OL>$stack</OL>$dump_out</BODY></HTML>');
|
||||
msg.document.close();
|
||||
}
|
||||
HTML
|
||||
my $link = qq!<a href="javascript:my$nb();">$title</a><br>!;
|
||||
|
||||
return $var, $link;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{quick_quote} = __LINE__ . <<'END_OF_SUB';
|
||||
sub quick_quote {
|
||||
# -------------------------------------------------------------------
|
||||
# Quick quote to replace ' with \'.
|
||||
#
|
||||
my $str = shift;
|
||||
defined $str and ($str eq "") and return "''";
|
||||
$str =~ s/'/\\'/g;
|
||||
return $str;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{replace_placeholders} = __LINE__ . <<'END_OF_SUB';
|
||||
sub replace_placeholders {
|
||||
# -------------------------------------------------------------------
|
||||
# Replace question marks with the actual values
|
||||
#
|
||||
my ($self, $query, @args) = @_;
|
||||
if (@args > 0) {
|
||||
my @vals = split /('(?:[^']+|''|\\')')/, $query;
|
||||
VALUE: for my $val (@args) {
|
||||
SUBSTRING: for my $i (0 .. $#vals) {
|
||||
next SUBSTRING if $i % 2;
|
||||
next VALUE if $vals[$i] =~ s/\?/defined $val ? ( $val =~ m,\D, ? "'".quick_quote($val)."'" : quick_quote($val) ) : 'NULL'/e;
|
||||
}
|
||||
}
|
||||
$query = join '', @vals;
|
||||
}
|
||||
return $query;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
293
site/glist/lib/GT/SQL/Driver/sth.pm
Normal file
293
site/glist/lib/GT/SQL/Driver/sth.pm
Normal file
@@ -0,0 +1,293 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::sth
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: sth.pm,v 2.1 2004/09/30 01:09:46 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Generic statement handle wrapper
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::sth;
|
||||
use strict;
|
||||
use GT::Base;
|
||||
use GT::AutoLoader(NEXT => '_AUTOLOAD');
|
||||
require GT::SQL::Driver;
|
||||
use GT::SQL::Driver::debug;
|
||||
use vars qw(@ISA $AUTOLOAD $DEBUG $ERROR_MESSAGE);
|
||||
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::debug/;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
# Get rid of a 'used only once' warnings
|
||||
$DBI::errstr if 0;
|
||||
|
||||
sub new {
|
||||
# --------------------------------------------------------
|
||||
# Create a new driver sth.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $opts = {};
|
||||
my $self = bless {}, $class;
|
||||
|
||||
if (@_ == 1 and ref $_[0]) { $opts = shift }
|
||||
elsif (@_ and @_ % 2 == 0) { $opts = {@_} }
|
||||
else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)") }
|
||||
|
||||
$self->{_debug} = $opts->{_debug} || $DEBUG;
|
||||
$self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL';
|
||||
|
||||
# Drivers can set this to handle name case changing for fetchrow_hashref
|
||||
$self->{hints} = $opts->{hints} || {};
|
||||
|
||||
for (qw/dbh do query sth schema name _limit _lim_rows _lim_offset/) {
|
||||
$self->{$_} = $opts->{$_} if exists $opts->{$_};
|
||||
}
|
||||
$self->debug("OBJECT CREATED") if ($self->{_debug} > 2);
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{execute} = __LINE__ . <<'END_OF_SUB';
|
||||
sub execute {
|
||||
# --------------------------------------------------------
|
||||
# Execute the query.
|
||||
#
|
||||
my $self = shift;
|
||||
my $do = $self->{do};
|
||||
my $rc;
|
||||
|
||||
# Debugging, stack trace is printed if debug >= 2.
|
||||
my $time;
|
||||
if ($self->{_debug}) {
|
||||
$self->last_query($self->{query}, @_);
|
||||
my $stack = '';
|
||||
if ($self->{_debug} > 1) {
|
||||
$stack = GT::Base->stack_trace(1,1);
|
||||
$stack =~ s/<br>/\n /g;
|
||||
$stack =~ s/ / /g;
|
||||
$stack = "\n $stack\n"
|
||||
}
|
||||
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
|
||||
$self->debug("Executing query: $query$stack");
|
||||
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
|
||||
}
|
||||
if (my $meth = $GT::SQL::Driver::QUERY_MAP{$do}) {
|
||||
$meth = "_execute_$meth";
|
||||
$rc = $self->$meth(@_) or return;
|
||||
}
|
||||
else {
|
||||
$rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
}
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
$rc;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Define one generic execute, and alias all the specific _execute_* functions to it
|
||||
sub _generic_execute {
|
||||
my $self = shift;
|
||||
$self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
}
|
||||
for (*_execute_create, *_execute_insert, *_execute_alter, *_execute_select, *_execute_update, *_execute_drop, *_execute_delete, *_execute_describe, *_execute_show_tables, *_execute_show_index) {
|
||||
$_ = \&_generic_execute;
|
||||
}
|
||||
|
||||
sub rows {
|
||||
my $self = shift;
|
||||
return $self->{_rows} if exists $self->{_rows};
|
||||
return $self->{rows} if exists $self->{rows};
|
||||
$self->{sth}->rows;
|
||||
}
|
||||
|
||||
sub fetchrow_arrayref {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->{_results} or return $self->{sth}->fetchrow_arrayref;
|
||||
return shift @{$self->{_results}};
|
||||
}
|
||||
|
||||
sub fetchrow_array {
|
||||
# -----------------------------------------------------------------------------
|
||||
# When called in scalar context, returns either the first or last row, as per
|
||||
# DBI, so avoid using in scalar context when fetching more than one row.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{_results} or return $self->{sth}->fetchrow_array;
|
||||
my $arr = shift @{$self->{_results}};
|
||||
return $arr ? wantarray ? @$arr : $arr->[0] : ();
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# Alias for fetchrow_array (DBI code comments this as an "old" alias, and DBI's
|
||||
# documentation no longer mentions it at all).
|
||||
*fetchrow = \&fetchrow_array; *fetchrow if 0;
|
||||
|
||||
sub fetchrow_hashref {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->_fetchrow_hashref() if $self->{hints}->{case_map} or $self->{_results};
|
||||
$self->{sth}->fetchrow_hashref;
|
||||
}
|
||||
|
||||
$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _fetchrow_hashref {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Handles row fetching for driver that can't use the default ->fetchrow_hashref
|
||||
# due to needing column case mapping ($sth->{hints}->{case_map}), or special
|
||||
# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit
|
||||
# handling).
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my %case_map; # returnedname => ReturnedName, but only for columns that use upper case
|
||||
if ($self->{hints}->{case_map}) {
|
||||
if (exists $self->{schema}->{cols}) {
|
||||
my $cols = $self->{schema}->{cols};
|
||||
%case_map = map { lc $_ => $_ } keys %$cols;
|
||||
}
|
||||
else {
|
||||
for my $table (keys %{$self->{schema}}) {
|
||||
for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) {
|
||||
$case_map{lc $col} = $col;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($self->{_results}) {
|
||||
my $arr = shift @{$self->{_results}} or return;
|
||||
|
||||
my $i;
|
||||
my %selected = map { lc $_ => $i++ } @{$self->{_names}};
|
||||
my %hash;
|
||||
|
||||
for my $lc_col (keys %selected) {
|
||||
if (exists $case_map{$lc_col}) {
|
||||
$hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}];
|
||||
}
|
||||
else {
|
||||
$hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}];
|
||||
}
|
||||
}
|
||||
return \%hash;
|
||||
}
|
||||
else {
|
||||
my $h = $self->{sth}->fetchrow_hashref or return;
|
||||
for (keys %$h) {
|
||||
$h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_};
|
||||
}
|
||||
return $h;
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub fetchall_arrayref {
|
||||
# ---------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{sth}->fetchall_arrayref(@_) unless $self->{_results};
|
||||
|
||||
my $opt = shift;
|
||||
if ($opt and ref $opt eq 'HASH') {
|
||||
my @ret;
|
||||
while (my $row = $self->fetchrow_hashref) {
|
||||
for (keys %$row) {
|
||||
delete $row->{$_} unless exists $opt->{$_};
|
||||
}
|
||||
push @ret, $row;
|
||||
}
|
||||
return \@ret;
|
||||
}
|
||||
|
||||
my $results = $self->{_results};
|
||||
$self->{_results} = [];
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub fetchall_list { map @$_, @{shift->fetchall_arrayref} }
|
||||
|
||||
sub fetchall_hashref {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This is very different from DBI's fetchall_hashref - this is actually
|
||||
# equivelant to DBI's ->fetchall_arrayref({})
|
||||
#
|
||||
my $self = shift;
|
||||
my @results;
|
||||
while (my $hash = $self->fetchrow_hashref) {
|
||||
push @results, $hash;
|
||||
}
|
||||
return \@results;
|
||||
}
|
||||
|
||||
sub row_names {
|
||||
my $self = shift;
|
||||
$self->{_names} || $self->{sth}->{NAME};
|
||||
}
|
||||
|
||||
$COMPILE{insert_id} = __LINE__ . <<'END_OF_SUB';
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the value of the last record inserted.
|
||||
#
|
||||
return $_[0]->{sth}->{insertid};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub DESTROY {
|
||||
# -------------------------------------------------------------------
|
||||
# Calls finish on the row when it is destroyed.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->debug("OBJECT DESTROYED") if $self->{_debug} > 2;
|
||||
$self->{sth}->finish if ref $self->{sth} and $self->{sth}->can("finish");
|
||||
}
|
||||
|
||||
sub _AUTOLOAD {
|
||||
# -------------------------------------------------------------------
|
||||
# Autoloads any unknown methods to the DBI::st object.
|
||||
#
|
||||
my ($self, @param) = @_;
|
||||
my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/;
|
||||
|
||||
if (exists $DBI::st::{$attrib}) {
|
||||
local *code = $DBI::st::{$attrib};
|
||||
if (*code{CODE}) {
|
||||
$self->debug("Calling DBI::st::$attrib") if $self->{_debug} > 1;
|
||||
return code($self->{sth}, @param);
|
||||
}
|
||||
}
|
||||
|
||||
$GT::SQL::Driver::debug::AUTOLOAD = $AUTOLOAD;
|
||||
goto >::SQL::Driver::debug::AUTOLOAD;
|
||||
}
|
||||
|
||||
$COMPILE{debug} = __LINE__ . <<'END_OF_SUB';
|
||||
sub debug {
|
||||
# -------------------------------------------------------------------
|
||||
# DBI::st has a debug that autoload is catching.
|
||||
#
|
||||
my $self = shift;
|
||||
my $i = 1;
|
||||
my ( $package, $file, $line, $sub );
|
||||
while ( ( $package, $file, $line ) = caller($i++) ) {
|
||||
last if index( $package, 'GT::SQL' ) != 0;
|
||||
}
|
||||
while ( $sub = (caller($i++))[3] ) {
|
||||
last if index( $sub, 'GT::SQL' ) != 0;
|
||||
}
|
||||
return $self->SUPER::debug( "$_[0] from $sub at $file line $line\n" );
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
1080
site/glist/lib/GT/SQL/Editor.pm
Normal file
1080
site/glist/lib/GT/SQL/Editor.pm
Normal file
File diff suppressed because it is too large
Load Diff
1079
site/glist/lib/GT/SQL/File.pm
Normal file
1079
site/glist/lib/GT/SQL/File.pm
Normal file
File diff suppressed because it is too large
Load Diff
150
site/glist/lib/GT/SQL/Monitor.pm
Normal file
150
site/glist/lib/GT/SQL/Monitor.pm
Normal file
@@ -0,0 +1,150 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Monitor
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Monitor.pm,v 1.2 2005/04/18 22:10:09 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::SQL::Monitor;
|
||||
use strict;
|
||||
use vars qw/@EXPORT_OK $CSS/;
|
||||
use Carp qw/croak/;
|
||||
use GT::CGI qw/:escape/;
|
||||
require Exporter;
|
||||
@EXPORT_OK = qw/query/;
|
||||
|
||||
use constant CSS => <<'CSS';
|
||||
<style type="text/css">
|
||||
.sql_monitor td {
|
||||
border-bottom: 1px solid rgb(128, 128, 128);
|
||||
border-right: 1px solid rgb(128, 128, 128);
|
||||
padding: 2px;
|
||||
}
|
||||
.sql_monitor th {
|
||||
border-bottom: 2px solid rgb(128, 128, 128);
|
||||
border-right: 1px solid rgb(128, 128, 128);
|
||||
padding: 2px;
|
||||
}
|
||||
table.sql_monitor {
|
||||
border-collapse: collapse;
|
||||
border-left: 2px solid rgb(128, 128, 128);
|
||||
border-top: 2px solid rgb(128, 128, 128);
|
||||
border-bottom: 2px solid rgb(128, 128, 128);
|
||||
border-right: 2px solid rgb(128, 128, 128);
|
||||
}
|
||||
.sql_monitor pre {
|
||||
margin-bottom: 0px;
|
||||
margin-top: 0px;
|
||||
}
|
||||
</style>
|
||||
CSS
|
||||
|
||||
|
||||
sub query {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Handles the 'SQL Monitor' function of various Gossamer Threads products.
|
||||
# Takes a hash of options:
|
||||
# table - any GT::SQL table object
|
||||
# style - the style to use - 'tab', 'text' or 'html'; defaults to 'text'
|
||||
# html - ('tab' or 'text' mode) whether values should be SQL escaped and the whole thing surrouned by a <pre> tag
|
||||
# query - the query to run
|
||||
# css - if defined, the value will be used for the CSS in 'html' style; otherwise _css() is used
|
||||
# Returned is a hash reference containing:
|
||||
# db_prefix - the database prefix currently in use
|
||||
# style - the value of the 'style' option
|
||||
# query - the query performed
|
||||
# rows - the number of rows returned by the query, or possibly the number of rows affected
|
||||
# results - a scalar reference to the result of the query, if a SELECT/SHOW/sp_*
|
||||
# error - set to 1 if an error occured
|
||||
# error_connect - set to an error message if the database connection failed
|
||||
# error_prepare - set to an error message if the prepare failed
|
||||
# error_execute - set to an error message if the execute failed
|
||||
#
|
||||
my %opts = @_;
|
||||
|
||||
$opts{table} and $opts{query} or croak "query() called without table and/or query options";
|
||||
|
||||
$opts{table}->connect or return { error => 1, error_connect => $GT::SQL::error };
|
||||
|
||||
my %ret = (
|
||||
db_prefix => $opts{table}->{connect}->{PREFIX},
|
||||
pretty_style => $opts{pretty_style},
|
||||
query => $opts{query}
|
||||
);
|
||||
|
||||
my $sth = $opts{table}->prepare($opts{query}) or return { %ret, error => 1, error_prepare => $GT::SQL::error };
|
||||
my $rv = $sth->execute or return { %ret, error => 1, error_execute => $GT::SQL::error };
|
||||
|
||||
my $names = $sth->row_names;
|
||||
|
||||
$ret{rows} = $sth->rows || 0;
|
||||
|
||||
if ($opts{query} =~ /^\s*(SELECT|DESCRIBE|SHOW|sp_)/i) {
|
||||
my $table = '';
|
||||
my $data = $sth->fetchall_arrayref;
|
||||
if ($opts{style} and $opts{style} eq 'html') {
|
||||
$table .= defined $opts{css} ? $opts{css} : CSS;
|
||||
$table .= qq|<table class="sql_monitor">\n|;
|
||||
$table .= " <tr>\n";
|
||||
$table .= join '', map ' <th><pre>' . html_escape($_) . "</pre></th>\n",
|
||||
@$names;
|
||||
$table .= " </tr>\n";
|
||||
for (@$data) {
|
||||
$table .= " <tr>\n";
|
||||
for (@$_) {
|
||||
my $val = html_escape($_);
|
||||
$val .= "<br />" unless $val =~ /\S/;
|
||||
$table .= qq| <td><pre>$val</pre></td>\n|;
|
||||
}
|
||||
$table .= " </tr>\n";
|
||||
}
|
||||
$table .= "</table>";
|
||||
}
|
||||
elsif ($opts{style} and $opts{style} eq 'tabs') {
|
||||
$table = $opts{html} ? '<pre>' : '';
|
||||
for (@$data) {
|
||||
$table .= join("\t", $opts{html} ? (map html_escape($_), @$_) : @$_) . "\n";
|
||||
}
|
||||
$table .= "</pre>" if $opts{html};
|
||||
}
|
||||
else { # style = 'text'
|
||||
$table = $opts{html} ? '<pre>' : '';
|
||||
my @max_width = (0) x @$names;
|
||||
for ($names, @$data) {
|
||||
for my $i (0 .. $#$_) {
|
||||
my $width = length $_->[$i];
|
||||
$max_width[$i] = $width if $width > $max_width[$i];
|
||||
}
|
||||
}
|
||||
$table = $opts{html} ? '<pre>' : '';
|
||||
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
|
||||
$table .= '|';
|
||||
for my $i (0 .. $#$names) {
|
||||
$table .= sprintf " %-$max_width[$i]s |", $opts{html} ? html_escape($names->[$i]) : $names->[$i];
|
||||
}
|
||||
$table .= " \n";
|
||||
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
|
||||
for (@$data) {
|
||||
$table .= '|';
|
||||
for my $i (0 .. $#$names) {
|
||||
$table .= sprintf " %-$max_width[$i]s |", $opts{html} ? html_escape($_->[$i]) : $_->[$i];
|
||||
}
|
||||
$table .= " \n";
|
||||
}
|
||||
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
|
||||
$table .= $opts{html} ? '</pre>' : '';
|
||||
}
|
||||
$ret{results} = \$table;
|
||||
}
|
||||
else {
|
||||
$ret{results} = "Rows affected: $ret{rows}";
|
||||
}
|
||||
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
1897
site/glist/lib/GT/SQL/Relation.pm
Normal file
1897
site/glist/lib/GT/SQL/Relation.pm
Normal file
File diff suppressed because it is too large
Load Diff
584
site/glist/lib/GT/SQL/Search.pm
Normal file
584
site/glist/lib/GT/SQL/Search.pm
Normal file
@@ -0,0 +1,584 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Search.pm,v 1.60 2004/08/28 03:53:43 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# highlevel class for searching, works with GT::SQL::Indexer
|
||||
#
|
||||
|
||||
package GT::SQL::Search;
|
||||
#--------------------------------------------------------------------------------
|
||||
|
||||
# pragmas
|
||||
use strict;
|
||||
use vars qw/@ISA $ERRORS $ERROR_MESSAGE $VERSION/;
|
||||
|
||||
# includes
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
|
||||
# variables
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.60 $ =~ /(\d+)\.(\d+)/;
|
||||
@ISA = qw(GT::Base);
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$ERRORS = {
|
||||
UNKNOWNDRIVER => 'Unknown driver requested: %s',
|
||||
NOTABLE => 'Cannot find reference to table object'
|
||||
};
|
||||
|
||||
sub load_search {
|
||||
#--------------------------------------------------------------------------------
|
||||
# checks if there is driver for this current database and if so, loads that
|
||||
# instead (since it would be faster)
|
||||
#
|
||||
my $class = shift;
|
||||
my $opts = ref $_[0] ? $_[0] : {@_};
|
||||
$opts->{mode} = 'Search';
|
||||
my $driver = $class->load_driver( $opts ) or return;
|
||||
my $pkg = "GT::SQL::Search::${driver}::Search";
|
||||
return $pkg->load(@_);
|
||||
}
|
||||
|
||||
sub load_indexer {
|
||||
#--------------------------------------------------------------------------------
|
||||
# checks if there is driver for this current database and if so, loads that
|
||||
# instead (since it would be faster)
|
||||
#
|
||||
my $class = shift;
|
||||
my $opts = ref $_[0] ? $_[0] : {@_};
|
||||
$opts->{mode} = 'Indexer';
|
||||
my $driver = $class->load_driver( $opts ) or return;
|
||||
my $pkg = "GT::SQL::Search::${driver}::Indexer";
|
||||
|
||||
return $pkg->load(@_);
|
||||
}
|
||||
|
||||
sub driver_ok {
|
||||
#--------------------------------------------------------------------------------
|
||||
# checks to see if a particular driver is allowed on this system
|
||||
#
|
||||
my $class = shift;
|
||||
my $driver = uc shift or return;
|
||||
my $opts = ref $_[0] ? $_[0] : {@_};
|
||||
my $mode = $opts->{mode} || 'Indexer';
|
||||
my $tbl = $opts->{table} or return GT::SQL::Search->error( 'NOTABLE', 'FATAL' );
|
||||
my $pkg = 'GT::SQL::Search::' . $driver . '::' . $mode;
|
||||
|
||||
eval { require "GT/SQL/Search/$driver/$mode.pm" };
|
||||
$@ and return GT::SQL::Search->error('UNKNOWNDRIVER', 'WARN', $driver);
|
||||
return $pkg->can('ok') ? $pkg->ok($tbl) : 1;
|
||||
}
|
||||
|
||||
sub load_driver {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Loads a driver into memory.
|
||||
#
|
||||
my $class = shift;
|
||||
my $opts = ref $_[0] ? $_[0] : {@_};
|
||||
my $tbl = $opts->{table};
|
||||
my $mode = $opts->{mode} || 'Indexer';
|
||||
my $driver = uc($opts->{driver} || $tbl->{schema}->{search_driver} || 'NONINDEXED');
|
||||
|
||||
require "GT/SQL/Search/$driver/$mode.pm";
|
||||
return $driver;
|
||||
}
|
||||
|
||||
sub available_drivers {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Returns a list of available drivers.
|
||||
#
|
||||
my $class = shift;
|
||||
|
||||
(my $path = $INC{'GT/SQL/Search.pm'}) =~ s/\.pm$//;
|
||||
opendir DHANDLE, $path or return $class->fatal(CANTOPENDIR => $path, "$!");
|
||||
my @arr;
|
||||
for my $driver_name (readdir DHANDLE) {
|
||||
next if $driver_name =~ y/a-z//;
|
||||
-f "$path/$driver_name/Search.pm" and -r _ or next;
|
||||
-f "$path/$driver_name/Indexer.pm" and -r _ or next;
|
||||
my $loaded = eval {
|
||||
require "GT/SQL/Search/$driver_name/Search.pm";
|
||||
require "GT/SQL/Search/$driver_name/Indexer.pm";
|
||||
};
|
||||
push @arr, $driver_name if $loaded;
|
||||
}
|
||||
closedir DHANDLE;
|
||||
return wantarray ? @arr : \@arr;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::SQL::Search - internal driver for searching
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This implements the query string based searching scheme for GT::SQL. Driver
|
||||
based, it is designed to take advantage of the different indexing schemes
|
||||
available on different database engines.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Instead of describing how Search.pm is interfaced* this will describe how a
|
||||
driver should be structured and how a new driver can be implemented.
|
||||
|
||||
* as it is never accessed directly by the programmer as it was designed to be
|
||||
called through the functions GT::SQL::Table::query and GT::SQL::Table::query_sth
|
||||
|
||||
=head2 Drivers
|
||||
|
||||
A driver has two parts. The Indexer and the Search packages are the most
|
||||
important. Howserver, for any driver in the search, there must exist a directory
|
||||
with the name of the driver in ALL CAPS. For exampel, MYSQL for MySQL, POSTGRES
|
||||
for Postgres. Within each driver directory, The Indexer and Search portions of
|
||||
the driver contains all the information required for initializing the database
|
||||
table and searching the database.
|
||||
|
||||
The Indexing package of the driver handles all the data that is manipulated in
|
||||
the database and also the initializes and the database for indexing.
|
||||
|
||||
The Search package handles the queries and retrieves results for the eventual
|
||||
consumption by the calling program.
|
||||
|
||||
Drivers are simply subclasses of the base driver module, GT::SQL::Search::Base
|
||||
and operate by overriding certain key functions.
|
||||
|
||||
The next few sections will cover how to create a search driver, and assumes a
|
||||
fair bit of familiarity with GT::SQL.
|
||||
|
||||
=head2 Structure of an Indexing Driver
|
||||
|
||||
The following is an absolutely simple skeleton driver that does nothing and but
|
||||
called "CUSTOM". Found in the CUSTOM directory, this is the search package, and
|
||||
would be call Search.pm in the GT/SQL/Search/CUSTOM library directory.
|
||||
|
||||
package GT::SQL::Search::CUSTOM::Search;
|
||||
#------------------------------------------
|
||||
use strict;
|
||||
use vars qw/ @ISA /;
|
||||
use GT::SQL::Search::Base::Search;
|
||||
@ISA = qw( GT::SQL::Search::Base::Search );
|
||||
|
||||
sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Search->new(@_) };
|
||||
|
||||
# overrides would go here
|
||||
|
||||
1;
|
||||
|
||||
For the indexer, another file, Indexer.pm would be found in the
|
||||
GT/SQL/Search/CUSTOM directory.
|
||||
|
||||
package GT::SQL::Search::CUSTOM::Indexer;
|
||||
#------------------------------------------
|
||||
|
||||
use strict;
|
||||
use vars qw/ @ISA /;
|
||||
use GT::SQL::Search::Base;
|
||||
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
|
||||
|
||||
sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) };
|
||||
|
||||
# overrides would go here
|
||||
|
||||
1;
|
||||
|
||||
The almost empty subs that immediately return with a value are functions that
|
||||
can be overridden to do special tasks. More will be detailed later.
|
||||
|
||||
The Driver has been split into two packages. The original package name,
|
||||
GT::SQL::Search::Nothing, houses the Search package.
|
||||
GT::SQL::Search::Nothing::Indexer is the Indexing portion of the seach system.
|
||||
"::Indexer" must be appended to the orginial search name for the indexer.
|
||||
|
||||
Each of the override functions are triggered at points just before and after a
|
||||
major event occurs in GT::SQL. Depending on the type of actions you require, you
|
||||
pick and chose which events you'd like your driver to attach to.
|
||||
|
||||
=head2 Structure of Indexing Driver
|
||||
|
||||
The Indexer is responsible for creating all the indexes, maintaining them and
|
||||
when the table is dropped, removing all the associated indexes.
|
||||
|
||||
The following header must be defined for the Indexer.
|
||||
GT::SQL::Search::Base::Indexer is the superclass that our driver inherits from.
|
||||
|
||||
package GT::SQL::Search::CUSTOM::Indexer;
|
||||
#------------------------------------------
|
||||
|
||||
use strict;
|
||||
use vars qw/ @ISA /;
|
||||
use GT::Base;
|
||||
use GT::SQL::Search::Base::Indexer;
|
||||
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
|
||||
|
||||
In addition to the header, the following function must be defined.
|
||||
GT::SQL::Search::Driver::Indexer::load creates the new object and allows for
|
||||
special preinitialization that must occur. You can also create another driver
|
||||
silently (such as defaulting to INTERNAL after a version check fails).
|
||||
|
||||
sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) };
|
||||
|
||||
Finally, there are the overrides. None of the override functions need be defined
|
||||
in your driver. Any calls made to undefined methods will silently fallback to
|
||||
the superclass driver's methods. When a method has been overridden, the function
|
||||
must return a true value when it is successful, otherwise the action will fail
|
||||
and an error generated.
|
||||
|
||||
Whenever a object is created it will receive one property $self->{table} which
|
||||
is the table that is being worked upon. This property is available in all the
|
||||
method calls and is required for methods such as _create_table and
|
||||
_drop_search_driver methods.
|
||||
|
||||
When a table is first created or when a table is destroyed the following two
|
||||
functions are called. They are not passed any special values, however, these are
|
||||
all class methods and $self->{table} will be a reference to the current table in
|
||||
use.
|
||||
|
||||
This set of overrides are used by GT::SQL::Creator when the ::create method is
|
||||
called. They are called just prior and then after the create table sql query has
|
||||
been executed.
|
||||
|
||||
=over 2
|
||||
|
||||
=item pre_create_table
|
||||
|
||||
=item post_create_table
|
||||
|
||||
These functions receive no special parameters. They will receive the data to the
|
||||
table in the $self->{table} property.
|
||||
|
||||
=back
|
||||
|
||||
This next set of functions take place in GT::SQL::Editor.
|
||||
|
||||
=over 2
|
||||
|
||||
=item drop_search_driver
|
||||
|
||||
This method receives no special parameters but is responsible for removing all
|
||||
indexes and "things" associated with the indexing schema.
|
||||
|
||||
=item add_search_driver
|
||||
|
||||
Receives no extra parameters. Creates all indexes and does all actions required
|
||||
to initialize indexing scheme.
|
||||
|
||||
=item pre_add_column
|
||||
|
||||
=item post_add_column
|
||||
|
||||
The previous two functions are called just before and after a new column is
|
||||
added.
|
||||
|
||||
pre_add_column accepts $name (of column), $col (hashref of column attributes).
|
||||
The method will only be called if the column has a weight associated with it.
|
||||
The function must return a non-zero value if successful. Note that the returned
|
||||
value will be passed into the post_add_column so temporary values can be passed
|
||||
through if required.
|
||||
|
||||
post_add_column accepts $name (of column), $col (hashref of column attributes),
|
||||
$results (of pre_add_column). This method is called just after the column has
|
||||
been inserted into the database.
|
||||
|
||||
=item pre_delete_column
|
||||
|
||||
=item post_delete_column
|
||||
|
||||
These previous functions are called just before and after the sql for a old
|
||||
column is deleted. They must remove all objects and "things" associated with a
|
||||
particular column's index.
|
||||
|
||||
pre_delete_column accepts $name (of column), $col (hashref of column
|
||||
attributes). The method will only be called if the column has a weight
|
||||
associated with it. The function must return a non-zero value if successful.
|
||||
Note that the returned value will be passed into the post_delete_column so
|
||||
temporary values can be passed through if required.
|
||||
|
||||
post_delete_column accepts $name (of column), $col (hashref of column
|
||||
attributes), $results (of pre_add_column). This method is called just after the
|
||||
column has been dropped from the database.
|
||||
|
||||
=item pre_drop_table
|
||||
|
||||
=item post_drop_table
|
||||
|
||||
The two previous methods are used before and after the table is dropped. The
|
||||
methods must remove any tables or "things" related to indexing from the table.
|
||||
|
||||
pre_drop_table receives no arguments. It can find a copy of the current table
|
||||
and columns associated in $self->{table}.
|
||||
|
||||
post_drop_table receives one argument, which is the result of the
|
||||
pre_drop_table.
|
||||
|
||||
=back
|
||||
|
||||
The following set of functions take place in GT::SQL::Table
|
||||
|
||||
=over 2
|
||||
|
||||
=item pre_add_record
|
||||
|
||||
=item post_add_record
|
||||
|
||||
Called just before and after an insert occurs. These functions take the record
|
||||
and indexes them as required.
|
||||
|
||||
pre_add_record will receive one argument, $rec, hashref, which is the record
|
||||
that will be inserted into the database. Table information can be found by
|
||||
accessing $self->{table} Much like the other functions, on success the result
|
||||
will be cached and fed into the post_add_record function.
|
||||
|
||||
post_add_record receives $rec, a hashref to describing the new result, the $sth
|
||||
of the insert query, and the result of the pre_add_record method. The result
|
||||
from $sth->insert_id if there is a ai field will be the new unique primary key.
|
||||
|
||||
=item pre_update_record
|
||||
|
||||
=item post_update_record
|
||||
|
||||
Intercepts the update request before and just after the sql query is executed.
|
||||
This override has the potential of being rather messy. More than one record can
|
||||
be modified in this action and the indexer must work a lot to ensure the
|
||||
database is up to snuff.
|
||||
|
||||
pre_update_record receives two parameters, $set_cond, $where_cond. $set_cond is
|
||||
a hashref containing the new values that must be set, and $where_cond is a
|
||||
GT::SQL::Condition object selecting records to update. The result once again, is
|
||||
cached and if undef is considered an error.
|
||||
|
||||
post_update_record takes the same parameters as pre_update_record, except one
|
||||
extra paremeter, the result of pre_update_record.
|
||||
|
||||
=item pre_delete_record
|
||||
|
||||
=item post_delete_record
|
||||
|
||||
Called just before and after the deletion request for records are called.
|
||||
|
||||
pre_delete_record, has only one parameter, $where, a GT::SQL::Condition object
|
||||
telling which records to delete. The results of this method are passed to
|
||||
post_delete_record.
|
||||
|
||||
post_delete_record, has one addition parameter to pre_delete_record and like
|
||||
most post_ methods, is the result of the pre_delete_record method.
|
||||
|
||||
=item pre_delete_all_records
|
||||
|
||||
=item post_delete_all_records
|
||||
|
||||
These two functions are quite simple, but they are different from drop search
|
||||
driver in that though the records are all dropped, the framework for all the
|
||||
indexing is not dropped as well.
|
||||
|
||||
Neither function is passed any special data, except for post_delete_all_records
|
||||
which receives the rsults of the pre_delete_all_records method.
|
||||
|
||||
=item reindex_all
|
||||
|
||||
This function is sometimes called by the user to refresh the index. The
|
||||
motivation for this, in the case of the INTERNAL driver, is sometimes due to
|
||||
outside manipulation of the database tables, the index can become
|
||||
non-representative of the data in the tables. This method is to force the
|
||||
indexing system to fix errors that have passed.
|
||||
|
||||
=item ok
|
||||
|
||||
This function is called by GT::SQL::Search as a package method,
|
||||
GT::SQL::Search::EXAMPLE::Indexer->ok( $table ); and is passed a table object
|
||||
reference. What this function must do is to return a true or false value that
|
||||
tells the search system if this driver can be used. The MYSQL driver has a good
|
||||
example for this, it tests to ensure that the mysql database system version is
|
||||
at least 3.23.23.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Structure of a Search Driver
|
||||
|
||||
The Searcher is responsible for only one thing, to return results from a query
|
||||
search. You can override the parser, however, subclassing the following methods
|
||||
will have full parsing for all things such as +/-, string parsing and substring
|
||||
matching.
|
||||
|
||||
The structures passed into the methods get a little complicated so beware!
|
||||
|
||||
ALL the following functions receive two parameters, the first is a search
|
||||
parameters detailing the words/phrases to search for, the second parameter is
|
||||
the current result set of IDs => scores.
|
||||
|
||||
There are two types of search parameters, one for words and the other for
|
||||
phrases. The structure is a little messy so I'll detail them here.
|
||||
|
||||
For words, the structure is like the following:
|
||||
|
||||
$word_search = {
|
||||
'word' => {
|
||||
substring => '1', # set to 1 if this is substring match
|
||||
phrase => 0, # not a phrase
|
||||
keyword => 1, # is a keyword
|
||||
mode => '', # can also be must, cannot to mean +/-
|
||||
},
|
||||
'word2' => ...
|
||||
}
|
||||
|
||||
For phrases the structure will become:
|
||||
|
||||
$phrase_search => {
|
||||
'phrase' => {
|
||||
substring => undef # never required
|
||||
phrase => [
|
||||
'word1',
|
||||
'word2',
|
||||
'word3',
|
||||
...
|
||||
], # for searching by indiv word if required
|
||||
keyword => 0, # not a keyword
|
||||
mode => '' # can also be must, cannot
|
||||
},
|
||||
'phrase2' => ...
|
||||
}
|
||||
|
||||
Based on these structures, hopefully it will be easy enough to build whatever is
|
||||
required to grab the appropriate records.
|
||||
|
||||
Finally, the second item passed in will be a hash filled with ID => score values
|
||||
of search results. They look something like this:
|
||||
|
||||
$results = {
|
||||
1 => 56,
|
||||
2 => 31,
|
||||
4 => 6
|
||||
}
|
||||
|
||||
It is important for all the methods to take the results and return the results,
|
||||
as the result set will be daisychained down like a set to be operated on by
|
||||
various searching schemes.
|
||||
|
||||
At the end of the query, the results in this set will be sorted and returned to
|
||||
the user as an sth.
|
||||
|
||||
Operations on this set are preformed by the following five methods.
|
||||
|
||||
=over 2
|
||||
|
||||
=item _query
|
||||
|
||||
This method is called just after all the query string has been parsed and put
|
||||
into their proper buckets. This method is overridden by the INTERNAL driver to
|
||||
decide it wants to switch to the NONINDEX driver for better performance.
|
||||
|
||||
Two parameters are passed in, ( $input, $buckets ). $input is a hash that
|
||||
contains all the form/cgi parameters passed to the $tbl->query function and
|
||||
$buckets is s the structure that is created after the query string is parsed.
|
||||
You may also call $self->SUPER::_query( $input, $buckets ) to pass the request
|
||||
along normally.
|
||||
|
||||
You must return undef or an STH from this function.
|
||||
|
||||
=item _union_query
|
||||
|
||||
This method takes a $word_search and does a simple match query. If it finds
|
||||
records with any of the words included, it will append the results to the list.
|
||||
Passed in is the $results and it must return the altered results set.
|
||||
|
||||
This method must also implement substring searching.
|
||||
|
||||
=item _phrase_query
|
||||
|
||||
Just like the union_query, however it searches based on phrases.
|
||||
|
||||
=item _phrase_intersect_query
|
||||
|
||||
This takes a $phrase_search and a $result as parameters. This method must look
|
||||
to find results that are found within the current result set that have the
|
||||
passed phrases as well. However, if there are no results found, this method can
|
||||
look for more results.
|
||||
|
||||
=item _intersect_query
|
||||
|
||||
Takes two parameters, a $word_search, and $results. Just like the
|
||||
_phrase_intersect query, if there are results already, tries to whittle away the
|
||||
result set. If there are no results, tries to look for results that have all the
|
||||
keywords in a record.
|
||||
|
||||
This method must also implement substring searching.
|
||||
|
||||
=item _disjoin_query
|
||||
|
||||
Takes two parameters, a $word_search, and $results. This will look through the
|
||||
result set and remove all matches to any of the keywords.
|
||||
|
||||
This method must also implement substring searching.
|
||||
|
||||
=item _phrase_disjoin_query
|
||||
|
||||
Two parameters, $phrase_search and $results are passed to this method. This does
|
||||
the exact same thing as _disjoin_query but it looks for phrases.
|
||||
|
||||
=item query
|
||||
|
||||
If you choose to override this method, you will have full control of the query.
|
||||
|
||||
This method accepts a $CGI or a $HASH object and performs the following
|
||||
|
||||
Options:
|
||||
- paging
|
||||
mh : max hits
|
||||
nh : number hit (or page of hits)
|
||||
sb : column to sort by (default is by score)
|
||||
|
||||
- searching
|
||||
ww : whole word
|
||||
ma : 1 => OR match, 0 => AND match, undefined => QUERY
|
||||
substring : search for substrings of words
|
||||
bool : 'and' => and search, 'or' => or search, '' => regular query
|
||||
query : the string of things to ask for
|
||||
|
||||
- filtering
|
||||
field_name : value # Find all rows with field_name = value
|
||||
field_name : ">value" # Find all rows with field_name > value.
|
||||
field_name : "<value" # Find all rows with field_name < value.
|
||||
field_name-gt : value # Find all rows with field_name > value.
|
||||
field_name-lt : value # Find all rows with field_name < value.
|
||||
|
||||
The function must return a STH object. However, you may find useful the
|
||||
GT::SQL::Search::STH object, which will automatically handle mh, nh, and
|
||||
alternative sorting requests. All you will have to do is
|
||||
|
||||
sub query { ... your code ... return $self->sth( $results ); }
|
||||
|
||||
Where results is a hashref containing primarykeyvalue => scorevalues.
|
||||
|
||||
=item alternate_driver_query
|
||||
|
||||
There is no reason to override this method, however, if you would like to use
|
||||
another driver's search instead of the current, this method will let you do so.
|
||||
|
||||
Accepting 2 parameters, ( $drivername, $input ), where $drivername is the name
|
||||
of the driver you'd like to use and $input is the parameters passed to the
|
||||
method. Returned is an $sth value (undef if an error has occured). This method
|
||||
was used in the INTERNAL driver to shunt to NONINDEXED if it found the search
|
||||
would take too long.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Search.pm,v 1.60 2004/08/28 03:53:43 jagerman Exp $
|
||||
|
||||
=cut
|
||||
82
site/glist/lib/GT/SQL/Search/Base/Common.pm
Normal file
82
site/glist/lib/GT/SQL/Search/Base/Common.pm
Normal file
@@ -0,0 +1,82 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::Base::Common
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Common.pm,v 1.8 2004/10/13 21:45:02 aki Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base classes upon which all search drivers are based
|
||||
#
|
||||
package GT::SQL::Search::Base::Common;
|
||||
|
||||
use strict;
|
||||
use Exporter;
|
||||
use vars qw/ @ISA @EXPORT $STOPWORDS /;
|
||||
|
||||
@ISA = qw( Exporter );
|
||||
@EXPORT = qw( &_tokenize &_check_word $STOPWORDS );
|
||||
|
||||
$STOPWORDS = { map { $_ => 1 } qw/
|
||||
of about or all several also she among since an some and such are than
|
||||
as that at the be them because there been these between they both this
|
||||
but those by to do toward during towards each upon either for from was
|
||||
had were has what have when he where her which his while however with if
|
||||
within in would into you your is it its many more most must on re it
|
||||
test not above add am pm jan january feb february mar march apr april
|
||||
may jun june jul july aug august sep sept september oct october nov
|
||||
november dec december find & > < we http com www inc other
|
||||
including
|
||||
/ };
|
||||
|
||||
sub _tokenize {
|
||||
#--------------------------------------------------------------------------------
|
||||
# takes a strings and chops it up into little bits
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
my ( @words, $i, %rejected, $word, $code );
|
||||
|
||||
# split on any non-word (includes accents) characters
|
||||
@words = split /[^\w\x80-\xFF\-]+/, lc $text;
|
||||
$self->debug_dumper( "Words: ", \@words ) if ($self->{_debug});
|
||||
|
||||
# drop all words that are too small, etc.
|
||||
$i = 0;
|
||||
while ( $i <= $#words ) {
|
||||
$word = $words[ $i ];
|
||||
if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or
|
||||
(length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or
|
||||
(length($word) > $self->{max_word_size} and $code = 'TOOBIG')) {
|
||||
splice( @words, $i, 1 );
|
||||
$rejected{$word} = $self->{'rejections'}->{$code};
|
||||
}
|
||||
else {
|
||||
$i++; # Words ok.
|
||||
}
|
||||
}
|
||||
$self->debug_dumper( "Accepted Words: ", \@words ) if ($self->{_debug});
|
||||
$self->debug_dumper( "Rejected Words: ", \%rejected ) if ($self->{_debug});
|
||||
|
||||
return ( \@words, \%rejected );
|
||||
}
|
||||
|
||||
sub _check_word {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Returns an error code if it is an invalid word, otherwise returns nothing.
|
||||
#
|
||||
my $self = shift;
|
||||
my $word = shift;
|
||||
my $code;
|
||||
if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or
|
||||
(length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or
|
||||
(length($word) > $self->{max_word_size} and $code = 'TOOBIG')) {
|
||||
return $code;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
78
site/glist/lib/GT/SQL/Search/Base/Indexer.pm
Normal file
78
site/glist/lib/GT/SQL/Search/Base/Indexer.pm
Normal file
@@ -0,0 +1,78 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::Base::Indexer
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Indexer.pm,v 1.4 2004/01/13 01:35:19 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
#
|
||||
#
|
||||
|
||||
package GT::SQL::Search::Base::Indexer;
|
||||
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
|
||||
use GT::Base;
|
||||
use GT::SQL::Search::Base::Common;
|
||||
|
||||
#--------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
|
||||
@ISA = qw/GT::Base GT::SQL::Search::Base::Common/;
|
||||
$ATTRIBS = {
|
||||
driver => undef,
|
||||
stopwords => $STOPWORDS,
|
||||
rejections => {
|
||||
STOPWORD => "is a stopword",
|
||||
TOOSMALL => "is too small a word",
|
||||
TOOBIG => "is too big a word"
|
||||
},
|
||||
table => '',
|
||||
init => 0,
|
||||
debug => 0,
|
||||
min_word_size => 3,
|
||||
max_word_size => 50,
|
||||
};
|
||||
|
||||
sub drop_search_driver { 1 }
|
||||
sub add_search_driver { 1 }
|
||||
|
||||
# found in GT::SQL::Creator
|
||||
sub pre_create_table { 1 }
|
||||
sub post_create_table { 1 }
|
||||
|
||||
# GT::SQL::Editor
|
||||
sub pre_add_column { 1 }
|
||||
sub post_add_column { 1 }
|
||||
|
||||
sub pre_delete_column { 1 }
|
||||
sub post_delete_column { 1 }
|
||||
|
||||
sub pre_drop_table { 1 }
|
||||
sub post_drop_table { 1 }
|
||||
|
||||
# GT::SQL::Table
|
||||
sub pre_add_record { 1 }
|
||||
sub post_add_record { 1 }
|
||||
|
||||
sub pre_update_record { 1 }
|
||||
sub post_update_record { 1 }
|
||||
|
||||
sub pre_delete_record { 1 }
|
||||
sub post_delete_record { 1 }
|
||||
|
||||
sub pre_delete_all_records { 1 }
|
||||
sub post_delete_all_records { 1 }
|
||||
|
||||
sub driver_ok { 1 }
|
||||
|
||||
sub reindex_all { 1 }
|
||||
|
||||
1;
|
||||
287
site/glist/lib/GT/SQL/Search/Base/STH.pm
Normal file
287
site/glist/lib/GT/SQL/Search/Base/STH.pm
Normal file
@@ -0,0 +1,287 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::STH
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: STH.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::SQL::Search::STH;
|
||||
#--------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE /;
|
||||
use GT::Base;
|
||||
|
||||
@ISA = ('GT::Base');
|
||||
$ATTRIBS = {
|
||||
'_debug' => 0,
|
||||
'sth' => undef,
|
||||
'results' => {},
|
||||
'db' => undef,
|
||||
'table' => undef,
|
||||
'index' => 0,
|
||||
'order' => [],
|
||||
'sb' => 'score',
|
||||
'so' => '',
|
||||
'score_col' => 'SCORE',
|
||||
'score_sort'=> 0,
|
||||
'nh' => 0,
|
||||
'mh' => 0
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$ERRORS = {
|
||||
BADSB => 'Invalid character found in so: "%s"',
|
||||
};
|
||||
|
||||
sub init {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
# setup the options
|
||||
$self->set(@_);
|
||||
|
||||
# correct a few of the values
|
||||
--$self->{nh} if $self->{nh};
|
||||
|
||||
my $sth;
|
||||
my $results = $self->{results};
|
||||
$self->{rows} = scalar( $results ? keys %{$results} : 0 );
|
||||
|
||||
# if we have asked to have sorting by another column (non score), create the part of the query that handles taht
|
||||
$self->debug( "Setting up sorting for GT::SQL::Search::STH" ) if ($self->{_debug});
|
||||
my $sb;
|
||||
|
||||
# clean up the sort by columns.
|
||||
unless ($self->{'score_sort'}) {
|
||||
$sb = GT::SQL::Search::Base::Search->clean_sb($self->{sb}, $self->{so});
|
||||
}
|
||||
|
||||
# setup the max hits and the offsets
|
||||
$self->{index} = $self->{nh} * $self->{mh} || 0;
|
||||
$self->{max_index} = $self->{index} + $self->{mh} - 1; # index + mh is the first record which should not be returned.
|
||||
|
||||
if ( $self->{max_index} > $self->{rows} ) {
|
||||
$self->{max_index} = $self->{rows};
|
||||
$self->{rows} = $self->{rows} - $self->{index};
|
||||
$self->{rows} < 0 ? $self->{rows} = 0 : 0;
|
||||
}
|
||||
|
||||
else {
|
||||
$self->{rows} = $self->{mh};
|
||||
}
|
||||
|
||||
# if we are sorting by another column, handle that
|
||||
if ( $sb and (keys %{$self->{results}})) {
|
||||
my ( $table, $pk ) = $self->_table_info();
|
||||
my ( $query, $where, $st, $limit );
|
||||
|
||||
$where = qq!$pk in(! . join( ",", keys %{$self->{results}}) . ')';
|
||||
$self->{mh} and $limit = qq!LIMIT $self->{index}, $self->{rows}!;
|
||||
$query = qq!
|
||||
SELECT $pk
|
||||
FROM $table
|
||||
WHERE $where
|
||||
$sb
|
||||
$limit
|
||||
!;
|
||||
$self->debug( "Row fetch query: $query" ) if ($self->{_debug});
|
||||
$sth = $self->{table}->{driver}->prepare( $query );
|
||||
$sth->execute();
|
||||
|
||||
# fix the counts
|
||||
$self->{index} = 0;
|
||||
$self->{max_hits} = $self->{rows};
|
||||
|
||||
# now return them
|
||||
my $order = $sth->fetchall_arrayref();
|
||||
$sth->finish();
|
||||
|
||||
$self->{'order'} = [ map { $_->[0] } @{$order} ];
|
||||
}
|
||||
else {
|
||||
$self->{'order'} = [ sort {
|
||||
( $results->{$b} || return 0 ) <=> ( $results->{$a} || 0 )
|
||||
} keys %{$results} ];
|
||||
$self->debug_dumper( "Results will be presented in the following order: ", $self->{'order'} ) if ($self->{_debug});
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub cache_results {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $results = $self->{'results'};
|
||||
my ($sth, @records, $i, %horder, @order, $in_list);
|
||||
my $table = $self->{table};
|
||||
my $tname = $table->name();
|
||||
my ($pk) = $self->{table}->pk;
|
||||
|
||||
use GT::SQL::Condition;
|
||||
|
||||
# we know what we're doing here so shut off warns (complains about uninit'd values in range
|
||||
# if thee aren't enough elements in the order array)
|
||||
my $w = $^W; $^W = 0;
|
||||
@order = grep $_, @{$self->{'order'} || []}[$self->{index}..$self->{max_index}] or return [];
|
||||
$^W = $w;
|
||||
|
||||
$i = 0; %horder = ( map { ( $_ => $i++) } @order );
|
||||
$in_list = join ( ",", @order );
|
||||
my $query = qq|
|
||||
SELECT *
|
||||
FROM
|
||||
$tname
|
||||
WHERE
|
||||
$pk IN($in_list)
|
||||
|;
|
||||
|
||||
# the following is left commented out as...
|
||||
# if $tbl->select is used $table->hits() will not
|
||||
# return an accurate count of the number of all the hits. instead, will return
|
||||
# a value up to mh. $tbl->hits() is important because the value is used
|
||||
# in toolbar calculations
|
||||
#
|
||||
# $sth = $table->select( GT::SQL::Condition->new( $pk, 'IN', \"($in_list)" ) );
|
||||
$sth = $table->do_query( $query );
|
||||
|
||||
while ( my $href = $sth->fetchrow_hashref() ) {
|
||||
$records[$horder{$href->{$pk}}] = \%$href
|
||||
}
|
||||
|
||||
return \@records;
|
||||
|
||||
}
|
||||
|
||||
sub fetchrow_array {
|
||||
#--------------------------------------------------------------------------------
|
||||
return @{ $_[0]->fetchrow_arrayref() || [] };
|
||||
}
|
||||
|
||||
sub fetchrow_arrayref {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $records = $self->{cache} ||= $self->cache_results;
|
||||
my $href = shift @$records or return;
|
||||
return $self->_hash_to_array($href);
|
||||
}
|
||||
|
||||
sub fetchrow_hashref {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $results = $self->{'results'};
|
||||
my $records = $self->{cache} ||= $self->cache_results;
|
||||
my $table = $self->{table};
|
||||
my ($pk) = $self->{table}->pk;
|
||||
|
||||
my $href = shift @$records or return;
|
||||
|
||||
$href->{$self->{'score_col'}} = ( $self->{score} = $results->{$href->{$pk}} );
|
||||
|
||||
return $href;
|
||||
|
||||
}
|
||||
|
||||
sub fetchall_hashref {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my @results;
|
||||
while (my $res = $self->fetchrow_hashref) {
|
||||
push @results, $res;
|
||||
}
|
||||
return \@results;
|
||||
}
|
||||
|
||||
sub fetchall_list {
|
||||
#--------------------------------------------------------------------------------
|
||||
return { map { @$_ } @{shift->fetchall_arrayref} }
|
||||
}
|
||||
|
||||
sub fetchall_arrayref {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
$self->{order} or return [];
|
||||
my $results = $self->{results};
|
||||
my ($pk) = $self->{table}->pk;
|
||||
my $scol = $self->{score_col};
|
||||
|
||||
|
||||
if (!$self->{allref_cache}) {
|
||||
$self->{allref_cache} ||= $self->cache_results;
|
||||
|
||||
for my $i ( 0 .. $#{$self->{allref_cache}} ) {
|
||||
my $element = $self->{allref_cache}->[$i];
|
||||
if ( $_[0] eq 'HASH' ) {
|
||||
$element->{$scol} = $results->{$element->{$pk}};
|
||||
}
|
||||
else {
|
||||
$element->{$scol} = $self->_hash_to_array( $element->{$scol} );
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
my $records = $self->{allref_cache};
|
||||
|
||||
return $records;
|
||||
}
|
||||
|
||||
sub score {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{score};
|
||||
}
|
||||
|
||||
sub _hash_to_array {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $href = shift or return;
|
||||
|
||||
my $results = $self->{'results'};
|
||||
my $table = $self->{table};
|
||||
my $cols = $table->cols();
|
||||
my $ordercols = ( $self->{ordercols} ||= [ sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } keys %$cols ] );
|
||||
my ($pk) = $self->{table}->pk;
|
||||
my $aref = [ map { $href->{$_} } @$ordercols, ( $self->{score} = $results->{$href->{$pk}} ) ];
|
||||
|
||||
return $aref;
|
||||
}
|
||||
|
||||
sub rows {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{rows};
|
||||
}
|
||||
|
||||
sub _table_info {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL');
|
||||
my ($pk) = $self->{table}->pk;
|
||||
return ( $table, $pk );
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->{'sth'} and $self->{'sth'}->finish();
|
||||
}
|
||||
|
||||
sub debug_dumper {
|
||||
#--------------------------------------------------------------------------------
|
||||
# calls debug but also dumps all the messages
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
my $level = ref $_[0] ? 1 : shift;
|
||||
|
||||
if ( $self->{_debug} >= $level ) {
|
||||
require GT::Dumper;
|
||||
$self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug});
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
572
site/glist/lib/GT/SQL/Search/Base/Search.pm
Normal file
572
site/glist/lib/GT/SQL/Search/Base/Search.pm
Normal file
@@ -0,0 +1,572 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::Base
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Search.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base classes upon which all search drivers are based
|
||||
#
|
||||
|
||||
package GT::SQL::Search::Base::Search;
|
||||
|
||||
|
||||
use strict;
|
||||
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
|
||||
use GT::Base;
|
||||
use GT::SQL::Search::Base::Common;
|
||||
@ISA = qw( GT::Base GT::SQL::Search::Base::Common);
|
||||
|
||||
#--------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/;
|
||||
@ISA = qw/ GT::Base /;
|
||||
|
||||
$ATTRIBS = {
|
||||
'stopwords' => $STOPWORDS,
|
||||
'mh' => 25,
|
||||
'nh' => 1,
|
||||
'ww' => undef,
|
||||
'ma' => undef,
|
||||
'bool' => undef,
|
||||
'substring' => 0,
|
||||
'query' => '',
|
||||
'sb' => 'score',
|
||||
'so' => '',
|
||||
'score_col' => 'SCORE',
|
||||
'score_sort'=> 0,
|
||||
'debug' => 0,
|
||||
'_debug' => 0,
|
||||
|
||||
# query related
|
||||
'db' => undef,
|
||||
'table' => undef,
|
||||
'filter' => undef,
|
||||
'callback' => undef,
|
||||
|
||||
# strict matching of indexed words, accents on words do count
|
||||
'sm' => 0,
|
||||
'min_word_size' => 3,
|
||||
'max_word_size' => 50,
|
||||
};
|
||||
|
||||
sub init {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Initialises the Search object
|
||||
#
|
||||
my $self = shift;
|
||||
my $input = $self->common_param(@_);
|
||||
|
||||
$self->set($input);
|
||||
|
||||
# now handle filters...,
|
||||
my $tbl = $self->{table};
|
||||
my $cols = $tbl->cols();
|
||||
my %filters = map {
|
||||
(my $tmp = $_) =~ s/-[lg]t$//;
|
||||
exists $cols->{$tmp} ? ($_ => $input->{$_}) : ()
|
||||
} keys %{$input};
|
||||
|
||||
if ( keys %filters ) {
|
||||
$self->debug_dumper( "INIT: Creating Filters: ", \%filters ) if ( $self->{_debug} );
|
||||
$self->filter(\%filters);
|
||||
}
|
||||
|
||||
$self->{table}->connect;
|
||||
}
|
||||
|
||||
sub query {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Returns a sth based on a query
|
||||
#
|
||||
# Options:
|
||||
# - paging
|
||||
# mh : max hits
|
||||
# nh : number hit (or page of hits)
|
||||
#
|
||||
# - searching
|
||||
# ww : whole word
|
||||
# ma : 1 => OR match, 0 => AND match, undefined => QUERY
|
||||
# substring : search for substrings of words
|
||||
# bool : 'and' => and search, 'or' => or search, '' => regular query
|
||||
# query : the string of things to ask for
|
||||
#
|
||||
# - filtering
|
||||
# field_name : value # Find all rows with field_name = value
|
||||
# field_name : ">value" # Find all rows with field_name > value.
|
||||
# field_name : "<value" # Find all rows with field_name < value.
|
||||
# field_name-gt : value # Find all rows with field_name > value.
|
||||
# field_name-lt : value # Find all rows with field_name < value.
|
||||
#
|
||||
# Parameters:
|
||||
# ( $CGI ) : a single cgi object
|
||||
# ( $HASH ) : a hash of the parameters
|
||||
#
|
||||
my $self = shift;
|
||||
# find out what sort of a parameter we're dealing with
|
||||
my $input = $self->common_param(@_);
|
||||
|
||||
# add additional parameters if required
|
||||
foreach my $parameter ( keys %{$ATTRIBS} ) {
|
||||
if ( not exists $input->{$parameter} ) {
|
||||
$input->{$parameter} = $self->{$parameter};
|
||||
}
|
||||
}
|
||||
|
||||
# parse query...,
|
||||
$self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug});
|
||||
my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} );
|
||||
|
||||
$self->{'rejected_keywords'} = $rejected;
|
||||
|
||||
# setup the additional input parameters
|
||||
$query = $self->_preset_options( $query, $input );
|
||||
|
||||
$self->debug_dumper( "Set the pre-options: ", $query ) if ($self->{_debug});
|
||||
|
||||
# now sort into distinct buckets
|
||||
my $buckets = &_create_buckets( $query );
|
||||
$self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug});
|
||||
|
||||
return $self->_query($input, $buckets);
|
||||
}
|
||||
|
||||
sub _query {
|
||||
#--------------------------------------------------------------------------------
|
||||
my ( $self, $input, $buckets ) = @_;
|
||||
|
||||
# now handle the separate possibilities
|
||||
my $results = {};
|
||||
|
||||
# query can have phrases
|
||||
$results = $self->_phrase_query( $buckets->{phrases}, $results );
|
||||
$self->debug_dumper("Did phrase union query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# query have keywords
|
||||
$results = $self->_union_query( $buckets->{keywords}, $results );
|
||||
$self->debug_dumper("Did keyword union query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# query must have phrases
|
||||
$results = $self->_phrase_intersect_query( $buckets->{phrases_must}, $results );
|
||||
$self->debug_dumper("Did phrase intersect query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# query must have keywords
|
||||
$results = $self->_intersect_query( $buckets->{keywords_must}, $results );
|
||||
$self->debug_dumper("Did keyword intersect query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# query cannot have keywords
|
||||
$results = $self->_disjoin_query( $buckets->{keywords_cannot}, $results );
|
||||
$self->debug_dumper("Did keyword disjoin query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# query cannot have phrases
|
||||
$results = $self->_phrase_disjoin_query( $buckets->{phrases_cannot}, $results);
|
||||
$self->debug_dumper("Did phrase disjoin query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# now handle filters
|
||||
my $cols = $self->{'table'}->cols();
|
||||
my %filters = map {
|
||||
(my $tmp = $_) =~ s/-[lg]t$//;
|
||||
$cols->{$tmp} ? ($_ => $input->{$_}) : ()
|
||||
} keys %{$input};
|
||||
|
||||
if (keys %filters) {
|
||||
$self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug});
|
||||
$results = $self->filter(\%filters, $results);
|
||||
}
|
||||
elsif ($self->{filter}) {
|
||||
$self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug});
|
||||
$results = $self->_filter_query( $self->{filter}, $results );
|
||||
}
|
||||
else {
|
||||
$self->debug( "No filters being used.") if ($self->{_debug});
|
||||
}
|
||||
|
||||
# now this query should probably clear the filters once it's been used, so i'll dothat here
|
||||
$self->{filter} = undef;
|
||||
|
||||
# now run through a callback function if needed.
|
||||
if ($self->{callback}) {
|
||||
unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') {
|
||||
return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!");
|
||||
}
|
||||
$self->debug_dumper ("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug});
|
||||
$results = $self->{callback}->($self, $results);
|
||||
$self->debug_dumper ("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug});
|
||||
}
|
||||
|
||||
# so how many hits did we get?
|
||||
$self->{table}->{last_hits} = ( $self->{rows} = scalar($results ? keys %{$results} : ()) );
|
||||
|
||||
# and now create a search sth object to handle all this
|
||||
return $self->sth( $results );
|
||||
}
|
||||
|
||||
sub sth {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $results = shift;
|
||||
|
||||
require GT::SQL::Search::Base::STH;
|
||||
my $sth = GT::SQL::Search::STH->new(
|
||||
'results' => $results,
|
||||
'db' => $self->{table}->{driver},
|
||||
# pass the following attributes down to the STH handler
|
||||
map({ ($_ => $self->{$_}) } qw/ table sb so score_col score_sort nh mh rows _debug /)
|
||||
);
|
||||
|
||||
return $sth;
|
||||
}
|
||||
|
||||
sub rows {
|
||||
#--------------------------------------------------------------------------------
|
||||
# after a query is run, returns the number of rows
|
||||
my $self = shift;
|
||||
return $self->{rows} || 0;
|
||||
}
|
||||
|
||||
sub _add_filters {
|
||||
#--------------------------------------------------------------------------------
|
||||
# creates the filter object
|
||||
my $self = shift;
|
||||
my $filter;
|
||||
|
||||
# find out how we're calling the parameters
|
||||
if ( ref $_[0] eq 'GT::SQL::Condition' ) {
|
||||
$filter = shift;
|
||||
}
|
||||
elsif ( ref $_[0] eq 'HASH' ) {
|
||||
|
||||
|
||||
# setup the query condition using the build_query condition method
|
||||
# build the condition object
|
||||
my %opts = %{ shift() || {} };
|
||||
delete $opts{query};
|
||||
|
||||
$filter = $self->{table}->build_query_cond( \%opts, $self->{table}{schema}{cols} );
|
||||
|
||||
}
|
||||
else {
|
||||
return $self->error ('BADARGS', 'FATAL', "Invalid argument: $_[0] passed to _add_filter");
|
||||
}
|
||||
|
||||
# Use ref, as someone can pass in filter => 1 and mess things up.
|
||||
|
||||
ref $self->{filter} ? $self->{filter}->add ($filter) : ($self->{filter} = $filter);
|
||||
$self->debug_dumper( "Filters: ", $self->{filter} ) if ($self->{_debug});
|
||||
|
||||
return $self->{filter};
|
||||
|
||||
}
|
||||
|
||||
sub _preset_options {
|
||||
#--------------------------------------------------------------------------------
|
||||
# sets up word parameters
|
||||
my $self = shift;
|
||||
my $query = shift or return;
|
||||
my $input = shift or return $query;
|
||||
|
||||
# whole word searching
|
||||
if ( defined $input->{'ww'} or defined $self->{'ww'}) {
|
||||
if ( defined $input->{'ww'} ? $input->{'ww'} : $self->{'ww'} ) {
|
||||
for ( keys %{$query} ) { $query->{$_}->{mode} = 'substring'; }
|
||||
}
|
||||
}
|
||||
|
||||
# substring searching
|
||||
if ( defined $input->{'substring'} or defined $self->{'substring'}) {
|
||||
if ( defined $input->{'substring'} ? $input->{'substring'} : $self->{'substring'} ) {
|
||||
for ( keys %{$query} ) { $query->{$_}->{'substring'} = 1; }
|
||||
}
|
||||
}
|
||||
|
||||
if ( defined $input->{'ma'} or defined $self->{'ma'} ) {
|
||||
# each keyword must be included
|
||||
if ( defined $input->{'ma'} ? $input->{'ma'} : $self->{'ma'} ) {
|
||||
for ( keys %{$query} ) {
|
||||
next if $query->{$_}->{mode} eq 'cannot';
|
||||
$query->{$_}->{mode} = 'must';
|
||||
}
|
||||
}
|
||||
# each word can be included but is not necessary
|
||||
else {
|
||||
for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; }
|
||||
}
|
||||
}
|
||||
|
||||
# some more and or searches, only if user hasn't put +word -word
|
||||
if ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'and' ) {
|
||||
unless ($input->{query} =~ /(?:^|\s)[+-]\w/) {
|
||||
for ( keys %{$query} ) {
|
||||
next if $query->{$_}->{mode} eq 'cannot';
|
||||
$query->{$_}->{mode} = 'must';
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'or' ) {
|
||||
unless ($input->{query} =~ /(?:^|\s)[+-]\w/) {
|
||||
for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; }
|
||||
}
|
||||
}
|
||||
|
||||
return $query;
|
||||
}
|
||||
|
||||
sub _phrase_query { $_[1] }
|
||||
sub _union_query { $_[1] }
|
||||
sub _phrase_intersect_query { $_[1] }
|
||||
sub _intersect_query { $_[1] }
|
||||
sub _disjoin_query { $_[1] }
|
||||
sub _phrase_disjoin_query { $_[1] }
|
||||
|
||||
sub filter {
|
||||
#--------------------------------------------------------------------------------
|
||||
# adds a filter
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# add filters..,
|
||||
my $filters = $self->_add_filters( shift );
|
||||
my $results = shift;
|
||||
|
||||
# see if we need to execute a search, otherwise just return the current filterset
|
||||
defined $results or return $results;
|
||||
|
||||
# start doing the filter stuff
|
||||
return $self->_filter_query( $filters, $results );
|
||||
}
|
||||
|
||||
sub _parse_query_string {
|
||||
#------------------------------------------------------------
|
||||
# from Mastering Regular Expressions altered a fair bit
|
||||
# takes a space delimited string and breaks it up.
|
||||
#
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
|
||||
my %words = ();
|
||||
my %reject = ();
|
||||
my %mode = (
|
||||
'+' => 'must',
|
||||
'-' => 'cannot',
|
||||
'<' => 'greater',
|
||||
'>' => 'less'
|
||||
);
|
||||
|
||||
# work on the individual elements
|
||||
my @new = ();
|
||||
while ( $text =~ m{
|
||||
# the first part groups the phrase inside the quotes.
|
||||
# see explanation of this pattern in MRE
|
||||
([+-]?"[^\"\\]*(?:\\.[^\"\\]*)*)" ?
|
||||
| (\+?[\w\x80-\xFF\-\*]+),?
|
||||
| ' '
|
||||
}gx ) {
|
||||
|
||||
my $match = lc $+;
|
||||
|
||||
# strip out buffering spaces
|
||||
$match =~ s/^\s+//; $match =~ s/\s+$//;
|
||||
|
||||
# don't bother trying if there is nothing there
|
||||
next unless $match;
|
||||
|
||||
# find out the searching mode
|
||||
my ($mode, $substring, $phrase);
|
||||
if (my $m = $mode{substr($match,0,1)}) {
|
||||
$match = substr($match,1);
|
||||
$mode = $m;
|
||||
}
|
||||
|
||||
# do we need to substring match?
|
||||
if ( substr( $match, -1, 1 ) eq "*" ) {
|
||||
$match = substr($match,0,length($match)-1);
|
||||
$substring = 1;
|
||||
}
|
||||
|
||||
# find out if we're dealing with a phrase
|
||||
if ( substr($match,0,1) eq '"' ) {
|
||||
$self->debug( "Dealing with a phrase: $match" ) if ($self->{_debug});
|
||||
|
||||
$match = substr($match,1);
|
||||
|
||||
# however, we want to make sure it's a phrase and not something else
|
||||
my ( $word_list, $rejected ) = $self->_tokenize( $match );
|
||||
$self->debug_dumper( "Phrase reduced to: ", $word_list ) if ($self->{_debug});
|
||||
$self->debug_dumper( "Phrase words rejected: ", $rejected ) if ($self->{_debug});
|
||||
my $word_count = @$word_list;
|
||||
|
||||
if ( $word_count > 1 ) { $phrase = $word_list } # ok, standard phrase
|
||||
elsif ($word_count == 1) { $match = $word_list->[0] } # just a standard word, don't worry about searching by phrase
|
||||
}
|
||||
|
||||
# make sure we can use this word
|
||||
if ( not $phrase and my $code = $self->_check_word( $match, $self->{stopwords} ) ) {
|
||||
$reject{ $match } = $code;
|
||||
next;
|
||||
}
|
||||
|
||||
# now, see if we should toss this word
|
||||
$words{$match} = {
|
||||
mode => $mode,
|
||||
phrase => $phrase,
|
||||
substring => $substring,
|
||||
keyword => not $phrase,
|
||||
};
|
||||
}
|
||||
|
||||
# words is a hashref of:
|
||||
# {
|
||||
# word => {
|
||||
# paramaters => 'values'
|
||||
# },
|
||||
# word1 => {
|
||||
# ...
|
||||
# },
|
||||
# ...
|
||||
# }
|
||||
#
|
||||
return( \%words, \%reject );
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub _filter_query {
|
||||
#--------------------------------------------------------------------------------
|
||||
# get the results from the filter
|
||||
#
|
||||
my $self = shift;
|
||||
my $filters = shift;
|
||||
my $results = shift or return {};
|
||||
keys %{$results} or return $results;
|
||||
|
||||
my $table = $self->{table};
|
||||
my $tname = $table->name();
|
||||
|
||||
# setup the where clause
|
||||
my $where = $filters->sql() or return $results;
|
||||
my ($pk) = $table->pk;
|
||||
$where .= qq! AND $pk IN (! . join(',', keys %$results) . ')';
|
||||
|
||||
# now do the filter
|
||||
my $query = qq!
|
||||
SELECT $pk
|
||||
FROM
|
||||
$tname
|
||||
WHERE
|
||||
$where
|
||||
!;
|
||||
$self->debug( "Filter Query: $query" ) if ($self->{_debug});
|
||||
my $sth = $self->{table}->{driver}->prepare($query);
|
||||
$sth->execute();
|
||||
|
||||
# get all the results
|
||||
my $aref = $sth->fetchall_arrayref;
|
||||
return {
|
||||
map {
|
||||
$_->[0] => $results->{$_->[0]}
|
||||
} @$aref
|
||||
};
|
||||
}
|
||||
|
||||
sub _create_buckets {
|
||||
#------------------------------------------------------------
|
||||
# takes the output from _parse_query_string and creates a
|
||||
# bucket hash of all the different types of searching
|
||||
# possible
|
||||
my $query = shift or return;
|
||||
|
||||
my %buckets;
|
||||
|
||||
# put each word in the appropriate hash bucket
|
||||
foreach my $parameter ( keys %{$query} ) {
|
||||
|
||||
my $word_data = $query->{$parameter};
|
||||
|
||||
# the following is slower, however, done that way to be syntatically legible
|
||||
if ( $word_data->{'phrase'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'} =~ /(must|cannot)/ ))) {
|
||||
$buckets{"phrases_$1"}->{$parameter} = $word_data;
|
||||
}
|
||||
elsif ( $word_data->{'phrase'} ) {
|
||||
$buckets{'phrases'}->{$parameter} = $word_data;
|
||||
}
|
||||
elsif ( $word_data->{'keyword'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'}=~ /(must|cannot|greater|less)/) )) {
|
||||
$buckets{"keywords_$1"}->{$parameter} = $word_data;
|
||||
}
|
||||
else {
|
||||
$buckets{'keywords'}->{$parameter} = $word_data;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return \%buckets;
|
||||
}
|
||||
|
||||
sub alternate_driver_query {
|
||||
#--------------------------------------------------------------------------------
|
||||
my ( $self, $drivername, $input ) = @_;
|
||||
|
||||
$drivername = uc $drivername;
|
||||
require GT::SQL::Search;
|
||||
my $driver = GT::SQL::Search->load_search({ %$input, table => $self->{table}, driver => $drivername });
|
||||
my $sth = $driver->query( $input );
|
||||
foreach ( qw( rows rejected_keywords ) ) { $self->{$_} = $driver->{$_}; }
|
||||
return $sth;
|
||||
|
||||
}
|
||||
|
||||
sub clean_sb {
|
||||
# -------------------------------------------------------------------------------
|
||||
# Convert the sort by, sort order into an sql string.
|
||||
#
|
||||
my ($class, $sb, $so) = @_;
|
||||
my $output = '';
|
||||
|
||||
return $output unless ($sb);
|
||||
|
||||
# Remove score attribute, used only for internal indexes.
|
||||
$sb =~ s/^\s*score\b//;
|
||||
$sb =~ s/,?\s*\bscore\b//;
|
||||
|
||||
if ($sb and not ref $sb) {
|
||||
if ($sb =~ /^[\w\s,]+$/) {
|
||||
if ($sb =~ /\s(?:asc|desc)/i) {
|
||||
$output = 'ORDER BY ' . $sb;
|
||||
}
|
||||
else {
|
||||
$output = 'ORDER BY ' . $sb . ' ' . $so;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$class->error('BADSB', 'WARN', $sb);
|
||||
}
|
||||
}
|
||||
elsif (ref $sb eq 'ARRAY') {
|
||||
foreach ( @$sb ) {
|
||||
/^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next;
|
||||
}
|
||||
$output = 'ORDER BY ' . join(',', @$sb);
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub debug_dumper {
|
||||
#--------------------------------------------------------------------------------
|
||||
# calls debug but also dumps all the messages
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
my $level = ref $_[0] ? 1 : defined $_[0] ? shift : 0;
|
||||
|
||||
if ( $self->{_debug} >= $level ) {
|
||||
require GT::Dumper;
|
||||
$self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug});
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
411
site/glist/lib/GT/SQL/Search/INTERNAL/Indexer.pm
Normal file
411
site/glist/lib/GT/SQL/Search/INTERNAL/Indexer.pm
Normal file
@@ -0,0 +1,411 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::INTERNAL::Indexer
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Indexer.pm,v 1.11 2004/01/13 01:35:19 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::SQL::Search::INTERNAL::Indexer;
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG /;
|
||||
use GT::SQL::Search::Base::Indexer;
|
||||
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
sub load {
|
||||
shift;
|
||||
return GT::SQL::Search::INTERNAL::Indexer->new(@_)
|
||||
}
|
||||
|
||||
sub drop_search_driver {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $table = $self->{table}->name;
|
||||
my $rc1 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Word_List");
|
||||
my $rc2 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Score_List");
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub add_search_driver {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $name = $self->{table}->name;
|
||||
|
||||
# first create the table that handles the words.
|
||||
my $creator = $self->{table}->creator ( $name . "_Word_List" );
|
||||
$creator->cols(
|
||||
Word_ID => {
|
||||
pos => 1,
|
||||
type => 'int',
|
||||
not_null => 1,
|
||||
unsigned => 1
|
||||
},
|
||||
Word => {
|
||||
pos => 2,
|
||||
type => 'varchar',
|
||||
not_null=> 1,
|
||||
size => '50'
|
||||
},
|
||||
Frequency => {
|
||||
pos => 3,
|
||||
type => 'int',
|
||||
not_null=> 1
|
||||
}
|
||||
);
|
||||
$creator->pk('Word_ID');
|
||||
$creator->ai('Word_ID');
|
||||
$creator->unique({ $name . "_wordndx" => ['Word'] });
|
||||
$creator->create('force') or return;
|
||||
|
||||
# now create the handler for scores
|
||||
$creator = $self->{table}->creator( $name . '_Score_List' );
|
||||
$creator->cols(
|
||||
Word_ID => {
|
||||
pos => 1,
|
||||
type => 'int',
|
||||
not_null => 1,
|
||||
unsigned => 1
|
||||
},
|
||||
Item_ID => {
|
||||
pos => 2,
|
||||
type => 'int',
|
||||
not_null => 1,
|
||||
unsigned => 1
|
||||
},
|
||||
Score => {
|
||||
pos => 3,
|
||||
type => 'int',
|
||||
not_null => 1
|
||||
},
|
||||
Word_Pos => {
|
||||
pos => 4,
|
||||
type => 'int',
|
||||
not_null => 1
|
||||
}
|
||||
);
|
||||
$creator->index({ 'wndx' => ['Word_ID', 'Item_ID', 'Score'], 'itndx' => ['Item_ID'] });
|
||||
$creator->create('force') or return;
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub post_create_table {
|
||||
# ------------------------------------------------------------------------------
|
||||
# creates the index tables..
|
||||
#
|
||||
return $_[0]->add_search_driver(@_);
|
||||
}
|
||||
|
||||
sub post_drop_table {
|
||||
# -------------------------------------------------------
|
||||
# Remove the index tables.
|
||||
#
|
||||
return $_[0]->drop_search_driver(@_);
|
||||
}
|
||||
|
||||
sub init_queries {
|
||||
# -------------------------------------------------------
|
||||
# Pre-load all our queries.
|
||||
#
|
||||
my $self = shift;
|
||||
my $queries = shift;
|
||||
|
||||
my $driver = $self->{table}->{driver} or return $self->error ('NODRIVER', 'FATAL');
|
||||
my $table_name = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL');
|
||||
my $wtable = $table_name . '_Word_List';
|
||||
my $seq = $wtable . '_seq';
|
||||
my $stable = $table_name . '_Score_List';
|
||||
|
||||
my %ai_queries = (
|
||||
ins_word_ORACLE => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES ($seq.NEXTVAL, ?, ?)",
|
||||
ins_word_PG => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES (NEXTVAL('$seq'), ?, ?)",
|
||||
ins_word => "INSERT INTO $wtable (Word, Frequency) VALUES (?, ?)"
|
||||
);
|
||||
my %queries = (
|
||||
upd_word => "UPDATE $wtable SET Frequency = ? WHERE Word_ID = ?",
|
||||
sel_word => "SELECT Word_ID,Word,Frequency FROM $wtable WHERE Word = ?",
|
||||
sel_freq => "SELECT Frequency FROM $wtable WHERE Word_ID = ?",
|
||||
del_word => "DELETE FROM $wtable WHERE Word_ID = ?",
|
||||
mod_word => "UPDATE $wtable SET Frequency = Frequency - ? WHERE Word_ID = ?",
|
||||
ins_scor => "INSERT INTO $stable (Word_ID, Item_ID, Score, Word_Pos) VALUES (?, ?, ?, ?)",
|
||||
item_cnt => "SELECT Word_ID, COUNT(*) FROM $stable WHERE Item_ID = ? GROUP BY Word_ID",
|
||||
scr_del => "DELETE FROM $stable WHERE Item_ID = ?",
|
||||
dump_word => "DELETE FROM $wtable",
|
||||
dump_scor => "DELETE FROM $stable"
|
||||
);
|
||||
my $type = uc $self->{table}->{connect}->{driver};
|
||||
$self->{ins_word} = $driver->prepare($ai_queries{"ins_word_$type"} || $ai_queries{"ins_word"});
|
||||
|
||||
# check to see if the table exist
|
||||
$self->{table}->new_table( $wtable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error);
|
||||
$self->{table}->new_table( $stable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error);
|
||||
|
||||
|
||||
if ($type eq 'MYSQL') {
|
||||
foreach my $query (keys %queries) {
|
||||
$self->{$query} = $driver->prepare_raw ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error);
|
||||
}
|
||||
}
|
||||
else {
|
||||
foreach my $query (keys %queries) {
|
||||
$self->{$query} = $driver->prepare ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub post_add_record {
|
||||
# -------------------------------------------------------
|
||||
# indexes a single record
|
||||
my ($self, $rec, $insert_sth ) = @_;
|
||||
|
||||
# Only continue if we have weights and a primary key.
|
||||
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
|
||||
my %weights = $tbl->_weight_cols() or return;
|
||||
my ($pk) = $tbl->pk();
|
||||
my $item_id = ( $tbl->ai() and $insert_sth ) ? $insert_sth->insert_id() : $rec->{$pk};
|
||||
my $index = 0;
|
||||
|
||||
$self->{init} or $self->init_queries;
|
||||
|
||||
# Go through each column and index it.
|
||||
foreach my $column ( keys %weights ) {
|
||||
my ($word_list, $rejected) = $self->_tokenize( $rec->{$column} );
|
||||
$word_list or next;
|
||||
|
||||
# Build a hash of word => frequency.
|
||||
my %words;
|
||||
foreach my $word (@{$word_list}) {
|
||||
$words{$word}++;
|
||||
}
|
||||
|
||||
# Add the words in, or update frequency.
|
||||
my %word_ids = ();
|
||||
while (my ($word, $freq) = each %words) {
|
||||
$self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
my $word_r = $self->{sel_word}->fetchrow_arrayref; # Word_ID, Word, Frequency
|
||||
if ($word_r) {
|
||||
$word_r->[2] += $freq;
|
||||
$word_ids{$word} = $word_r->[0];
|
||||
$self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
else {
|
||||
$self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
$word_ids{$word} = $self->{ins_word}->insert_id();
|
||||
}
|
||||
}
|
||||
# now that we have the word ids, insert each of the word-points
|
||||
my $weight = $weights{$column};
|
||||
foreach my $word ( @{$word_list} ) {
|
||||
$self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
$index++;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub reindex_all {
|
||||
# -------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $table = shift;
|
||||
my $opts = shift;
|
||||
my $tick = $opts->{tick} || 0;
|
||||
my $max = $opts->{max} || 5000;
|
||||
|
||||
my %weights = $self->{table}->_weight_cols() or return;
|
||||
my @weight_list = keys %weights;
|
||||
my @weight_arr = map { $weights{$_} } @weight_list;
|
||||
my ($pk) = $self->{table}->pk();
|
||||
my $index = 0;
|
||||
my $word_id = 1;
|
||||
$self->{init} or $self->init_queries;
|
||||
|
||||
# first nuke the current index
|
||||
$self->dump_index();
|
||||
|
||||
# Go through the table and index each field.
|
||||
my $iterations = 1;
|
||||
my $count = 0;
|
||||
|
||||
while (1) {
|
||||
if ($max) {
|
||||
my $offset = ($iterations-1) * $max;
|
||||
$table->select_options ( "LIMIT $offset,$max");
|
||||
}
|
||||
my $cond = $opts->{cond} || {};
|
||||
my $sth = $table->select($cond, [ $pk, @weight_list] );
|
||||
my $done = 1;
|
||||
|
||||
while ( my $arrayref = $sth->fetchrow_arrayref() ) {
|
||||
# the primary key value
|
||||
my $i = 0;
|
||||
my $item_id = $arrayref->[($i++)];
|
||||
$index = 0;
|
||||
$done = 0;
|
||||
|
||||
# start going through the record data
|
||||
foreach my $weight ( @weight_arr ) {
|
||||
my ($word_list, $junk) = $self->_tokenize( $arrayref->[$i++] );
|
||||
$word_list or next;
|
||||
|
||||
# Build a hash of word => frequency.
|
||||
my %words;
|
||||
foreach my $word (@{$word_list}) {
|
||||
$words{$word}++;
|
||||
}
|
||||
|
||||
# Add the words in, or update frequency.
|
||||
my %word_ids = ();
|
||||
while (my ($word, $freq) = each %words) {
|
||||
$self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
my $word_r = $self->{sel_word}->fetchrow_arrayref; # WordID,Word,Freq
|
||||
if ($word_r) {
|
||||
$word_r->[2] += $freq;
|
||||
$word_ids{$word} = $word_r->[0];
|
||||
$self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
else {
|
||||
$self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
$word_ids{$word} = $self->{ins_word}->insert_id();
|
||||
}
|
||||
}
|
||||
# now that we have the word ids, insert each of the word-points
|
||||
foreach my $word ( @{$word_list} ) {
|
||||
$self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
$index++;
|
||||
}
|
||||
if ($tick) {
|
||||
$count++;
|
||||
$count % $tick or (print "$count ");
|
||||
$count % ($tick*10) or (print "\n");
|
||||
}
|
||||
}
|
||||
return if ($done);
|
||||
$iterations++;
|
||||
return if (! $max);
|
||||
}
|
||||
}
|
||||
|
||||
sub pre_delete_record {
|
||||
# -------------------------------------------------------
|
||||
# Delete a records index values.
|
||||
#
|
||||
my $self = shift;
|
||||
my $where = shift;
|
||||
|
||||
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
|
||||
my %weights = $tbl->_weight_cols() or return;
|
||||
my ($pk) = $tbl->pk();
|
||||
my $q = $tbl->select( $where, [ $pk ] );
|
||||
|
||||
while ( my $aref = $q->fetchrow_arrayref() ) {
|
||||
my $item_id = $aref->[0] or next;
|
||||
my @weight_list = keys %weights;
|
||||
my $index = 0;
|
||||
$self->{init} or $self->init_queries;
|
||||
|
||||
# Get a frequency count for each word
|
||||
$self->{item_cnt}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
|
||||
# Now go through and either decrement the freq, or remove the entry.
|
||||
while ( my ($word_id, $frequency) = $self->{item_cnt}->fetchrow_array() ) {
|
||||
$self->{sel_freq}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
$self->debug( "Deleting frequencies for $word_id. decreasing by $frequency" ) if ($self->{_debug});
|
||||
if (my $freq = $self->{sel_freq}->fetchrow_arrayref) {
|
||||
if ($freq->[0] == $frequency) {
|
||||
$self->{del_word}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
else {
|
||||
$self->{mod_word}->execute($frequency, $word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
}
|
||||
}
|
||||
# Remove the listings from the scores table.
|
||||
$self->{scr_del}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub post_update_record {
|
||||
# -------------------------------------------------------
|
||||
my ( $self, $set_cond, $where_cond, $tmp ) = @_;
|
||||
|
||||
# delete the previous record
|
||||
$self->pre_delete_record( $where_cond ) or return;
|
||||
#
|
||||
# the new record
|
||||
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
|
||||
my $q = $tbl->select( $where_cond );
|
||||
while ( my $href = $q->fetchrow_hashref() ) {
|
||||
$self->post_add_record( $href );
|
||||
}
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub reindex_record {
|
||||
# -------------------------------------------------------
|
||||
# reindexes a record. basically deletes all associated records from current db abnd does an index.
|
||||
# it's safe to use this
|
||||
my $self = shift;
|
||||
my $rec = shift;
|
||||
|
||||
$self->delete_record($rec);
|
||||
$self->index_record($rec);
|
||||
}
|
||||
|
||||
sub dump_index {
|
||||
# -------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->{init} or $self->init_queries;
|
||||
|
||||
$self->{dump_word}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
$self->{dump_scor}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
|
||||
|
||||
sub debug_dumper {
|
||||
# ------------------------------------------------------------------------------
|
||||
# calls debug but also dumps all the messages
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
my $level = ref $_[0] ? 1 : shift;
|
||||
|
||||
if ( $self->{_debug} >= $level ) {
|
||||
require GT::Dumper;
|
||||
$self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ ));
|
||||
}
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Calls finish on init queries.
|
||||
#
|
||||
my $self = shift;
|
||||
return unless ($self->{init});
|
||||
$self->{upd_word}->finish;
|
||||
# $self->{ins_word}->finish; will get finished automatically
|
||||
$self->{sel_word}->finish;
|
||||
$self->{sel_freq}->finish;
|
||||
$self->{del_word}->finish;
|
||||
$self->{mod_word}->finish;
|
||||
$self->{ins_scor}->finish;
|
||||
$self->{item_cnt}->finish;
|
||||
$self->{scr_del}->finish;
|
||||
$self->{dump_word}->finish;
|
||||
$self->{dump_scor}->finish;
|
||||
$self->{init} = 0;
|
||||
}
|
||||
|
||||
1;
|
||||
604
site/glist/lib/GT/SQL/Search/INTERNAL/Search.pm
Normal file
604
site/glist/lib/GT/SQL/Search/INTERNAL/Search.pm
Normal file
@@ -0,0 +1,604 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Indexer
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Search.pm,v 1.18 2004/08/28 03:53:47 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Class used to make changes to tables and create tables.
|
||||
#
|
||||
|
||||
package GT::SQL::Search::INTERNAL::Search;
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/@ISA $VERSION $DEBUG $ATTRIBS /;
|
||||
use GT::SQL::Search::Base::Search;
|
||||
@ISA = qw( GT::SQL::Search::Base::Search );
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
# the max number of links that can be handled by UNION before it should simply
|
||||
# shunt the searching pipe to NONINDEXED system
|
||||
'union_shunt_threshold' => '5000',
|
||||
'phrase_shunt_threshold' => '1000',
|
||||
};
|
||||
|
||||
|
||||
################################################################################
|
||||
# Internal functions
|
||||
################################################################################
|
||||
|
||||
sub load {
|
||||
shift;
|
||||
return GT::SQL::Search::INTERNAL::Search->new(@_)
|
||||
}
|
||||
|
||||
sub _query {
|
||||
# ------------------------------------------------------------------------------
|
||||
# this just checks to ensure that the words are not all search keywords
|
||||
#
|
||||
my ( $self, $input, $buckets ) = @_;
|
||||
|
||||
# calculate wordids and frequencies
|
||||
foreach ( keys %$buckets ) {
|
||||
$buckets->{$_} = $self->get_wordids( $buckets->{$_}, ( /phrase/ ? "phrases" : "keywords" ) );
|
||||
}
|
||||
|
||||
# the following is a bit tricky and will be replaced however, if the number
|
||||
# of results from a union is more than the maximum shunt value, it will
|
||||
# simply do a nonindexed query
|
||||
if ( $buckets->{keywords} ) {
|
||||
my $rec = _count_frequencies( $buckets->{keywords} );
|
||||
my $count = 0;
|
||||
foreach ( values %$rec ) { $count += $_; }
|
||||
if ($count > $self->{union_shunt_threshold}) {
|
||||
$self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug});
|
||||
return $self->alternate_driver_query( 'NONINDEXED', $input );
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Now test the phrases. Just due to how the phrase searching works, the queries
|
||||
# can grow in size extremely rapidly, and slowdown the search. So the limit for
|
||||
# phrase searching is separate as it requires a different cutoff value than
|
||||
# the keyword search which is usually much lower!
|
||||
if ($buckets->{phrases}) {
|
||||
foreach my $phrase ( keys %{$buckets->{phrases} || {} } ) {
|
||||
my $rec = _count_frequencies( $buckets->{phrases}->{$phrase}->{word_info} );
|
||||
my ( $count ) = sort values %$rec; # Get smallest frequency.
|
||||
if ( $count > $self->{phrase_shunt_threshold} ) {
|
||||
$self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug});
|
||||
return $self->alternate_driver_query( 'NONINDEXED', $input );
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($buckets->{phrases_must}) {
|
||||
foreach my $phrase ( keys %{$buckets->{phrases_must} || {} } ) {
|
||||
my $rec = _count_frequencies( $buckets->{phrases_must}->{$phrase}->{word_info} );
|
||||
my ( $count ) = sort values %$rec; # Get smallest frequency.
|
||||
if ( $count > $self->{phrase_shunt_threshold} ) {
|
||||
$self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug});
|
||||
return $self->alternate_driver_query( 'NONINDEXED', $input );
|
||||
}
|
||||
}
|
||||
}
|
||||
return $self->SUPER::_query( $input, $buckets );
|
||||
}
|
||||
|
||||
sub _count_frequencies {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $word_info = shift;
|
||||
my $rec = {};
|
||||
foreach my $word ( keys %$word_info ) {
|
||||
my $freq = 0;
|
||||
foreach ( values %{$word_info->{$word}->{word_info}} ) {
|
||||
$freq += $_;
|
||||
}
|
||||
$rec->{$word} = $freq;
|
||||
}
|
||||
|
||||
return $rec;
|
||||
}
|
||||
|
||||
sub _table_names {
|
||||
# ------------------------------------------------------------------------------
|
||||
# return the table names
|
||||
#
|
||||
my $self = shift;
|
||||
my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL');
|
||||
my $wtable = $table . '_Word_List';
|
||||
my $stable = $table . '_Score_List';
|
||||
|
||||
return ( $table, $wtable, $stable);
|
||||
}
|
||||
|
||||
sub _word_infos {
|
||||
# ------------------------------------------------------------------------------
|
||||
# get the word ids and frequencies
|
||||
#
|
||||
my $self = shift;
|
||||
my $word_infos = shift;
|
||||
|
||||
my $rec = {};
|
||||
|
||||
foreach my $word ( keys %$word_infos ) {
|
||||
my $wi = $word_infos->{$word}->{word_info};
|
||||
$rec->{$word} = [ map { [ $_, $wi->{$_} ] } keys %$wi ];
|
||||
}
|
||||
|
||||
return $rec;
|
||||
|
||||
}
|
||||
|
||||
sub _union_query {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Takes a list of words and gets all words that match
|
||||
# returns { itemid -> score } of hits that match
|
||||
#
|
||||
my $self = shift;
|
||||
my $words = shift;
|
||||
my $results = shift || {};
|
||||
my ( $query, $where, $db, $word_infos );
|
||||
my ( $table, $wtable, $stable) = $self->_table_names();
|
||||
|
||||
$db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' );
|
||||
$word_infos = $self->_word_infos( $words ) or return $results;
|
||||
|
||||
return $results unless (keys %{$word_infos});
|
||||
|
||||
$self->debug_dumper( "Getting words: ", $words) if ($self->{_debug});
|
||||
|
||||
# build the where clause
|
||||
my @word_ids;
|
||||
foreach my $word_synonym_list ( values %$word_infos ) {
|
||||
next unless ( $word_synonym_list );
|
||||
foreach my $word_id ( @{$word_synonym_list }) {
|
||||
next unless ( ref $word_id eq 'ARRAY' ); # ensure it's a reference
|
||||
push @word_ids, $word_id->[0]; # we need to shed the word quantities
|
||||
}
|
||||
}
|
||||
|
||||
return $results unless ( @word_ids );
|
||||
$where = 'Word_ID IN(' . join(",", @word_ids) . ")";
|
||||
|
||||
# build the query
|
||||
$query = qq!
|
||||
SELECT Item_ID, SUM(Score)
|
||||
FROM $stable
|
||||
WHERE
|
||||
$where
|
||||
GROUP BY Item_ID
|
||||
!;
|
||||
|
||||
$self->debug( "Union Query: $query" ) if ($self->{_debug});
|
||||
|
||||
# prepare the query
|
||||
my $sth = $db->prepare( $query ) or return;
|
||||
$sth->execute() or return;
|
||||
|
||||
# get the results
|
||||
my %word_infos = $sth->fetchall_list;
|
||||
|
||||
# merge the current result set into found
|
||||
foreach my $item ( keys %{$results} ) {
|
||||
$word_infos{$item} += $results->{$item};
|
||||
};
|
||||
|
||||
return \%word_infos;
|
||||
}
|
||||
|
||||
sub _intersect_query {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Takes a list of words and gets all words that match all the keywords
|
||||
# returns { itemid -> score } of hits that match
|
||||
#
|
||||
my $self = shift;
|
||||
my $words = shift;
|
||||
my $results = shift || {};
|
||||
|
||||
$words or return $results;
|
||||
keys %{$words} or return $results;
|
||||
|
||||
my ( $query, $where, $db, $word_infos, $word_hits );
|
||||
my ( $table, $wtable, $stable) = $self->_table_names();
|
||||
|
||||
# have we left any of our words out?
|
||||
$db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' );
|
||||
$word_infos = $self->_word_infos( $words ) or return {};
|
||||
if ( keys %{$word_infos} < keys %{$words} ) {
|
||||
return {};
|
||||
}
|
||||
|
||||
$self->debug_dumper( "Keyword Intersect words: ", $word_infos ) if ($self->{_debug});
|
||||
|
||||
# take the words and get a hash of the word scores
|
||||
foreach my $word ( keys %{$word_infos} ) {
|
||||
|
||||
my $total_freq = 0;
|
||||
foreach my $word_synonyms ( @{$word_infos->{$word}} ) {
|
||||
$total_freq += $word_synonyms->[1];
|
||||
}
|
||||
|
||||
$word_hits->{$word} = $total_freq or return;
|
||||
|
||||
}
|
||||
|
||||
# so now, sort out the words from lowest frequency to highest frequency
|
||||
my @search_order = sort { $word_hits->{$a} <=> $word_hits->{$b} } keys %{$word_hits};
|
||||
|
||||
$self->debug_dumper( "Searching words in this order: ", \@search_order) if ($self->{_debug});
|
||||
|
||||
# find out how we're going to handle the searching, if the first elements
|
||||
|
||||
################################################################################
|
||||
### The following part is for smaller intersect subsets
|
||||
################################################################################
|
||||
my $intersect = $results;
|
||||
foreach my $word ( @search_order ) {
|
||||
|
||||
# setup the where clause to get all the words associated
|
||||
my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")";
|
||||
|
||||
# setup the intersect for the previous if required. for iterative intersecting
|
||||
if ( keys %{$intersect} ) {
|
||||
$where .= " AND Item_ID in(" . join(",",keys %{$intersect}) . ")";
|
||||
}
|
||||
|
||||
# make the database engine work a little bit
|
||||
$query = qq!
|
||||
SELECT Item_ID, SUM(Score) AS Score
|
||||
FROM $stable
|
||||
WHERE
|
||||
$where
|
||||
GROUP BY Item_ID
|
||||
!;
|
||||
$self->debug( "Intersect Query: $query" ) if ($self->{_debug});
|
||||
my $intersect_sth = $db->prepare( $query );
|
||||
|
||||
$intersect_sth->execute();
|
||||
|
||||
# get a list of all the matches
|
||||
my $matches = $intersect_sth->fetchall_arrayref();
|
||||
|
||||
$self->debug_dumper( "Matches found for $word: ", $matches ) if ($self->{_debug});
|
||||
|
||||
# go through all the matches and intersect them
|
||||
my %tmp = ();
|
||||
foreach my $row ( @{$matches} ) {
|
||||
my ( $itemid, $score ) = @{$row};
|
||||
$intersect->{$itemid} ||= 0;
|
||||
$tmp{ $itemid } = $intersect->{$itemid} + $score;
|
||||
}
|
||||
|
||||
# inform the system of that development
|
||||
%tmp or return;
|
||||
$intersect = \%tmp;
|
||||
}
|
||||
|
||||
return $intersect;
|
||||
}
|
||||
|
||||
sub _disjoin_query {
|
||||
#------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $words = shift;
|
||||
my $results = shift || {};
|
||||
$words or return $results;
|
||||
|
||||
my ( $query, $where, $db, $word_infos, $word_hits );
|
||||
my ( $table, $wtable, $stable) = $self->_table_names();
|
||||
|
||||
$db = $self->{table}->{driver} or return $results;
|
||||
|
||||
# have we left any of our words out?
|
||||
$word_infos = $self->_word_infos( $words ) or return $results;
|
||||
# if ( keys %{$word_infos} < keys %{$words} ) {
|
||||
# return $results;
|
||||
# }
|
||||
|
||||
# take the words and get a hash of the word scores
|
||||
foreach my $word ( keys %{$word_infos} ) {
|
||||
my $total_freq = 0;
|
||||
foreach my $word_synonyms ( $word_infos->{$word} ) {
|
||||
$total_freq += ( $word_synonyms->[0] || 0 );
|
||||
}
|
||||
# if the value is null this mean there is actually no results, whoops!
|
||||
$total_freq and $word_hits->{$word} = $total_freq;
|
||||
}
|
||||
|
||||
# so now, sort out the words from lowest frequency to highest frequency
|
||||
my @search_order = sort { $word_hits->{$b} <=> $word_hits->{$b} } keys %{$word_hits};
|
||||
$self->debug_dumper( "Disjoining words in the following order: ", \@search_order) if ($self->{_debug});
|
||||
|
||||
################################################################################
|
||||
### This following part is for smaller disjoin presets
|
||||
################################################################################
|
||||
foreach my $word ( @search_order ) {
|
||||
|
||||
# setup the where clause to get all the words associated
|
||||
my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")";
|
||||
|
||||
# setup the intersect for the previous if required. for iterative intersecting
|
||||
if ( keys %{$results} ) {
|
||||
$where .= " AND Item_ID in(" . join(",", keys %{$results}) . ")";
|
||||
}
|
||||
|
||||
# make the database engine work a little bit
|
||||
$query = qq!
|
||||
SELECT Item_ID
|
||||
FROM $stable
|
||||
WHERE
|
||||
$where
|
||||
GROUP BY Item_ID
|
||||
!;
|
||||
$self->debug($query) if ($self->{_debug});
|
||||
my $intersect_sth = $db->prepare( $query );
|
||||
|
||||
$intersect_sth->execute();
|
||||
|
||||
# get a list of all the matches
|
||||
my $matches = $intersect_sth->fetchall_arrayref();
|
||||
|
||||
# strip the matches from the current result set
|
||||
foreach my $word ( map { $_->[0] } @{$matches}) {
|
||||
delete $results->{$word};
|
||||
}
|
||||
}
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub _phrase_disjoin_query {
|
||||
#------------------------------------------------------------
|
||||
# subtracts the found phrases from the list
|
||||
my $self = shift;
|
||||
my $phrases = shift;
|
||||
my $results = shift || {};
|
||||
$phrases or return $results;
|
||||
|
||||
foreach my $phrase ( values %{$phrases} ) {
|
||||
my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} );
|
||||
|
||||
# perform disjoin
|
||||
foreach my $itemid ( keys %{$temp} ) {
|
||||
$self->debug( "Deleting $itemid from list" ) if ($self->{_debug});
|
||||
delete $results->{$itemid};
|
||||
}
|
||||
}
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub _phrase_intersect_query {
|
||||
#------------------------------------------------------------
|
||||
# intersects phrases together
|
||||
my $self = shift;
|
||||
my $phrases = shift;
|
||||
my $results = shift || {};
|
||||
|
||||
$phrases or return $results;
|
||||
|
||||
foreach my $phrase ( values %{$phrases} ) {
|
||||
my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} );
|
||||
|
||||
# perform intersect
|
||||
foreach my $itemid ( keys %{$temp} ) {
|
||||
$temp->{$itemid} += $results->{$itemid} || 0;
|
||||
}
|
||||
$results = $temp;
|
||||
|
||||
}
|
||||
|
||||
return $results;
|
||||
|
||||
}
|
||||
|
||||
sub _phrase_query {
|
||||
#------------------------------------------------------------
|
||||
# this is a phrase union query
|
||||
my $self = shift;
|
||||
my $phrases = shift or return;
|
||||
my $results = shift || {};
|
||||
|
||||
foreach my $phrase ( values %{$phrases} ) {
|
||||
$self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug});
|
||||
$results = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info}, $results );
|
||||
}
|
||||
|
||||
return $results;
|
||||
|
||||
}
|
||||
|
||||
sub _get_phrase {
|
||||
#------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $wordlist= shift;
|
||||
my $word_info = shift;
|
||||
my $results = shift || {};
|
||||
|
||||
$wordlist or return $results;
|
||||
|
||||
my ( $query, $where, $db, $word_infos, %word_hits );
|
||||
my ( $table, $wtable, $stable) = $self->_table_names();
|
||||
my ($pk) = $self->{table}->pk;
|
||||
|
||||
$self->debug_dumper( "Getting words: ", $wordlist ) if ($self->{_debug});
|
||||
|
||||
# get all the word ids that we want to handle
|
||||
$db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' );
|
||||
$word_infos = $self->_word_infos( $word_info ) or return;
|
||||
|
||||
|
||||
$self->debug_dumper( "Word infos: ", $word_infos ) if ($self->{_debug});
|
||||
|
||||
# take the words and get a hash of the word scores
|
||||
foreach my $word ( keys %{$word_infos} ) {
|
||||
|
||||
@{$word_infos->{$word} || []} or return;
|
||||
|
||||
my $total_freq = 0;
|
||||
foreach my $word_synonyms ( @{$word_infos->{$word}} ) {
|
||||
$total_freq += $word_synonyms->[1];
|
||||
}
|
||||
|
||||
# if the value is null this mean there is actually no results, whoops!
|
||||
$word_hits{$word} = $total_freq;
|
||||
}
|
||||
|
||||
$self->debug_dumper( "With synonyms tallied: ", \%word_hits ) if ($self->{_debug});
|
||||
|
||||
# so now, setup the order of search
|
||||
my $i = 0;
|
||||
my %word_order = map { $_ => $i++ } @{$wordlist};
|
||||
my @search_order = sort { $word_hits{$a} <=> $word_hits{$b} } keys %word_hits;
|
||||
|
||||
$self->debug_dumper( "Word search order: ", \@search_order ) if ($self->{_debug});
|
||||
|
||||
################################################################################
|
||||
### This following part is for smaller phrases
|
||||
################################################################################
|
||||
# start getting words in order of their frequency
|
||||
my %matches = ();
|
||||
my $index = 0;
|
||||
foreach my $word ( @search_order ) {
|
||||
|
||||
# setup the where clause for the individual words, firstly
|
||||
if ( keys %matches ) {
|
||||
my $vector = $word_order{$word} - $index;
|
||||
$where = '(';
|
||||
$where =
|
||||
'(' .
|
||||
join(
|
||||
" OR ",
|
||||
map(
|
||||
"Item_ID = $_ AND Word_Pos IN(" . join(",", map $_->[0] + $vector, @{$matches{$_}}) . ')',
|
||||
keys %matches
|
||||
)
|
||||
) .
|
||||
") AND ";
|
||||
}
|
||||
else {
|
||||
$where = '';
|
||||
}
|
||||
|
||||
$where .= "Word_ID IN(" . ( join ",", map { $_->[0] || () } @{$word_infos->{$word}} or return $results ) . ')';
|
||||
|
||||
$query = qq!
|
||||
SELECT
|
||||
Item_ID, Score, Word_Pos
|
||||
FROM
|
||||
$stable
|
||||
WHERE
|
||||
$where
|
||||
!;
|
||||
|
||||
$self->debug( "Phrase get for '$word': " . $query ) if ($self->{_debug});
|
||||
my $sth = $db->prepare( $query );
|
||||
$sth->execute();
|
||||
|
||||
%matches = ();
|
||||
|
||||
while (my $hit = $sth->fetchrow_arrayref) {
|
||||
push @{$matches{$hit->[0]}}, [ $hit->[2], $hit->[1] ];
|
||||
}
|
||||
|
||||
# If there are no values stored in %matches, it means that for
|
||||
# this keyword, there have been no hits based upon position.
|
||||
# In that case, terminate and return a null result
|
||||
keys %matches or last;
|
||||
|
||||
# where were we in the string?
|
||||
$index = $word_order{$word};
|
||||
}
|
||||
|
||||
# now tally up all the scores and merge the new records in
|
||||
foreach my $itemid ( keys %matches ) {
|
||||
my $score = 0;
|
||||
foreach my $sub_total ( @{$matches{$itemid}} ) {
|
||||
$score += $sub_total->[1];
|
||||
}
|
||||
$results->{$itemid} += $score;
|
||||
}
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub get_wordids {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Get a list of words
|
||||
#
|
||||
my $self = shift;
|
||||
my $elements = shift or return;
|
||||
my $mode = lc shift || 'keywords';
|
||||
|
||||
if ( $mode eq 'keywords' ) {
|
||||
$elements = $self->_get_wordid($elements);
|
||||
}
|
||||
else {
|
||||
foreach my $phrase ( keys %$elements ) {
|
||||
my $results = $self->_get_wordid({
|
||||
map { ($_ => { substring => 0 }) } @{$elements->{$phrase}->{phrase}}
|
||||
});
|
||||
|
||||
$elements->{$phrase}->{word_info} = $results;
|
||||
}
|
||||
}
|
||||
|
||||
return $elements;
|
||||
}
|
||||
|
||||
sub _get_wordid {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Get a list of words
|
||||
#
|
||||
my $self = shift;
|
||||
my $words = shift;
|
||||
my $tbl = $self->{table};
|
||||
|
||||
my ( $table, $wtable, $stable) = $self->_table_names();
|
||||
|
||||
foreach my $word ( keys %$words ) {
|
||||
my $query =
|
||||
qq!SELECT Word_ID, Frequency FROM $wtable WHERE Word LIKE '! .
|
||||
quotemeta($word) .
|
||||
( $words->{$word}->{substring} ? '%' : '' ) .
|
||||
"'";
|
||||
my $sth = $tbl->do_query($query) or next;
|
||||
my $tmp = { $sth->fetchall_list };
|
||||
|
||||
$words->{$word}->{word_info} = $tmp;
|
||||
}
|
||||
|
||||
return $words;
|
||||
}
|
||||
|
||||
##
|
||||
# Internal Use
|
||||
# $self->_cgi_to_hash ($in);
|
||||
# --------------------------
|
||||
# Creates a hash ref from a cgi object.
|
||||
##
|
||||
sub _cgi_to_hash {
|
||||
my ($self, $cgi) = @_;
|
||||
$cgi and UNIVERSAL::can($cgi, 'param') or return $self->error(NODRIVER => 'FATAL');
|
||||
my @keys = $cgi->param;
|
||||
my $result = {};
|
||||
foreach my $key (@keys) {
|
||||
my @values = $cgi->param($key);
|
||||
if (@values == 1) { $result->{$key} = $values[0] }
|
||||
else { $result->{$key} = \@values }
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
98
site/glist/lib/GT/SQL/Search/MSSQL/Indexer.pm
Normal file
98
site/glist/lib/GT/SQL/Search/MSSQL/Indexer.pm
Normal file
@@ -0,0 +1,98 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MSSQL::Indexer
|
||||
# Author: Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Indexer.pm,v 1.6 2004/08/28 03:53:48 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Supports MS SQL full text indexer on MS SQL 2000 only.
|
||||
#
|
||||
|
||||
package GT::SQL::Search::MSSQL::Indexer;
|
||||
#--------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/@ISA $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/;
|
||||
use GT::SQL::Search::Base::Indexer;
|
||||
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
$ERRORS = {
|
||||
NOTFROMWEB => 'There are far too many records in table %s for create/destroy of this indexing scheme from the web. Please use alternative method.',
|
||||
MSSQLNONSUPPORT => 'You must be using MS SQL 2000 in order to use full text indexing. Current Database: %s',
|
||||
CREATEINDEX => 'Problem Creating Full Text Index: %s'
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
sub load {
|
||||
my $class = shift;
|
||||
return $class->new(@_);
|
||||
}
|
||||
|
||||
sub ok {
|
||||
#--------------------------------------------------------------------------------
|
||||
my ($class, $tbl) = @_;
|
||||
unless (uc $tbl->{connect}->{driver} eq 'ODBC') {
|
||||
return $class->error ('MSSQLNONSUPPORT', 'WARN', $tbl->{connect}->{driver});
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub drop_search_driver {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $table = $self->{table};
|
||||
my $name = $table->name;
|
||||
my $cat = $name . '_ctlg';
|
||||
|
||||
my $res = eval {
|
||||
$table->do_query(" sp_fulltext_table '$name', 'drop' ");
|
||||
$table->do_query(" sp_fulltext_catalog '$cat', 'drop' ");
|
||||
1;
|
||||
};
|
||||
$res ? return 1 : return;
|
||||
}
|
||||
|
||||
sub add_search_driver {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $table = $self->{table};
|
||||
my $name = $table->name;
|
||||
my $cat = $name . '_ctlg';
|
||||
my %weights = $table->weight;
|
||||
my ($pk) = $table->pk;
|
||||
|
||||
# Enable a database for full text indexing
|
||||
$table->do_query(" sp_fulltext_database 'enable' ") or $self->error('CREATEINDEX', 'FATAL', $GT::SQL::error);
|
||||
# Create a full text catalog to store the data.
|
||||
$table->do_query(" sp_fulltext_catalog '$cat', 'create' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error);
|
||||
# Make a unique index on primary key (not sure why it isn't by default.
|
||||
$table->do_query(" create unique index PK_$name on $name ($pk) ");
|
||||
# Mark this table as using the full text catalog created
|
||||
$table->do_query(" sp_fulltext_table '$name', 'create', '$cat', 'PK_$name' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error);
|
||||
# Specify which columns are to be indexed
|
||||
foreach my $col (keys %weights) {
|
||||
if ($weights{$col}) {
|
||||
$table->do_query(" sp_fulltext_column '$name', '$col', 'add' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error);
|
||||
}
|
||||
}
|
||||
# Must have a timestamp field.
|
||||
$table->do_query(" alter table $name add timestamp ");
|
||||
# Build the index.
|
||||
$table->do_query(" sp_fulltext_table '$name', 'start_change_tracking' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error);
|
||||
$table->do_query(" sp_fulltext_table '$name', 'start_background_updateindex' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub post_create_table {
|
||||
#--------------------------------------------------------------------------------
|
||||
shift->add_search_driver(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
179
site/glist/lib/GT/SQL/Search/MSSQL/Search.pm
Normal file
179
site/glist/lib/GT/SQL/Search/MSSQL/Search.pm
Normal file
@@ -0,0 +1,179 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MSSQL::Search
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Search.pm,v 1.9 2004/08/28 03:53:48 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Class used to search indexed tables.
|
||||
#
|
||||
|
||||
package GT::SQL::Search::MSSQL::Search;
|
||||
#--------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
|
||||
use GT::SQL::Search::Base::Search;
|
||||
@ISA = qw( GT::SQL::Search::Base::Search );
|
||||
|
||||
#--------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
min_word_size => 2,
|
||||
};
|
||||
|
||||
sub load {
|
||||
shift;
|
||||
return GT::SQL::Search::MSSQL::Search->new(@_)
|
||||
}
|
||||
|
||||
sub query {
|
||||
#--------------------------------------------------------------------------------
|
||||
# overruns the usual query system with the mssql version
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Find out what sort of a parameter we're dealing with
|
||||
my $input = $self->common_param(@_);
|
||||
|
||||
# Add additional parameters if required
|
||||
foreach my $parameter ( keys %{$ATTRIBS} ) {
|
||||
if ( not exists $input->{$parameter} ) {
|
||||
$input->{$parameter} = $self->{$parameter};
|
||||
}
|
||||
}
|
||||
|
||||
# Parse query...,
|
||||
my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} );
|
||||
$self->{'rejected_keywords'} = $rejected;
|
||||
|
||||
# Setup the additional input parameters
|
||||
$query = $self->_preset_options( $query, $input );
|
||||
|
||||
# Now sort into distinct buckets
|
||||
my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query );
|
||||
my $tbl = $self->{table} or $self->error( 'BADARGS', 'FATAL', 'Must have table object defined' );
|
||||
my $string = $self->_string ($buckets);
|
||||
|
||||
return $self->sth({}) unless ($string =~ /\w/);
|
||||
|
||||
my $table_name = $tbl->name();
|
||||
my ($pk) = $tbl->pk;
|
||||
|
||||
# create the filter
|
||||
my $filter_sql = $self->{filter} ? "WHERE ( " . $self->{filter}->sql . ' )' : '';
|
||||
|
||||
# If we have a callback, we need all results.
|
||||
if ($self->{callback}) {
|
||||
$query = qq!
|
||||
SELECT $pk, K.RANK
|
||||
FROM $table_name AS T INNER JOIN
|
||||
CONTAINSTABLE ( $table_name, *,
|
||||
'$string'
|
||||
) AS K
|
||||
ON T.$pk = K.[KEY]
|
||||
$filter_sql
|
||||
!;
|
||||
my %results = $tbl->do_query($query)->fetchall_list;
|
||||
my $results = $self->{callback}->($self, \%results);
|
||||
$self->{rows} = $results ? scalar keys %$results : 0;
|
||||
return $self->sth($results);
|
||||
}
|
||||
else {
|
||||
my $mh = (defined $input->{nh} and $input->{nh} =~ /^(\d+)$/) ? $1 : 1;
|
||||
my $nh = (defined $input->{mh} and $input->{mh} =~ /^(\d+)$/) ? $1 : 25;
|
||||
# First get the total.
|
||||
$query = qq!
|
||||
SELECT COUNT(*)
|
||||
FROM $table_name AS T INNER JOIN
|
||||
CONTAINSTABLE ( $table_name, *,
|
||||
'$string'
|
||||
) AS K
|
||||
ON T.$pk = K.[KEY]
|
||||
$filter_sql
|
||||
!;
|
||||
my ($count) = $tbl->do_query($query)->fetchrow;
|
||||
|
||||
# Now get results.
|
||||
$query = qq!
|
||||
SELECT $pk, K.RANK
|
||||
FROM $table_name AS T INNER JOIN
|
||||
CONTAINSTABLE ( $table_name, *,
|
||||
'$string'
|
||||
) AS K
|
||||
ON T.$pk = K.[KEY]
|
||||
$filter_sql
|
||||
ORDER BY K.RANK DESC
|
||||
!;
|
||||
my %results = $tbl->do_query($query)->fetchall_list;
|
||||
$self->{rows} = $count;
|
||||
return $self->sth(\%results);
|
||||
}
|
||||
}
|
||||
|
||||
sub _string {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the string to use for containstable.
|
||||
#
|
||||
my ($self, $buckets) = @_;
|
||||
|
||||
# union
|
||||
my $tmp_bucket = $buckets->{keywords};
|
||||
my $union_request_str = join(
|
||||
" or ",
|
||||
map(
|
||||
qq!"$_"!,
|
||||
keys %{$buckets->{phrases}}
|
||||
),
|
||||
map(
|
||||
($tmp_bucket->{$_}->{substring} ? "$_*" : $_),
|
||||
keys %$tmp_bucket
|
||||
)
|
||||
);
|
||||
|
||||
# intersect
|
||||
$tmp_bucket = $buckets->{keywords_must};
|
||||
my $intersect_request_str = join(
|
||||
" and ",
|
||||
map(
|
||||
qq!"$_"!,
|
||||
keys %{$buckets->{phrases_must}}
|
||||
),
|
||||
map(
|
||||
($tmp_bucket->{$_}->{substring} ? "$_*" : $_),
|
||||
keys %$tmp_bucket
|
||||
)
|
||||
);
|
||||
|
||||
# disjoin
|
||||
$tmp_bucket = $buckets->{keywords_cannot};
|
||||
my $disjoin_request_str = join(
|
||||
" and ",
|
||||
map(
|
||||
qq!"$_"!,
|
||||
keys %{$buckets->{phrases_cannot}}
|
||||
),
|
||||
map(
|
||||
($tmp_bucket->{$_}->{substring} ? "$_*" : $_),
|
||||
keys %$tmp_bucket
|
||||
)
|
||||
);
|
||||
|
||||
# now build the query
|
||||
my $tmp_request_str = join(
|
||||
" and ",
|
||||
($union_request_str ? "( $union_request_str )" : ()),
|
||||
($intersect_request_str ? "( $intersect_request_str )" : ()),
|
||||
($disjoin_request_str ? "NOT ( $disjoin_request_str )" : ())
|
||||
);
|
||||
return $tmp_request_str;
|
||||
}
|
||||
|
||||
1;
|
||||
187
site/glist/lib/GT/SQL/Search/MYSQL/Indexer.pm
Normal file
187
site/glist/lib/GT/SQL/Search/MYSQL/Indexer.pm
Normal file
@@ -0,0 +1,187 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MYSQL::Indexer
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Indexer.pm,v 1.17 2004/08/28 03:53:49 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Class used to search indexed tables.
|
||||
#
|
||||
|
||||
package GT::SQL::Search::MYSQL::Indexer;
|
||||
# ------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/@ISA $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/;
|
||||
use GT::SQL::Search::Base::Indexer;
|
||||
@ISA = qw/GT::SQL::Search::Base::Indexer/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
$ERRORS = {
|
||||
NOTFROMWEB => 'There are far too many records in table %s for create/destroy of this indexing scheme from the web. Please use alternative method.',
|
||||
MYSQLNONSUPPORT => 'Driver MYSQL requires MySQL version 3.23.23 or greater. Currently MySQL version: %s'
|
||||
};
|
||||
|
||||
@$GT::SQL::ERRORS{ keys %$ERRORS } = values %$ERRORS;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
sub load {
|
||||
my $class = shift;
|
||||
return $class->new(@_);
|
||||
}
|
||||
|
||||
sub ok {
|
||||
# ------------------------------------------------------------------------------
|
||||
my ($class, $tbl) = @_;
|
||||
unless (uc $tbl->{connect}->{driver} eq 'MYSQL') {
|
||||
return $class->error ('MYSQLNONSUPPORT', 'WARN', $tbl->{connect}->{driver});
|
||||
}
|
||||
my $sth = $tbl->do_query(qq!SELECT VERSION()!);
|
||||
my $version = $sth->fetchrow;
|
||||
my ($maj, $min) = split (/\./, $version);
|
||||
unless ($maj > 3 or ($maj == 3 and $min >= 23)) {
|
||||
return $class->error(MYSQLNONSUPPORT => WARN => $version);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub drop_search_driver {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
$self->too_much() and return;
|
||||
|
||||
my $tbl = $self->{table} or return;
|
||||
$tbl->connect();
|
||||
|
||||
my %weights = $tbl->weight() or return;
|
||||
my $tblname = $tbl->name();
|
||||
|
||||
# Group the fulltext columns by value of the weight
|
||||
my %cols_grouped;
|
||||
foreach ( keys %weights ) {
|
||||
my $val = $weights{$_} or next;
|
||||
push @{$cols_grouped{$val}}, $_;
|
||||
}
|
||||
|
||||
# Drop unified fulltext columns if required
|
||||
if ( keys %cols_grouped > 1 ) {
|
||||
$cols_grouped{-1} = [ grep { $weights{$_} } keys %weights ];
|
||||
}
|
||||
|
||||
# For each value grouped column set create a full text
|
||||
# column
|
||||
foreach my $v ( keys %cols_grouped ) {
|
||||
|
||||
my $ft_name = 'ft_'.join("_", sort @{$cols_grouped{$v}});
|
||||
|
||||
my $res = eval {
|
||||
$tbl->do_query(qq!
|
||||
ALTER TABLE $tblname
|
||||
DROP INDEX $ft_name
|
||||
!);
|
||||
};
|
||||
|
||||
# Break on errors that can't be handled
|
||||
if ( $@ ) {
|
||||
next if $@ !~ /exist/i;
|
||||
$self->warn( "$@" );
|
||||
return;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub add_search_driver {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
$self->too_much() and return;
|
||||
|
||||
my $tbl = $self->{table} or return $self->error(BADARGS => FATAL => "table must be passed into add_search_driver.");
|
||||
my %weights = $tbl->weight() or return $self->error(NOWEIGHTS => 'WARN');
|
||||
my $tblname = $tbl->name() or return $self->error(BADARGS => FATAL => "table does not have a name?");
|
||||
|
||||
# group the fulltext columns by value of the weight
|
||||
my %cols_grouped;
|
||||
foreach ( keys %weights ) {
|
||||
my $val = $weights{$_} or next;
|
||||
push @{$cols_grouped{$val}}, $_;
|
||||
}
|
||||
|
||||
# Create unified fulltext columns if required
|
||||
if ( keys %cols_grouped > 1 ) {
|
||||
$cols_grouped{-1} = [ grep { $weights{$_} } keys %weights ];
|
||||
}
|
||||
|
||||
# for each value grouped column set create a full text
|
||||
# column
|
||||
foreach my $v ( keys %cols_grouped ) {
|
||||
|
||||
my $cols = join(",", sort @{$cols_grouped{$v}});
|
||||
my $ft_name = 'ft_'.join("_", sort @{$cols_grouped{$v}});
|
||||
|
||||
my $res = eval {
|
||||
$tbl->do_query(qq!
|
||||
ALTER TABLE $tblname
|
||||
ADD FULLTEXT $ft_name ( $cols )
|
||||
!);
|
||||
};
|
||||
|
||||
# break on errors that can't be handled
|
||||
if ( $@ ) {
|
||||
next if $@ =~ /duplicate/i;
|
||||
$self->warn( "$@" );
|
||||
return;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub too_much {
|
||||
# ------------------------------------------------------------------------------
|
||||
# returns true if there are too many records to be used on the Web
|
||||
#
|
||||
if ( $ENV{REQUEST_METHOD} ) {
|
||||
my $self = shift;
|
||||
my $tbl = $self->{table};
|
||||
if ( $tbl->count() > 5000 ) {
|
||||
$self->error( 'NOTFROMWEB', 'WARN', $tbl->name() );
|
||||
return 1
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub post_create_table {
|
||||
# ------------------------------------------------------------------------------
|
||||
shift->add_search_driver(@_);
|
||||
}
|
||||
|
||||
sub reindex_all {
|
||||
# ------------------------------------------------------------------------------
|
||||
# this will drop all the fulltext columns and reindex all of them. This should
|
||||
# not be required unless the user changes the weights on one of their columns.
|
||||
# Unfortunately, this method is not particularly smart and risks not dropping
|
||||
# certain index columns and reindexes even when it's not required. It must be
|
||||
# recoded at a future date, but as this action won't happen frequently and will
|
||||
# rarely affect the user, it is not a priority.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
$self->drop_search_driver;
|
||||
$self->add_search_driver;
|
||||
}
|
||||
|
||||
1;
|
||||
51
site/glist/lib/GT/SQL/Search/MYSQL/Search.pm
Normal file
51
site/glist/lib/GT/SQL/Search/MYSQL/Search.pm
Normal file
@@ -0,0 +1,51 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MYSQL::Search
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Search.pm,v 1.14 2004/01/13 01:35:19 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Class used to search indexed tables.
|
||||
#
|
||||
|
||||
package GT::SQL::Search::MYSQL::Search;
|
||||
# ------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
|
||||
use GT::SQL::Search::Base::Search;
|
||||
@ISA = qw( GT::SQL::Search::Base::Search );
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
min_word_size => 4
|
||||
};
|
||||
|
||||
sub load {
|
||||
# --------------------------------------------------
|
||||
my $self = shift;
|
||||
my $opts = $self->common_param( @_ );
|
||||
|
||||
# determine which mysql search variant to use.
|
||||
my $tbl = $opts->{table};
|
||||
my $ver_sth = $tbl->do_query( 'SELECT VERSION()' );
|
||||
my $version = $ver_sth->fetchrow_array();
|
||||
|
||||
my ( $maj, $min ) = split /\./, $version;
|
||||
|
||||
my $pkg = 'GT::SQL::Search::MYSQL::';
|
||||
$pkg .= $maj > 3 ? 'VER4' : 'VER3';
|
||||
|
||||
eval "require $pkg";
|
||||
return $pkg->new(@_)
|
||||
}
|
||||
|
||||
1;
|
||||
178
site/glist/lib/GT/SQL/Search/MYSQL/VER3.pm
Normal file
178
site/glist/lib/GT/SQL/Search/MYSQL/VER3.pm
Normal file
@@ -0,0 +1,178 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MYSQL::VER3
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: VER3.pm,v 1.3 2004/08/28 03:53:49 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Class used to search indexed tables.
|
||||
#
|
||||
|
||||
package GT::SQL::Search::MYSQL::VER3;
|
||||
# ------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
|
||||
use GT::SQL::Search::Base::Search;
|
||||
@ISA = qw( GT::SQL::Search::Base::Search );
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
min_word_size => 4
|
||||
};
|
||||
|
||||
sub _phrase_query {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $phrases = shift or return $_[0];
|
||||
my $results = shift || {};
|
||||
|
||||
foreach my $phrase ( values %{$phrases} ) {
|
||||
$self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug});
|
||||
|
||||
my $tmp = {};
|
||||
foreach my $keyword ( @{ $phrase->{phrase}|| [] } ) {
|
||||
$tmp = $self->_get_words ( [ $keyword ], $tmp, 'intersect' );
|
||||
keys %$tmp or return {};
|
||||
}
|
||||
foreach my $key ( keys %$tmp ) { $results->{$key} += $tmp->{$key} }
|
||||
|
||||
}
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub _get_phrase {
|
||||
# ------------------------------------------------------------------------------
|
||||
# one day change this so it does words properly
|
||||
return _get_words(@_);
|
||||
}
|
||||
|
||||
sub _union_query {
|
||||
# ------------------------------------------------------------------------------
|
||||
return _get_words(@_);
|
||||
}
|
||||
|
||||
sub _intersect_query {
|
||||
# ------------------------------------------------------------------------------
|
||||
my ( $self, $keywords, $results ) = @_;
|
||||
$keywords or return $results;
|
||||
|
||||
foreach my $keyword ( keys %{ $keywords || {} } ) {
|
||||
$results = $self->_get_words ( [ $keyword ], $results, 'intersect' );
|
||||
keys %$results or return {};
|
||||
}
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub _phrase_intersect_query {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $phrases = shift or return $_[0];
|
||||
my $results = shift || {};
|
||||
|
||||
my $tmp = $self->_phrase_query ( $phrases, $results );
|
||||
keys %$results or return $tmp;
|
||||
foreach my $key ( keys %$results ) {
|
||||
if ( $tmp->{$key} ) {
|
||||
$results->{$key} += $tmp->{$key};
|
||||
}
|
||||
else {
|
||||
delete $results->{$key}
|
||||
}
|
||||
}
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub _disjoin_query {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $words = shift or return shift;
|
||||
my $results = shift || {};
|
||||
|
||||
$results = $self->_get_words([ keys %{$words || {}} ], $results, 'disjoin' );
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub _phrase_disjoin_query {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $phrases = shift or return shift;
|
||||
my $results = shift || {};
|
||||
|
||||
my $tmp = $self->_phrase_query ( $phrases, $results );
|
||||
keys %$results or return $tmp;
|
||||
foreach my $key ( keys %$results ) {
|
||||
$tmp->{$key} and delete $results->{$key};
|
||||
}
|
||||
}
|
||||
|
||||
sub _get_words {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $words = shift or return $_[0] || {};
|
||||
my $results = shift || {};
|
||||
my $mode = lc shift;
|
||||
|
||||
my $tbl = $self->{table} or $self->error( 'BADARGS', 'FATAL', 'Must have table object defined' );
|
||||
my $tname = $tbl->name();
|
||||
my $wordlist = join " ", ( ref $words ? ( ref $words eq 'HASH' ? keys %$words : @$words ) : $words ) ;
|
||||
my ($pk) = $tbl->pk;
|
||||
|
||||
my %weights = $tbl->_weight_cols();
|
||||
my $cols = join(",", keys %weights);
|
||||
my $qwrds = quotemeta( $wordlist );
|
||||
my $where = ( $results and keys %$results )
|
||||
? ("AND $pk IN(" . join(',', keys %$results) . ")")
|
||||
: '';
|
||||
my $query = qq!
|
||||
SELECT $pk, MATCH($cols) AGAINST ('$qwrds') AS SCORE
|
||||
FROM $tname
|
||||
WHERE MATCH($cols) AGAINST ('$qwrds')
|
||||
$where
|
||||
!;
|
||||
my $sth = $tbl->do_query( $query ) or return;
|
||||
|
||||
if ( $mode eq 'disjoin' ) {
|
||||
while ( my $result = $sth->fetchrow ) {
|
||||
delete $results->{$result};
|
||||
}
|
||||
}
|
||||
elsif ( $mode eq 'intersect' ) {
|
||||
my $tmp = {};
|
||||
while ( my $aref = $sth->fetchrow_arrayref ) {
|
||||
$tmp->{$aref->[0]} = $aref->[1];
|
||||
}
|
||||
if ( $results and keys %$results ) {
|
||||
while (my ($id, $score) = each %$results) {
|
||||
if (not defined $tmp->{$id}) {
|
||||
delete $results->{$id};
|
||||
next;
|
||||
}
|
||||
$results->{$id} += $score;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$results = $tmp;
|
||||
}
|
||||
}
|
||||
else {
|
||||
while ( my $aref = $sth->fetchrow_arrayref ) {
|
||||
$results->{$aref->[0]} += $aref->[1];
|
||||
}
|
||||
}
|
||||
return $results;
|
||||
}
|
||||
|
||||
1;
|
||||
355
site/glist/lib/GT/SQL/Search/MYSQL/VER4.pm
Normal file
355
site/glist/lib/GT/SQL/Search/MYSQL/VER4.pm
Normal file
@@ -0,0 +1,355 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MYSQL::VER4
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: VER4.pm,v 1.9 2004/01/13 01:35:19 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Class used to search indexed tables.
|
||||
#
|
||||
|
||||
package GT::SQL::Search::MYSQL::VER4;
|
||||
# ------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD $STOPWORDS /;
|
||||
use GT::SQL::Search::Base::Search;
|
||||
@ISA = qw( GT::SQL::Search::Base::Search );
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
|
||||
$STOPWORDS = { map { $_ => 1 } qw/
|
||||
|
||||
a's able about above according accordingly across actually after
|
||||
afterwards again against ain't all allow allows almost alone
|
||||
along already also although always am among amongst an and another
|
||||
any anybody anyhow anyone anything anyway anyways anywhere apart
|
||||
appear appreciate appropriate are aren't around as aside ask asking
|
||||
associated at available away awfully be became because become becomes
|
||||
becoming been before beforehand behind being believe below beside
|
||||
besides best better between beyond both brief but by c'mon c's came
|
||||
can can't cannot cant cause causes certain certainly changes clearly
|
||||
co com come comes concerning consequently consider considering
|
||||
contain containing contains corresponding could couldn't course currently
|
||||
definitely described despite did didn't different do does doesn't
|
||||
doing don't done down downwards during each edu eg eight either else
|
||||
elsewhere enough entirely especially et etc even ever every everybody
|
||||
everyone everything everywhere ex exactly example except far few
|
||||
fifth first five followed following follows for former formerly
|
||||
forth four from further furthermore get gets getting given gives
|
||||
go goes going gone got gotten greetings had hadn't happens hardly
|
||||
has hasn't have haven't having he he's hello help hence her here
|
||||
here's hereafter hereby herein hereupon hers herself hi him himself
|
||||
his hither hopefully how howbeit however i'd i'll i'm i've ie if ignored
|
||||
immediate in inasmuch inc indeed indicate indicated indicates inner
|
||||
insofar instead into inward is isn't it it'd it'll it's its itself
|
||||
just keep keeps kept know knows known last lately later latter latterly
|
||||
least less lest let let's like liked likely little look looking looks
|
||||
ltd mainly many may maybe me mean meanwhile merely might more
|
||||
moreover most mostly much must my myself name namely nd near nearly
|
||||
necessary need needs neither never nevertheless new next nine no
|
||||
nobody non none noone nor normally not nothing novel now nowhere
|
||||
obviously of off often oh ok okay old on once one ones only onto
|
||||
or other others otherwise ought our ours ourselves out outside over
|
||||
overall own particular particularly per perhaps placed please plus
|
||||
possible presumably probably provides que quite qv rather rd re
|
||||
really reasonably regarding regardless regards relatively respectively
|
||||
right said same saw say saying says second secondly see seeing seem
|
||||
seemed seeming seems seen self selves sensible sent serious seriously
|
||||
seven several shall she should shouldn't since six so some somebody
|
||||
somehow someone something sometime sometimes somewhat somewhere
|
||||
soon sorry specified specify specifying still sub such sup sure
|
||||
t's take taken tell tends th than thank thanks thanx that that's
|
||||
thats the their theirs them themselves then thence there there's
|
||||
thereafter thereby therefore therein theres thereupon these they
|
||||
they'd they'll they're they've think third this thorough thoroughly
|
||||
those though three through throughout thru thus to together too
|
||||
took toward towards tried tries truly try trying twice two un
|
||||
under unfortunately unless unlikely until unto up upon us use used
|
||||
useful uses using usually value various very via viz vs want wants
|
||||
was wasn't way we we'd we'll we're we've welcome well went were
|
||||
weren't what what's whatever when whence whenever where where's
|
||||
whereafter whereas whereby wherein whereupon wherever whether
|
||||
which while whither who who's whoever whole whom whose why will
|
||||
willing wish with within without won't wonder would would wouldn't
|
||||
yes yet you you'd you'll you're you've your yours yourself
|
||||
yourselves zero
|
||||
|
||||
/ };
|
||||
|
||||
$ATTRIBS = {
|
||||
min_word_size => 4,
|
||||
stopwords => $STOPWORDS,
|
||||
};
|
||||
|
||||
sub query {
|
||||
# --------------------------------------------------
|
||||
# Returns a sth based on a query
|
||||
#
|
||||
# Options:
|
||||
# - paging
|
||||
# mh : max hits
|
||||
# nh : number hit (or page of hits)
|
||||
#
|
||||
# - searching
|
||||
# ww : whole word
|
||||
# ma : 1 => OR match, 0 => AND match, undefined => QUERY
|
||||
# substring : search for substrings of words
|
||||
# bool : 'and' => and search, 'or' => or search, '' => regular query
|
||||
# query : the string of things to ask for
|
||||
#
|
||||
# - filtering
|
||||
# field_name : value # Find all rows with field_name = value
|
||||
# field_name : ">value" # Find all rows with field_name > value.
|
||||
# field_name : "<value" # Find all rows with field_name < value.
|
||||
# field_name-gt : value # Find all rows with field_name > value.
|
||||
# field_name-lt : value # Find all rows with field_name < value.
|
||||
#
|
||||
# Parameters:
|
||||
# ( $CGI ) : a single cgi object
|
||||
# ( $HASH ) : a hash of the parameters
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# create an easily accessible argument hash
|
||||
my $args = $self->common_param(@_);
|
||||
|
||||
# see if we can setup the filtering constraints
|
||||
my $filter = { %$args };
|
||||
my $query = delete $args->{query} || $self->{query} || '';
|
||||
my $ftr_cond;
|
||||
|
||||
# parse query
|
||||
$self->debug( "Search Query: $query" ) if ($self->{_debug});
|
||||
my ( $query_struct, $rejected ) = $self->_parse_query_string( $query );
|
||||
|
||||
$self->{rejected_keywords} = $rejected;
|
||||
|
||||
# setup the additional input parameters
|
||||
$query_struct = $self->_preset_options( $query_struct, $args );
|
||||
|
||||
# now sort into distinct buckets
|
||||
my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query_struct );
|
||||
$self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug});
|
||||
|
||||
# with the buckets, it's now possible to create a query string
|
||||
# that can be passed directly into the FULLTEXT search.
|
||||
my $query_string = '';
|
||||
|
||||
foreach my $search_type ( keys %$buckets ) {
|
||||
my $bucket = $buckets->{$search_type};
|
||||
foreach my $token ( keys %$bucket ) {
|
||||
next unless $token;
|
||||
my $properties = $bucket->{$token} or next;
|
||||
|
||||
my $e = ' ';
|
||||
|
||||
# handle boolean operations
|
||||
$properties->{mode} ||= '';
|
||||
if ( $properties->{mode} eq 'must' ) {
|
||||
$e .= '+';
|
||||
}
|
||||
elsif ( $properties->{mode} eq 'cannot' ) {
|
||||
$e .= '-';
|
||||
}
|
||||
|
||||
# deal with phrase vs keyword
|
||||
if ( $properties->{phrase} ) {
|
||||
$e .= '"' . quotemeta( $token ) . '"';
|
||||
}
|
||||
else {
|
||||
$e .= quotemeta $token;
|
||||
|
||||
# substring match
|
||||
$e .= '*' if $properties->{substring};
|
||||
}
|
||||
|
||||
$query_string .= $e;
|
||||
}
|
||||
}
|
||||
|
||||
# start building the GT::SQL::COndition object that will allow us to
|
||||
# to retreive the data
|
||||
|
||||
require GT::SQL::Condition;
|
||||
my $tbl = $self->{table};
|
||||
my $constraints = GT::SQL::Condition->new;
|
||||
|
||||
# create the GT::SQL::Condition object that will become the filtering
|
||||
# constraints
|
||||
my $filt = $self->{filter};
|
||||
|
||||
if ( $filt and ref $filt eq 'HASH' ) {
|
||||
foreach my $fkey ( keys %$filt ) {
|
||||
next if exists $args->{$fkey};
|
||||
$args->{$fkey} = $filt->{$fkey};
|
||||
}
|
||||
}
|
||||
|
||||
if ( my $filter_cond = $tbl->build_query_cond( $args ) ) {
|
||||
$constraints->add( $filter_cond );
|
||||
}
|
||||
|
||||
# if the cached filter object is a Condition object, append
|
||||
# it to the filter set
|
||||
if ( $filt and UNIVERSAL::isa( $filt, 'GT::SQL::Condition' ) ) {
|
||||
$constraints->add( $filt );
|
||||
}
|
||||
|
||||
# create our fulltext query condition
|
||||
my %weights = $tbl->_weight_cols();
|
||||
my $cols = join(",", keys %weights);
|
||||
if ( $query_string ) {
|
||||
$constraints->add( GT::SQL::Condition->new(
|
||||
"MATCH( $cols )",
|
||||
"AGAINST",
|
||||
\"('$query_string' IN BOOLEAN MODE)" ) );
|
||||
}
|
||||
|
||||
# calculate the cursor constraints
|
||||
foreach my $k (qw( nh mh so sb )) {
|
||||
next if defined $args->{$k};
|
||||
$args->{$k} = $self->{$k} || '';
|
||||
}
|
||||
$args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1;
|
||||
$args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^(\d+)$/) ? $1 : 25;
|
||||
$args->{sb} = (defined $args->{sb} and $args->{sb} =~ /^([\w ]+)$/ ) ? $1 : 'score';
|
||||
|
||||
# if the sorting method is "score" the order is forced to "descend" (as there
|
||||
# is almost no reason to order by worst matches)
|
||||
# if the storing key is not "score", the default order will be "ascend"
|
||||
$args->{so} =
|
||||
$args->{sb} eq 'score' ? 'desc' : # comment out this entire line to prevent "descend" order forcing
|
||||
( (defined $args->{so} and $args->{so} =~ /^(asc(?:end)?|desc(?:end)?)$/i) ? $1 : 'asc' );
|
||||
|
||||
# check that sb is not dangerous
|
||||
my $sb = $self->clean_sb($args->{sb}, $args->{so});
|
||||
|
||||
$self->debug_dumper( "About to query. Constraint object: ", $constraints) if ($self->{_debug});
|
||||
|
||||
# Setup a limit only if there is no callback. The callback argument requires a full results list
|
||||
unless ( $self->{callback} ) {
|
||||
my $offset = ( $args->{nh} - 1 ) * $args->{mh};
|
||||
$tbl->select_options($sb) if ($sb);
|
||||
$tbl->select_options("LIMIT $offset, $args->{mh}");
|
||||
}
|
||||
|
||||
my $sth;
|
||||
|
||||
# if the weights are all the same value, the query can be optimized
|
||||
# to use just one MATCH AGAINST argument. However, if the weights
|
||||
# are different, each element must be sectioned and queried separately
|
||||
# with the weight value multipler
|
||||
|
||||
# check to see if all the weight values are the same.
|
||||
my $base_weight;
|
||||
my $weights_same = 1;
|
||||
foreach ( values %weights ) {
|
||||
$base_weight ||= $_ or next; # init and skip 0s
|
||||
next if $base_weight == $_;
|
||||
$weights_same = 0;
|
||||
last;
|
||||
}
|
||||
|
||||
# multiplex the action
|
||||
my $result_cols = $self->{callback} ? ($tbl->pk)[0] : '*';
|
||||
|
||||
unless ( $query_string ) {
|
||||
$sth = $tbl->select( [ $result_cols ], $constraints ) or return;
|
||||
}
|
||||
elsif ( $weights_same ) {
|
||||
$sth = $tbl->select( [ $result_cols, "MATCH($cols) AGAINST ('$query_string' IN BOOLEAN MODE) AS score" ], $constraints )
|
||||
or return;
|
||||
}
|
||||
else {
|
||||
|
||||
# group the multiplier counts
|
||||
my %column_multiplier;
|
||||
foreach ( keys %weights ) {
|
||||
push @{$column_multiplier{$weights{$_}}}, $_;
|
||||
}
|
||||
|
||||
my @search_parameters;
|
||||
foreach my $val ( keys %column_multiplier ) {
|
||||
next unless $val;
|
||||
|
||||
my $cols_ar = $column_multiplier{ $val } or next;
|
||||
my $search_cols = join ",", @$cols_ar;
|
||||
|
||||
if ( $val > 1 ) {
|
||||
push @search_parameters, "( ( MATCH($search_cols) AGAINST ('$query_string' IN BOOLEAN MODE) ) * $val )";
|
||||
}
|
||||
else {
|
||||
push @search_parameters, "( MATCH($search_cols) AGAINST ('$query_string' IN BOOLEAN MODE) )";
|
||||
}
|
||||
}
|
||||
|
||||
my $search_sql = "( " . join( " + ", @search_parameters ) . " ) AS score";
|
||||
|
||||
$sth = $tbl->select( [ $result_cols, $search_sql ], $constraints )
|
||||
or return;
|
||||
}
|
||||
|
||||
# If we have a callback, we fetch the primary key => score and pass that hash into
|
||||
# the filter.
|
||||
if ($self->{callback}) {
|
||||
unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') {
|
||||
return $self->error('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!");
|
||||
}
|
||||
my %results = map { $_->[0] => $_->[1] } @{$sth->fetchall_arrayref};
|
||||
|
||||
$self->debug_dumper("Running results through callback. Had: " . scalar (keys %results) . " results.", \%results) if ($self->{_debug});
|
||||
my $filtered = $self->{callback}->($self, \%results) || {};
|
||||
$self->debug_dumper("New result set: " . scalar (keys %$filtered) . " results.", $filtered) if ($self->{_debug});
|
||||
|
||||
$self->{rows} = scalar keys %$filtered;
|
||||
return $self->sth($filtered);
|
||||
}
|
||||
|
||||
# count the number of hits. create a query for this purpose only if we are required to.
|
||||
$self->{rows} = $sth->rows();
|
||||
if (($args->{nh} > 1) or ($self->{rows} == $args->{mh})) {
|
||||
$self->{rows} = $tbl->count($constraints);
|
||||
}
|
||||
return $sth;
|
||||
}
|
||||
|
||||
sub clean_sb {
|
||||
# -------------------------------------------------------------------------------
|
||||
# Convert the sort by, sort order into an sql string.
|
||||
#
|
||||
my ($class, $sb, $so) = @_;
|
||||
my $output = '';
|
||||
|
||||
return $output unless ($sb);
|
||||
|
||||
if ($sb and not ref $sb) {
|
||||
if ($sb =~ /^[\w\s,]+$/) {
|
||||
if ($sb =~ /\s(?:asc|desc)/i) {
|
||||
$output = 'ORDER BY ' . $sb;
|
||||
}
|
||||
else {
|
||||
$output = 'ORDER BY ' . $sb . ' ' . $so;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$class->error('BADSB', 'WARN', $sb);
|
||||
}
|
||||
}
|
||||
elsif (ref $sb eq 'ARRAY') {
|
||||
foreach ( @$sb ) {
|
||||
/^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next;
|
||||
}
|
||||
$output = 'ORDER BY ' . join(',', @$sb);
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
1;
|
||||
25
site/glist/lib/GT/SQL/Search/NONINDEXED/Indexer.pm
Normal file
25
site/glist/lib/GT/SQL/Search/NONINDEXED/Indexer.pm
Normal file
@@ -0,0 +1,25 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::NONINDEXED::Indexer
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Indexer.pm,v 1.3 2004/01/13 01:35:20 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::SQL::Search::NONINDEXED::Indexer;
|
||||
#--------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/@ISA $DEBUG/;
|
||||
use GT::SQL::Search::Base::Indexer;
|
||||
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
|
||||
|
||||
sub load {
|
||||
shift;
|
||||
return GT::SQL::Search::NONINDEXED::Indexer->new(@_)
|
||||
}
|
||||
|
||||
1;
|
||||
255
site/glist/lib/GT/SQL/Search/NONINDEXED/Search.pm
Normal file
255
site/glist/lib/GT/SQL/Search/NONINDEXED/Search.pm
Normal file
@@ -0,0 +1,255 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::NONINDEXED::Search
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Search.pm,v 1.28 2004/08/28 03:53:50 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Nonindex search system
|
||||
#
|
||||
|
||||
package GT::SQL::Search::NONINDEXED::Search;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG/;
|
||||
use GT::SQL::Search::Base::Search;
|
||||
use GT::SQL::Condition;
|
||||
@ISA = qw( GT::SQL::Search::Base::Search );
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
# parse based on latin characters
|
||||
latin_query_parse => 0
|
||||
};
|
||||
|
||||
sub load {
|
||||
shift;
|
||||
return GT::SQL::Search::NONINDEXED::Search->new(@_)
|
||||
}
|
||||
|
||||
sub query {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Returns a sth based on a query
|
||||
#
|
||||
# Options:
|
||||
# - paging
|
||||
# mh : max hits
|
||||
# nh : number hit (or page of hits)
|
||||
#
|
||||
# - searching
|
||||
# ww : whole word
|
||||
# ma : 1 => OR match, 0 => AND match, undefined => QUERY
|
||||
# substring : search for substrings of words
|
||||
# bool : 'and' => and search, 'or' => or search, '' => regular query
|
||||
# query : the string of things to ask for
|
||||
#
|
||||
# - filtering
|
||||
# field_name : value # Find all rows with field_name = value
|
||||
# field_name : ">value" # Find all rows with field_name > value.
|
||||
# field_name : "<value" # Find all rows with field_name < value.
|
||||
# field_name-gt : value # Find all rows with field_name > value.
|
||||
# field_name-lt : value # Find all rows with field_name < value.
|
||||
#
|
||||
# Parameters:
|
||||
# ( $CGI ) : a single cgi object
|
||||
# ( $HASH ) : a hash of the parameters
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# find out what sort of a parameter we're dealing with
|
||||
my $input = $self->common_param(@_);
|
||||
|
||||
# add additional parameters if required
|
||||
foreach my $parameter ( keys %{$ATTRIBS} ) {
|
||||
if ( not exists $input->{$parameter} ) {
|
||||
$input->{$parameter} = $self->{$parameter};
|
||||
}
|
||||
}
|
||||
|
||||
# parse query
|
||||
$self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug});
|
||||
my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} );
|
||||
|
||||
$self->{rejected_keywords} = $rejected;
|
||||
|
||||
# setup the additional input parameters
|
||||
$query = $self->_preset_options( $query, $input );
|
||||
|
||||
$self->debug( "Set the pre-options: ", $query ) if ($self->{_debug});
|
||||
|
||||
# now sort into distinct buckets
|
||||
my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query );
|
||||
$self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug});
|
||||
|
||||
|
||||
require GT::SQL::Condition;
|
||||
my $query_condition = new GT::SQL::Condition;
|
||||
|
||||
# now handle the separate possibilities
|
||||
# the union
|
||||
my $union_cond = $self->_get_condition( $buckets->{keywords}, $buckets->{phrases} );
|
||||
$query_condition->add(GT::SQL::Condition->new(@$union_cond, 'OR')) if $union_cond;
|
||||
# the intersect
|
||||
my $intersect_cond = $self->_get_condition( $buckets->{keywords_must}, $buckets->{phrases_must} );
|
||||
$query_condition->add(GT::SQL::Condition->new(@$intersect_cond)) if $intersect_cond;
|
||||
|
||||
# the disjoin
|
||||
my $disjoin_cond = $self->_get_condition( $buckets->{keywords_cannot}, $buckets->{phrases_cannot} );
|
||||
$query_condition->add(GT::SQL::Condition->new(@$disjoin_cond, 'OR')->not) if $disjoin_cond;
|
||||
|
||||
# now handle filters
|
||||
my $cols = $self->{'table'}->cols();
|
||||
my %filters = map {
|
||||
(my $column = $_) =~ s/-[lg]t$//;
|
||||
exists $cols->{$column}
|
||||
? ($_ => $input->{$_})
|
||||
: ()
|
||||
} keys %{$input};
|
||||
|
||||
# if there was no query nor filter return nothing.
|
||||
keys %$query or keys %filters or return $self->sth({});
|
||||
|
||||
if (keys %filters) {
|
||||
$self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug});
|
||||
$self->_add_filters( \%filters );
|
||||
$query_condition = GT::SQL::Condition->new( keys %$query ? $query_condition : (), $self->{filter} );
|
||||
}
|
||||
elsif ($self->{filter} and keys %{$self->{filter}} ) {
|
||||
$self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug});
|
||||
$query_condition = GT::SQL::Condition->new( keys %$query ? $query_condition : (), $self->{filter} );
|
||||
}
|
||||
else {
|
||||
$self->debug( "No filters being used.") if ($self->{_debug});
|
||||
}
|
||||
|
||||
# now this query should probably clear the filters once it's been used, so i'll do that here
|
||||
$self->{filter} = undef;
|
||||
|
||||
my $tbl = $self->{table};
|
||||
my ($pk) = $tbl->pk;
|
||||
|
||||
# now run through a callback function if needed.
|
||||
if ($self->{callback}) {
|
||||
|
||||
# Warning: this slows things a heck of a lot.
|
||||
unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') {
|
||||
return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!");
|
||||
}
|
||||
|
||||
my $sth = $tbl->select( [ $pk ], $query_condition );
|
||||
my $results = {};
|
||||
while (my $result = $sth->fetchrow) {
|
||||
$results->{$result} = undef;
|
||||
}
|
||||
$self->debug_dumper("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug});
|
||||
$results = $self->{callback}->($self, $results);
|
||||
$self->debug_dumper("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug});
|
||||
$self->{rows} = scalar($results ? keys %{$results} : ());
|
||||
|
||||
return $self->sth( $results );
|
||||
}
|
||||
|
||||
# and now create a search sth object to handle all this
|
||||
$input->{nh} = (defined $input->{nh} and $input->{nh} =~ /^(\d+)$/) ? $1 : 1;
|
||||
$input->{mh} = (defined $input->{mh} and $input->{mh} =~ /^(\d+)$/) ? $1 : 25;
|
||||
$input->{so} = (defined $input->{so} and $input->{so} =~ /^(asc(?:end)?|desc(?:end)?)$/i) ? $1 : '';
|
||||
|
||||
# check that sb is not dangerous
|
||||
my $sb = $self->clean_sb($input->{sb}, $input->{so});
|
||||
|
||||
my $offset = ( $input->{nh} - 1 ) * $input->{mh};
|
||||
$tbl->select_options($sb) if ($sb);
|
||||
$tbl->select_options("LIMIT $offset, $input->{mh}");
|
||||
my $sth = $tbl->select( $query_condition ) or return;
|
||||
|
||||
# so how many hits did we get?
|
||||
$self->{rows} = $sth->rows();
|
||||
if (($input->{nh} > 1) or ($self->{rows} == $input->{mh})) {
|
||||
$self->{rows} = $tbl->count($query_condition);
|
||||
}
|
||||
return $sth;
|
||||
}
|
||||
|
||||
sub _get_condition {
|
||||
#-------------------------------------------------------------------------------
|
||||
my ( $self, $keywords, $phrases ) = @_;
|
||||
|
||||
my @list = ( keys %$keywords, keys %$phrases );
|
||||
|
||||
my $tbl = $self->{table} or return $self->error( 'NODRIVER', 'FATAL' );
|
||||
my @cond = ();
|
||||
my %tmp = $tbl->weight();
|
||||
my @weights = keys %tmp or return;
|
||||
foreach my $element ( @list ) {
|
||||
my @where = ();
|
||||
foreach my $cols ( @weights ) {
|
||||
push @where, [$cols, 'LIKE', "%$element%"]; # Condition does quoting by default.
|
||||
}
|
||||
push @cond, GT::SQL::Condition->new(@where, 'OR');
|
||||
}
|
||||
@cond or return;
|
||||
|
||||
return \@cond;
|
||||
}
|
||||
|
||||
sub _parse_query_string {
|
||||
#------------------------------------------------------------
|
||||
# Parses a query string '+foo -"bar this" alpha' into a hash of
|
||||
# words and modes.
|
||||
#
|
||||
my ($self, $text) = @_;
|
||||
my %modes = (
|
||||
'+' => 'must',
|
||||
'-' => 'cannot',
|
||||
'<' => 'greater',
|
||||
'>' => 'less'
|
||||
);
|
||||
|
||||
# Latin will break up on actual words and punctuation.
|
||||
if ($self->{latin_query_parse}) {
|
||||
return $self->SUPER::_parse_query_string( $text );
|
||||
}
|
||||
else {
|
||||
my $words = {};
|
||||
my @terms;
|
||||
my $i = 0;
|
||||
foreach my $term (split /"/, $text) {
|
||||
push @terms, ($i++ % 2 ? $term : split ' ', $term);
|
||||
}
|
||||
for (my $i = 0; $i < @terms; $i++) {
|
||||
my $word = $terms[$i];
|
||||
$word =~ s/^\s*|\s*$//g;
|
||||
next if ($word eq '');
|
||||
($word eq '-') and ($word = '-' . $terms[++$i]);
|
||||
($word eq '+') and ($word = '+' . $terms[++$i]);
|
||||
$word =~ s/^([<>+-])//;
|
||||
my $mode = ($1 and $modes{$1} or 'can');
|
||||
my $substring = ($word =~ s/\*$//) || 0;
|
||||
if ($word =~ /\s/) {
|
||||
$words->{$word} = {
|
||||
mode => $mode,
|
||||
phrase => 1,
|
||||
substring => $substring,
|
||||
keyword => 0,
|
||||
};
|
||||
}
|
||||
else {
|
||||
$words->{$word} = {
|
||||
mode => $mode,
|
||||
phrase => 0,
|
||||
substring => $substring,
|
||||
keyword => 1,
|
||||
};
|
||||
}
|
||||
}
|
||||
return $words;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
2955
site/glist/lib/GT/SQL/Table.pm
Normal file
2955
site/glist/lib/GT/SQL/Table.pm
Normal file
File diff suppressed because it is too large
Load Diff
1268
site/glist/lib/GT/SQL/Tree.pm
Normal file
1268
site/glist/lib/GT/SQL/Tree.pm
Normal file
File diff suppressed because it is too large
Load Diff
237
site/glist/lib/GT/SQL/Tree/Rebuild.pm
Normal file
237
site/glist/lib/GT/SQL/Tree/Rebuild.pm
Normal file
@@ -0,0 +1,237 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Table
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# This goes hand in hand with GT::SQL::Tree and is very useful in
|
||||
# turning an existing table without the root, and/or depth columns
|
||||
# into a GT::SQL::Tree-compatible format.
|
||||
#
|
||||
package GT::SQL::Tree::Rebuild;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/$DEBUG $VERSION $ERROR_MESSAGE @ISA $AUTOLOAD/;
|
||||
|
||||
use constants TREE_COLS_ROOT => 0,
|
||||
TREE_COLS_FATHER => 1,
|
||||
TREE_COLS_DEPTH => 2;
|
||||
|
||||
@ISA = qw/GT::SQL::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
# New returns a GT::SQL::Tree::Rebuild object when you can pass to GT::SQL::Tree.
|
||||
# When you are adding a tree to an existing table, but the table does not have
|
||||
# the root and/or depth columns, you get a Rebuild object, then pass it to
|
||||
# ->add_tree so that your tree can be built anyway.
|
||||
# You need to call new with the following options:
|
||||
# table => $Table_object
|
||||
# missing_root => sub { ... }, # Only if you are missing the root. The code reference should return the pk of the root.
|
||||
# missing_depth => 1, # Only if you are missing the depth. The code reference should return the depth of the node.
|
||||
# missing_father => 1, # Only if you are missing the father. The code reference should return the pk of the father.
|
||||
# cols => [...], # The columns you want %row (discussed below) to contain
|
||||
#
|
||||
# The code references are passed two arguments:
|
||||
# \%row, # A row from the table. If using the cols option, it will only have those columns.
|
||||
# $table_object, # This is the same object you pass to new()
|
||||
# \%all # This is a hash reference of all rows; each key is a primary key, each value the row. This may or may not be of use to you.
|
||||
#
|
||||
# For depth, %all will have root and father ids set, for roots father ID's will be set.
|
||||
#
|
||||
# NOTE: The father, root, and depth columns must exist beforehand.
|
||||
sub new {
|
||||
my $this = shift;
|
||||
my $opts = $this->common_param(@_) or return $this->error(BADARGS => FATAL => '$obj->new(HASH or HASH REF)');
|
||||
|
||||
my $self = bless {}, $this;
|
||||
|
||||
$self->{table} = $opts->{table} or return $self->error(BADARGS => FATAL => '$obj->new({ ... table => $table_obj ... })');
|
||||
for (qw(missing_root missing_depth missing_father)) {
|
||||
next unless exists $opts->{$_};
|
||||
$self->{$_} = $opts->{$_};
|
||||
ref $self->{$_} eq 'CODE' or return $self->error(BADARGS => FATAL => '$obj->new({ ... ' . $_ . ' => sub { ... } ... })');
|
||||
}
|
||||
$self->{cols} = $opts->{cols} if $opts->{cols};
|
||||
$self->{cols} = [$self->{cols}] if $self->{cols} and not ref $self->{cols};
|
||||
$self->{cols} ||= [];
|
||||
$self->{order_by} = $opts->{order_by} if $opts->{order_by};
|
||||
|
||||
$self->{missing_root} or $self->{missing_depth} or $self->{missing_father} or return $self->error(BADARGS => FATAL => 'At least one of "missing_root", "missing_depth", or "missing_father" must be passed to $obj->new({ ... })');
|
||||
|
||||
$self->{_debug} = $opts->{debug} || $DEBUG || 0;
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
# Called internally by the GT::SQL::Tree object. This does all the calculations.
|
||||
# Note that this only rebuilds the table itself, GT::SQL::Tree->create will still
|
||||
# have to create its tree table.
|
||||
sub _rebuild {
|
||||
my ($self, $pk, $root_col, $father_col, $depth_col) = @_;
|
||||
my $table = $self->{table};
|
||||
|
||||
my $count = $table->count();
|
||||
for (my $i = 0; $i < $count; $i += 10000) {
|
||||
$table->select_options("ORDER BY $self->{order_by}") if exists $self->{order_by};
|
||||
$table->select_options("LIMIT 10000" . ($i ? " OFFSET $i" : ""));
|
||||
my $sth = $table->select(@{$self->{cols}});
|
||||
while (my $row = $sth->fetchrow_hashref) {
|
||||
my %update;
|
||||
if ($self->{missing_father}) {
|
||||
my $father_id = $self->{missing_father}->($row, $table);
|
||||
$update{$father_col} = $father_id unless $row->{$father_col} == $father_id;
|
||||
$row->{$father_col} = $father_id;
|
||||
}
|
||||
if ($self->{missing_root}) {
|
||||
my $root_id = $self->{missing_root}->($row, $table);
|
||||
$update{$root_col} = $root_id unless $row->{$root_col} == $root_id;
|
||||
$row->{$root_col} = $root_id;
|
||||
}
|
||||
if ($self->{missing_depth}) {
|
||||
my $depth = $self->{missing_depth}->($row, $table);
|
||||
$update{$depth_col} = $depth unless $row->{$depth_col} == $depth;
|
||||
$row->{$depth_col} = $depth;
|
||||
}
|
||||
|
||||
$table->update(\%update, { $pk => $row->{$pk} }) if keys %update; # If the new value(s) is/are 0, like the default value(s), %update will be empty
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::SQL::Tree::Rebuild - Helps to turn a table into one usable by GT::SQL::Tree.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::SQL::Tree;
|
||||
use GT::SQL::Tree::Rebuild;
|
||||
|
||||
my $rebuild = GT::SQL::Tree::Rebuild->new(
|
||||
table => $DB->table('MyTable'),
|
||||
missing_root => \&root_code,
|
||||
missing_father => \&father_code,
|
||||
missing_depth => \&depth_code,
|
||||
order_by => 'column_name'
|
||||
);
|
||||
|
||||
$DB->editor('MyTable')->add_tree(root => $root_col, father => $father_col, depth => $depth_col, rebuild => $rebuild);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::SQL::Tree::Rebuild is designed to go hand-in-hand with GT::SQL::Tree and
|
||||
aids in turning an existing table into one with the neccessary root, father and
|
||||
depth columns needed by GT::SQL::Tree.
|
||||
|
||||
The main purpose is to do a one-shot conversion of a table to make it compatible
|
||||
with GT::SQL::Tree.
|
||||
|
||||
=head2 new - Create a Rebuild object
|
||||
|
||||
There is only one method that is called - new. You pass the arguments needed
|
||||
and get back a GT::SQL::Tree::Rebuild object. This object should then be passed
|
||||
into GT::SQL::Tree->create (typically via C<$editor-E<gt>add_tree()>)
|
||||
|
||||
new() takes a hash with up to 4 argument pairs: "table" (required), and one or
|
||||
more of "missing_root", "missing_father", or "missing_depth". The values are
|
||||
explained below.
|
||||
|
||||
=over 4
|
||||
|
||||
=item table
|
||||
|
||||
Required. You specify the table object for the table to rebuild. For example, if
|
||||
you are going to add a tree to the "Category" table, you provide the "Category"
|
||||
table object here.
|
||||
|
||||
=item cols
|
||||
|
||||
By default, an entire row will be returned. To speed up the process and lower
|
||||
the memory usage, you can use the C<cols> option, which specifies the columns to
|
||||
select for $row. It is recommended that you only select columns that you need as
|
||||
doing so will definately save time and memory.
|
||||
|
||||
=item missing_father, missing_root, missing_depth
|
||||
|
||||
Each of these arguments takes a code reference as its value. The arguments to
|
||||
the code references are as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $row
|
||||
|
||||
The first argument is a hash reference of the row being examined. Your job, in
|
||||
the code reference, is to examine $row and determine the missing value,
|
||||
depending on which code reference is being called. missing_root needs to return
|
||||
the root_id for this row; missing_father needs to return the father_id, and the
|
||||
missing_depth code reference should return the depth for the row.
|
||||
|
||||
=item $table
|
||||
|
||||
The second argument passed to the code references is the same table object that
|
||||
you pass into new(), which you can select from if neccessary.
|
||||
|
||||
=back
|
||||
|
||||
=item missing_father
|
||||
|
||||
The C<missing_father> code reference is called first - before C<missing_root>
|
||||
and C<missing_depth>. The code reference is called as described above and should
|
||||
return the ID of the father of the row passed in. A false return (0 or undef) is
|
||||
interpreted as meaning that this is a root and therefore has no father.
|
||||
|
||||
=item missing_root
|
||||
|
||||
C<missing_root> has to return the root of the row passed in. This is called
|
||||
after C<missing_father>, so the $row will contain whatever you returned in
|
||||
C<missing_father> in the father ID column. Of course, this only applies if using
|
||||
both C<missing_root> and C<missing_father>.
|
||||
|
||||
=item missing_depth
|
||||
|
||||
C<missing_depth> has to return the depth of the row passed in. This is called
|
||||
last, so if you are also using C<missing_father> and/or C<missing_root>, you
|
||||
will have whatever was returned by those code refs available in the $row.
|
||||
|
||||
=item order_by
|
||||
|
||||
The query done to retrieve records can be sorted using the C<order_by> option.
|
||||
It should be anything valid for "ORDER BY _____". Often it can be useful to have
|
||||
your results returned in a certain order - for example:
|
||||
order_by => 'depth_column ASC'
|
||||
would insure that parents come before roots. Of course, this example wouldn't
|
||||
work if you are using "missing_depth" since none of the depth values will be
|
||||
set.
|
||||
|
||||
=back
|
||||
|
||||
Once you have a GT::SQL::Tree::Rebuild object, you should pass it into
|
||||
C<GT::SQL::Tree-E<gt>create> (which typically involves passing it into
|
||||
C<$editor-E<gt>add_tree()>, which passed it through). Before calculating the
|
||||
tree, GT::SQL::Tree will call on the rebuild object to reproduce the father,
|
||||
root, and/or depth columns (whichever you specified).
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $
|
||||
|
||||
=cut
|
||||
385
site/glist/lib/GT/SQL/Types.pm
Normal file
385
site/glist/lib/GT/SQL/Types.pm
Normal file
@@ -0,0 +1,385 @@
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::SQL::Driver::Types - Column types supported by GT::SQL
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $c = $DB->creator('new_table');
|
||||
$c->cols({
|
||||
column_name => { type => 'INT', default => 42, not_null => 1, unsigned => 1 }
|
||||
# ... more columns ...
|
||||
});
|
||||
|
||||
my $e = $DB->editor('table_name');
|
||||
$e->add_col(column_name2 => { type => 'CHAR', size => 10, default => 'abc' });
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module should not be used directly, however the documentation here
|
||||
describes the different types support by GT::SQL and any caveats associated
|
||||
with those types.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
All types are specified as a C<column_name =E<gt> { column definition }> pair,
|
||||
where the column definition should contain at least a C<type> key containing
|
||||
one of the L</"TYPES"> outlined below. Commonly accepted attributes are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item not_null
|
||||
|
||||
Used to specify that a column should not be allowed to contain NULL values.
|
||||
Note that for character/string data types, a 0-character string (and, for
|
||||
C<CHAR>/C<VARCHAR> columns, strings containing only spaces), B<are> considered
|
||||
NULL values are are not permitted if the column is specified as C<not_null>.
|
||||
The value passed to not_null should be true.
|
||||
|
||||
=item default
|
||||
|
||||
Used to specify a default value to be used for the column when no explicit
|
||||
value is provided when a row is inserted. The default value is also used for
|
||||
the value in existing rows when adding a not_null column to an existing table -
|
||||
in such a case, the C<default> is B<required>.
|
||||
|
||||
Also see the L<C<TEXT>|/TEXT> section regarding caveats and limitations of
|
||||
using C<default>'s for C<TEXT> types.
|
||||
|
||||
=back
|
||||
|
||||
Other column attributes are supported as outlined below. In addition to
|
||||
attributes mentioned in this document, various attributes are available that
|
||||
influence automatically-generated forms displayed by GT::SQL::Admin - see
|
||||
L<GT::SQL::Creator> for details on these attributes.
|
||||
|
||||
=head1 TYPES
|
||||
|
||||
=head2 Integer types
|
||||
|
||||
=over 4
|
||||
|
||||
=item TINYINT
|
||||
|
||||
The C<TINYINT> type specifies an 8-bit integer able to handle values from -128
|
||||
to 127. Some databases will allow larger values due to not supporting an
|
||||
appropriate data type. The C<unsigned> column attribute I<may> turn this into
|
||||
an unsigned value supporting values from 0 to 255; due to this type being
|
||||
implemented as a larger integer type in some databases (which, incidentally,
|
||||
coincide with the databases not supporting an unsigned 8-bit C<TINYINT>) using
|
||||
an C<unsigned> TINYINT type will result in a column able to store any value
|
||||
from 0-255, unlike most of the larger integer types below.
|
||||
|
||||
=item SMALLINT
|
||||
|
||||
The C<SMALLINT> type specifies a 16-bit integer able to handle values from
|
||||
-32768 to 32767. The C<unsigned> column attribute I<may> turn this into an
|
||||
unsigned value supporting values from 0 to 65535, however this is B<not>
|
||||
guaranteed. If you need to store values in the 32768-65535 range, a larger
|
||||
type is recommended.
|
||||
|
||||
=item MEDIUMINT
|
||||
|
||||
The C<MEDIUMINT> type (only natively supported by MySQL) specifies a 24-bit
|
||||
integer type able to hold values from -8388608 to 8388607. If the C<unsigned>
|
||||
column attribute is specified, this allows values from 0 to 16777215. Due to
|
||||
this being supported with the C<unsigned> attribute, or implemented as a larger
|
||||
data type, an C<unsigned> C<MEDIUMINT> will always supported values up to
|
||||
16777215.
|
||||
|
||||
=item INT, INTEGER
|
||||
|
||||
The C<INT> type specifies a 32-bit integer able to hold values from -2147483648
|
||||
to 2147483647. If the C<unsigned> column attribute is specified, the column
|
||||
I<may> support values from 0 to 4294967295, however this is B<not> guaranteed.
|
||||
If values larger than 2147483647 are needed, using the C<BIGINT> type below is
|
||||
recommended. C<INTEGER> is an alias for C<INT>.
|
||||
|
||||
=item BIGINT
|
||||
|
||||
The largest integral type, C<BIGINT> specifies a 64-bit integer value able to
|
||||
hold values from -9223372036854775808 to 9223372036854775807. If specified as
|
||||
C<unsigned>, the column I<may> support values from 0 to 18446744073709551616,
|
||||
but this is B<not> guaranteed. If larger values are needed, use the C<DECIMAL>
|
||||
type with a C<scale> value of C<0>.
|
||||
|
||||
=item back
|
||||
|
||||
=head2 Float-point types
|
||||
|
||||
=over 4
|
||||
|
||||
=item REAL, FLOAT
|
||||
|
||||
The C<REAL> type specifies a 32-bit floating-point (i.e. fractional) number,
|
||||
accurate to 23 binary digits (which works out to I<approximately> 6 decimal
|
||||
digits). The values may be signed, and can range from at least as small as
|
||||
10^-37 to at least as large as 10^37. For more precise values, the C<DOUBLE>
|
||||
type is recommended. For exact precision (i.e. for monetary values), the
|
||||
(often slower) C<DECIMAL> type is recommended. C<FLOAT> is an alias for
|
||||
C<REAL>.
|
||||
|
||||
=item DOUBLE
|
||||
|
||||
The C<DOUBLE> type specifies a 64-bit floating-point (i.e. fractional) number,
|
||||
accurate to 52 binary digits (I<approximately> 15 decimal digits). The values
|
||||
may be signed, and can range from at least as small as 10^-307 to at least as
|
||||
large as 10^308 (except under Oracle - see below). For exact precision (i.e.
|
||||
for monetary values), the (often slower) C<DECIMAL> type is recommended.
|
||||
|
||||
Take note that Oracle doesn't properly support the full range supported by
|
||||
other databases' C<DOUBLE> types - the smallest number supported (assuming
|
||||
precision to digits) is 10^-113 - specifically, the number of digits after the
|
||||
decimal place may not exceed 128 - so 1.2345678901e-117 is acceptable, while
|
||||
1.23456789012e-117 is not. The larger number Oracle supports is just less than
|
||||
1e+126 (i.e. 9.999...e+125), as opposed to other databases' 1e+307. If you
|
||||
need to store numbers larger or smaller than this amount, you'll have to find
|
||||
some other way to store your numbers (i.e. Math::BigFloat with a C<VARCHAR>).
|
||||
|
||||
=back
|
||||
|
||||
=head2 Aribtrary precision numbers
|
||||
|
||||
=over 4
|
||||
|
||||
=item DECIMAL
|
||||
|
||||
The C<DECIMAL> type is provided to support numbers of arbitrary precision. It
|
||||
requires two attributes, C<scale> and C<precision>, where C<scale> specifies
|
||||
the number of decimal places, and precision specifies the number of overall
|
||||
digits. For example, C<123.45> has a C<precision> of 5, and a C<scale> of 2.
|
||||
C<42> has a C<precision> or 2, and a C<scale> of 0. C<scale> must be less than
|
||||
C<precision>, and C<precision> must not exceed 38. Also, although the value
|
||||
stored and retrieved is completely accurate within it's given precision and
|
||||
scale range, the accuracy available for comparisons (i.e. column = number) is
|
||||
only reliably accurate to approximately the same level as DOUBLE's - that is,
|
||||
about 15 digits.
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=head2 Character types
|
||||
|
||||
=over 4
|
||||
|
||||
=item CHAR
|
||||
|
||||
The C<CHAR> type is used to specify a string of characters from 1 to 255
|
||||
characters long. It takes a C<size> attribute which must be 255 or less, and
|
||||
specifies the size of the column values - if not specified, 255 will be used.
|
||||
This implementation's C<CHAR> type, for historic reasons, B<will not> pad
|
||||
inserted values with spaces, but B<may> trim trailing spaces when retrieving
|
||||
and/or comparing values. Note that this is B<not> SQL compliant C<CHAR>
|
||||
behaviour - SQL-compliant C<CHAR>'s are padded with spaces up to their size.
|
||||
|
||||
What this ends up meaning is that for everything except MySQL, C<CHAR> columns
|
||||
will be mapped to C<VARCHAR> columns. Note that even MySQL, which is the only
|
||||
database for which C<CHAR>'s are not automatically mapped into C<VARCHAR>'s,
|
||||
will I<transparently> convert C<CHAR> columns to C<VARCHAR> columns if any
|
||||
non-fixed-size datatype (anything other than a C<CHAR> or numeric types) is
|
||||
used in or added to the table. As a general rule, C<VARCHAR> is preferred over
|
||||
C<CHAR> except when dealing with columns whose values don't vary significantly
|
||||
in length B<and> are in a table that only contains fixed-size data types
|
||||
(C<CHAR>'s and numeric types). Everywhere else, use C<VARCHAR>'s, since that's
|
||||
what you'll be getting anyway.
|
||||
|
||||
A C<binary> attribute is supported, which I<may> indicates that comparisons
|
||||
with this field should be case-sensitive. Note that this only works on
|
||||
databases that actually have a case-sensitive C<CHAR> field - currently, only
|
||||
MySQL.
|
||||
|
||||
=item VARCHAR
|
||||
|
||||
The C<VARCHAR> type is identical to the above C<CHAR> type B<except> as
|
||||
follows. Unlike a C<CHAR>, a C<VARCHAR> column does not take up C<size> bytes
|
||||
of storage space - typically the storage space is only slightly larger
|
||||
(typically 1 byte) than the size of the value stored. As such, C<VARCHAR>'s
|
||||
are almost always preferred over columns, except for nearly-constant sized
|
||||
data, or tables with all fixed-width data types (C<CHAR>'s, C<INT>'s, and
|
||||
non-C<DECIMAL> numeric types). C<VARCHAR> columns will not be padded with
|
||||
whitespace up to C<size>, however trailing whitespace C<may> be trimmed from
|
||||
values.
|
||||
|
||||
As with C<CHAR>, the C<binary> attribute I<may> make the C<VARCHAR> values
|
||||
case-sensitive for the matching purposes.
|
||||
|
||||
=item TEXT
|
||||
|
||||
The C<TEXT> type is similar to C<VARCHAR> types, except that they are always
|
||||
case-insensitive for matching/equality, and can contain longer values. The
|
||||
C<TEXT> type takes a C<size> attribute which contains the length required - if
|
||||
not provided, a value of approximately 2 billion is used. Note that the
|
||||
maximum size of the column will usually be larger than the value you specify to
|
||||
C<size> - it simply indicates to the driver to use a field capable of at least
|
||||
the size specified. The values of C<TEXT> fields are case-insensitive in terms
|
||||
of matches and equality. The maximum C<size> value, and the default, is
|
||||
approximately 2 billion.
|
||||
|
||||
Certain aliases are provided with implicit size defaults - C<TINYTEXT>,
|
||||
C<SMALLTEXT>, C<MEDIUMTEXT>, and C<LONGTEXT>, which are equivelant to C<TEXT>
|
||||
with C<size> values of 255, 65535, 16777215, and 2147483647, respectively.
|
||||
|
||||
Depending on the C<size> value, certain databases _may_ use different
|
||||
underlying types. MySQL, for example, uses the smallest possible type between
|
||||
its native C<TINYTEXT>, C<TEXT>, C<MEDIUMTEXT>, and C<LONGTEXT> types. As
|
||||
such, it is recommended that you use a sufficiently large C<size> value unless
|
||||
absolutely sure that you will never need a larger value.
|
||||
|
||||
Also note that C<TEXT> types B<do not> support normal equality operations - in
|
||||
fact, the only portable things that can be done with C<TEXT> columns is C<IS
|
||||
NULL> tests (in GT::SQL this means "=" C<undef>) and C<LIKE> comparisons - but,
|
||||
for portability with all supported databases, the argument of a C<LIKE> may not
|
||||
exceed 4000 characters.
|
||||
|
||||
Also note that the C<default> value will be ignored by MySQL, which does not
|
||||
support having default values on C<TEXT> columns. Everything else, however,
|
||||
will properly support this, and the default will still be used when inserting
|
||||
with GT::SQL even when using MySQL. Also note that the default value of
|
||||
C<TEXT> types B<must not> exceed 3998 characters, due to limits imposed by some
|
||||
databases. Longer indexes may work in some cases, but are not guaranteed - for
|
||||
example, a table resync on MSSQL will not work.
|
||||
|
||||
=item ENUM
|
||||
|
||||
The C<ENUM> type is a MySQL-only type that supports certain fixed string
|
||||
values. On non-MySQL databases, it is simply mapped to a C<VARCHAR> column.
|
||||
It requires a C<values> option which should have a value of an array reference
|
||||
of string values that the ENUM should permit. The C<ENUM> type is generally
|
||||
discouraged in favour of a C<CHAR>, C<VARCHAR>, or an
|
||||
L<integral type|/"Integer types"> column, all of which provide more flexibility
|
||||
(i.e. if you want to add a new possible value) and are not a single
|
||||
database-specific type.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Date/time types
|
||||
|
||||
All of the date/time types support by MySQL will be handled by GT::SQL, for
|
||||
compatibility reasons. However, all types other than DATE and C<DATETIME>
|
||||
should be considered deprecated as cross-database compatibility is not possible
|
||||
using these types. In particular, C<TIMESTAMP> will work exactly like a
|
||||
C<DATETIME> on every non-MySQL database; C<TIME> and C<DATE> will work in
|
||||
Postgres just like they do in MySQL; under everything else, C<TIME> won't work
|
||||
at all, and C<DATE> will work like C<DATETIME>.
|
||||
|
||||
GT::SQL users are urged to at least consider using an INT column, designed to
|
||||
contain Perl's time() value, in lieu of any of the Date/time types as it avoids
|
||||
many problems typically associated with storing local times - such as time zone
|
||||
issues and non-local databases. That said, if you are certain you want a
|
||||
Date/time type, a DATETIME is preferred as it will work (almost) the same
|
||||
everywhere.
|
||||
|
||||
=over 4
|
||||
|
||||
=item DATETIME
|
||||
|
||||
A date field, which stores values in C<YYYY-MM-DD HH:MM:SS> format (where
|
||||
C<'HH'> is a 24-hour hour). Inserted values may omit the seconds
|
||||
(C<YYYY-MM-DD HH:MM>), or time (C<YYYY-MM-DD>) portions of the value. Omitted
|
||||
values will default to C<0>.
|
||||
|
||||
Note that C<DATETIME> values returned from a database I<may> include
|
||||
fractional-second precision values such as C<2004-01-01 12:00:07.123>.
|
||||
Currently MSSQL and Postgres exhibit this behaviour. MSSQL's C<DATETIME> type
|
||||
always includes exactly three decimal digits, while Postgres' C<TIMESTAMP> type,
|
||||
used for GT::SQL C<DATETIME>'s, stores times with 6 decimal-digit precision.
|
||||
Unlike MSSQL, however, Postgres will only display decimal digits if a
|
||||
significant decimal value has been stored in the database. This happens with
|
||||
the C<time_check> option, below, and when an explicit fractional second value
|
||||
has been inserted into the database.
|
||||
|
||||
A C<time_check> attribute may be passed with a true value; if set, any update
|
||||
to the row that doesn't explicitly set the column will have the column updated
|
||||
to the B<database's> current local time. Due to issues with times and/or
|
||||
timezones, this option should be considered deprecated and discouraged - it is
|
||||
recommended instead that you update the value yourself using a value that
|
||||
I<your script> thinks is local time (or, better yet, use an C<INT> column with
|
||||
unix time values (i.e. time() in Perl), which are timezone-independent to begin
|
||||
with), rather than trying to depend on a database having the same time and time
|
||||
zone as your script.
|
||||
|
||||
=item DATE
|
||||
|
||||
Just like C<DATETIME>, except (under MySQL and Postgres) it only stores and
|
||||
returns the C<YYYY-MM-DD> portion of the value. Note that when using this
|
||||
type, care must be taken to extract only the desired portion of the output as
|
||||
databases other than MySQL and Postgres map this to a C<DATETIME> above, which
|
||||
returns 'YYYY-MM-DD HH:MM:SS' values (with a possible fractional seconds value,
|
||||
in the case of MSSQL/Postgres). Using a C<DATETIME> or C<INT> field is
|
||||
generally preferred, but this type may be slightly more effecient and take
|
||||
slightly less space (4 bytes instead of 8 bytes) on MySQL and Postgres
|
||||
databases.
|
||||
|
||||
Like C<DATETIME>, this handles a C<time_check> field, with the same caveats
|
||||
described in the the C<DATETIME> C<time_check> description.
|
||||
|
||||
=back
|
||||
|
||||
The alternate, deprecated date/time types supported are listed in the
|
||||
L</Deprecated types> section below.
|
||||
|
||||
=head2 Deprecated types
|
||||
|
||||
=over 4
|
||||
|
||||
=item BLOB
|
||||
|
||||
Limited C<BLOB> support (C<TINYBLOB>, C<BLOB>, C<MEDIUMBLOB>, and C<LONGBLOB>)
|
||||
existed in older versions of GT::SQL, however the support, where it existed at
|
||||
all, was partial and incomplete. Additionally, only certain drivers (MySQL and
|
||||
Oracle) supported C<BLOB> types at all. As such, the limited C<BLOB> support
|
||||
present in old GT::SQL versions is still supported under MySQL and Oracle, but
|
||||
any new development should avoid them. If you really need to store binary
|
||||
data, it is strongly recommended that you use files, and simply store
|
||||
fileI<names> in the database.
|
||||
|
||||
=item TIMESTAMP
|
||||
|
||||
This extremely odd MySQL data type, depending on the version of MySQL, stores
|
||||
times in either the format described in C<DATETIME> (MySQL 4.1+) or an
|
||||
extremely MySQL-specific C<YYYYMMDDhhmmss> format. Another MySQL-specific of
|
||||
this data type is that the first - and ONLY the first - C<TIMESTAMP> column in
|
||||
a row will be automatically updated to the current local timezone-dependent
|
||||
date and time. Use a C<DATETIME> (possibly with the C<time_check> option)
|
||||
instead.
|
||||
|
||||
=item TIME
|
||||
|
||||
A MySQL and Postgres-specific type that stores only the time-of-day in
|
||||
C<HH:MM:SS> format. Deprecated due to non-portability and incompatibility on
|
||||
other databases. If you really want to store just the time of day, either use
|
||||
an C<INT> to store the minutes or seconds since midnight, or use a C<CHAR>
|
||||
which you update with the C<HH:MM:SS> value. Causes a fatal error on databases
|
||||
which don't have an appropriate native type.
|
||||
|
||||
=item YEAR
|
||||
|
||||
A particularly useless MySQL-specific data type that stores only the year
|
||||
portion of a date. Use a C<SMALLINT> instead. Causes a fatal error on
|
||||
anything other than MySQL.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::SQL>
|
||||
|
||||
L<GT::SQL::Creator>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Types.pm,v 1.2 2004/09/07 20:56:59 jagerman Exp $
|
||||
|
||||
=cut
|
||||
276
site/glist/lib/GT/SQL/Upgrade.pm
Normal file
276
site/glist/lib/GT/SQL/Upgrade.pm
Normal file
@@ -0,0 +1,276 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Upgrade
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Upgrade.pm,v 1.3 2005/04/14 00:59:12 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Various commonly used SQL upgrade functions used by GT product upgrades.
|
||||
#
|
||||
|
||||
package GT::SQL::Upgrade;
|
||||
use strict;
|
||||
use vars qw/@ISA @EXPORT $VERSION/;
|
||||
require Exporter;
|
||||
|
||||
# You *must* bump this each time you change or fix any of the code this file or
|
||||
# it is guaranteed to cause problems:
|
||||
$VERSION = 1.00;
|
||||
|
||||
@ISA = 'Exporter';
|
||||
@EXPORT = qw/add_column alter_column drop_column add_index drop_index add_table recreate_table/;
|
||||
|
||||
# Adds a column. Takes 5 args:
|
||||
# Output coderef, database object, table name, column name, column definition
|
||||
# Returns the return of $editor->add_col
|
||||
sub add_column {
|
||||
my ($out, $db, $table, $col, $def) = @_;
|
||||
$out->("Adding column $col to $table table...\n");
|
||||
my $ret = $db->editor($table)->add_col($col => $def);
|
||||
$out->($ret ? "\tOkay!\n" : "\tCould not add column $col: $GT::SQL::error\n");
|
||||
$ret;
|
||||
}
|
||||
|
||||
# Changes a column. Takes 5 args:
|
||||
# Output coderef, database obj, table name, column name, new column definition
|
||||
sub alter_column {
|
||||
my ($out, $db, $table, $col, $def) = @_;
|
||||
$out->("Updating column definition for $col in $table table...\n");
|
||||
my $ret = $db->editor($table)->alter_col($col, $def);
|
||||
$out->($ret ? "\tOkay!\n" : "\tCould not alter column $col: $GT::SQL::error\n");
|
||||
$ret;
|
||||
}
|
||||
|
||||
# Drops a column. Takes 4 args:
|
||||
# Output coderef, database object, table name, column name
|
||||
# Returns the return of $editor->drop_col
|
||||
sub drop_column {
|
||||
my ($out, $db, $table, $col) = @_;
|
||||
$out->("Dropping column '$col' from table '$table'...\n");
|
||||
my $ret = $db->editor($table)->drop_col($col);
|
||||
$out->($ret ? "\tOkay!\n" : "\tCould not drop column $col: $GT::SQL::error\n");
|
||||
$ret;
|
||||
}
|
||||
|
||||
# Adds indexes. Takes 4-5 args
|
||||
# Output coderef, database object, table name, indexes hash reference, and an
|
||||
# optional boolean value to make the added indexes unique indexes.
|
||||
# Returns the return of $editor->add_index
|
||||
sub add_index {
|
||||
my ($out, $db, $table, $indexes, $unique) = @_;
|
||||
my $editor = $db->editor($table);
|
||||
my $cret = 1;
|
||||
while (my ($idx, $defn) = each %$indexes) {
|
||||
my ($meth, $index_display) = $unique ? (add_unique => 'unique index') : (add_index => 'index');
|
||||
$out->("Adding $index_display '$idx' to '$table' table...\n");
|
||||
my $ret = $editor->$meth($idx => $indexes->{$idx});
|
||||
$out->($ret ? "\tOkay!\n" : "\tCould not add $index_display '$idx': $GT::SQL::error\n");
|
||||
$cret = $ret unless $ret;
|
||||
}
|
||||
$cret;
|
||||
}
|
||||
|
||||
# Drops an index. Takes 4-5 args:
|
||||
# Output coderef, GT::SQL obj, table name, index name, plus an optional boolean
|
||||
# value to indicate that the index to drop is a unique index.
|
||||
sub drop_index {
|
||||
my ($out, $db, $table, $index, $unique) = @_;
|
||||
$out->("Dropping index '$index' from '$table' table...\n");
|
||||
my $editor = $db->editor($table);
|
||||
my $meth = $unique ? 'drop_unique' : 'drop_index';
|
||||
my $ret = $editor->$meth($index);
|
||||
$out->($ret ? "\tOkay!\n" : "\tCould not drop index '$index': $GT::SQL::error\n");
|
||||
$ret;
|
||||
}
|
||||
|
||||
# Adds a table. Takes 3 base, plus unlimited extra arguments:
|
||||
# Output coderef, GT::SQL obj, table name
|
||||
# Other arguments are read in pairs - the first is a ::Creator method name, the
|
||||
# second is the value to pass to the method.
|
||||
sub add_table {
|
||||
my ($out, $db, $table) = splice @_, 0, 3;
|
||||
|
||||
$out->("Adding table '$table'...\n");
|
||||
my $c = $db->creator($table);
|
||||
|
||||
while (@_) {
|
||||
my ($meth, $arg) = splice @_, 0, 2;
|
||||
$c->$meth($arg);
|
||||
}
|
||||
|
||||
my $ret = $c->create;
|
||||
if ($ret) {
|
||||
$out->("\tOkay!\n");
|
||||
}
|
||||
else {
|
||||
$out->("\tAn error occured: $GT::SQL::error\n");
|
||||
$c->set_defaults;
|
||||
$c->save_schema;
|
||||
}
|
||||
$ret;
|
||||
}
|
||||
|
||||
# Used when recreating a table is necessary (used in at least the Links SQL
|
||||
# 2.1.2 -> 2.2.0 upgrade) It creates a temporary table, copies all the data
|
||||
# into it, then drops the original table, recreates it, and copies all the data
|
||||
# back.
|
||||
# Usage:
|
||||
# recreate_table($out, $db, $table_name, $condition, ...ARGS...);
|
||||
# - $out is the code reference to call with output
|
||||
# - $db is the GT::SQL object for the database
|
||||
# - $table_name is the name of the table to recreated
|
||||
# - $condition is a code reference - it will be called with the table as an
|
||||
# argument. If it returns true, the table is recreated, otherwise (if it
|
||||
# returns false) recreating the table is skipped.
|
||||
# - Remaining arguments are specified in pairs - the first of each pair of
|
||||
# arguments is the function to call, the second is the argument to pass to
|
||||
# that function. At least a "cols => [ ... ]" pair must be specified.
|
||||
# Known problems:
|
||||
# - The code that copies any custom columns breaks if any columns have been
|
||||
# removed from the new table has fewer columns from the old one - those
|
||||
# columns will be copied to the new table.
|
||||
# - A change adding not_null to a column will only work for INT's/FLOAT's,
|
||||
# for which any previous null values are given a value of 0.
|
||||
sub recreate_table {
|
||||
my ($out, $db, $table_name, $condition) = splice @_, 0, 4;
|
||||
@_ % 2 == 0 or die "Invalid arguments. Usage: recreate_table(INSTALLER_OBJ, GTSQL_OBJ, 'Table', method => val, method => val, ...)";
|
||||
my @args = @_;
|
||||
my %args = @args;
|
||||
my @cols = $args{cols};
|
||||
my %cols = @cols;
|
||||
|
||||
my $table = $db->table($table_name);
|
||||
|
||||
my $success;
|
||||
if ($condition->($table)) {
|
||||
RECREATE: {
|
||||
$out->("Performing required $table_name table recreation...\n");
|
||||
|
||||
$out->("\t- Creating temporary storage table...\n");
|
||||
my @create;
|
||||
my %old_cols = $table->cols;
|
||||
my %new_cols = @{$args{cols}};
|
||||
|
||||
my ($count, @denull) = 0;
|
||||
for (keys %old_cols) {
|
||||
if (
|
||||
!$old_cols{$_}->{not_null} and # Didn't have not_null before
|
||||
$new_cols{$_} and # Still exists in the new version of the table
|
||||
$new_cols{$_}->{not_null} and # not_null present in the new version
|
||||
$new_cols{$_}->{type} =~ /^(?:FLOAT|DOUBLE|DECIMAL|\w*INT)$/ # is a numeric type
|
||||
) {
|
||||
push @denull, $count;
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
|
||||
# Retain any custom columns:
|
||||
for (keys %old_cols) {
|
||||
unless ($cols{$_}) {
|
||||
push @create, $_ => $old_cols{$_};
|
||||
push @cols, $_ => $old_cols{$_};
|
||||
$cols{$_} = $old_cols{$_};
|
||||
}
|
||||
}
|
||||
|
||||
my $c = $db->creator($table_name . '_tmp');
|
||||
$c->cols(@create);
|
||||
|
||||
# We should probably 'force' the following create, but that is
|
||||
# potentially dangerous if the main table isn't recreated properly.
|
||||
my $ret = $c->create;
|
||||
if ($ret) {
|
||||
$out->("\t\tOkay!\n");
|
||||
}
|
||||
else {
|
||||
$out->("\t\tAn error occured: $GT::SQL::error\n");
|
||||
last RECREATE;
|
||||
}
|
||||
|
||||
my $tmp_table = $db->table($table_name . '_tmp');
|
||||
|
||||
$out->("\t- Copying existing data to temporary table...\n");
|
||||
my $sth = $table->select(keys %old_cols);
|
||||
my @recs;
|
||||
while () {
|
||||
my $row = $sth->fetchrow_arrayref;
|
||||
if ($row) {
|
||||
my @row = @$row;
|
||||
for (@denull) {
|
||||
$row[$_] = 0 if not defined $row[$_];
|
||||
}
|
||||
push @recs, \@row;
|
||||
}
|
||||
if (!$row or @recs >= 1000) {
|
||||
$ret = $tmp_table->insert_multiple([keys %old_cols], @recs) if @recs;
|
||||
$out->("\t\tAn error occured: $GT::SQL::error\n") unless $ret;
|
||||
@recs = ();
|
||||
last if !$row;
|
||||
}
|
||||
}
|
||||
$out->("\t\tOkay!\n");
|
||||
|
||||
$out->("\t- Dropping $table_name table...\n");
|
||||
$ret = $db->editor($table_name)->drop_table;
|
||||
if ($ret) {
|
||||
$out->("\t\tOkay!\n");
|
||||
}
|
||||
else {
|
||||
$out->("\t\tAn error occured: $GT::SQL::error\n");
|
||||
}
|
||||
|
||||
$out->("\t- Creating new $table_name table...\n");
|
||||
$c = $db->creator($table_name);
|
||||
while (@args) {
|
||||
my ($method, $value) = (shift @args, shift @args);
|
||||
$c->$method($value);
|
||||
}
|
||||
|
||||
$ret = $c->create('force');
|
||||
if ($ret) {
|
||||
$out->("\t\tOkay!\n");
|
||||
}
|
||||
else {
|
||||
$out->("\t\tAn error occured: $GT::SQL::error\n");
|
||||
last RECREATE;
|
||||
}
|
||||
|
||||
$out->("\t- Copying temporary data back into new table...\n");
|
||||
$sth = $tmp_table->select(keys %old_cols);
|
||||
@recs = ();
|
||||
while () {
|
||||
my $row = $sth->fetchrow_arrayref;
|
||||
push @recs, [@$row] if $row;
|
||||
if (!$row or @recs >= 1000) {
|
||||
$ret = $table->insert_multiple([keys %old_cols], @recs) if @recs;
|
||||
$out->("\t\tAn error occured: $GT::SQL::error\n") unless $ret;
|
||||
@recs = ();
|
||||
last if !$row;
|
||||
}
|
||||
}
|
||||
$out->("\t\tOkay!\n");
|
||||
|
||||
$out->("\t- Dropping ${table_name}_tmp table...\n");
|
||||
$ret = $db->editor("${table_name}_tmp")->drop_table;
|
||||
if ($ret) {
|
||||
$out->("\t\tOkay!\n");
|
||||
}
|
||||
else {
|
||||
$out->("\t\tAn error occured: $GT::SQL::error\n");
|
||||
}
|
||||
|
||||
$success = 1;
|
||||
}
|
||||
|
||||
if (!$success) {
|
||||
$out->("\tAn error occured while attempting to recreate $table_name. Procedure aborted.\n");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
295
site/glist/lib/GT/Session/File.pm
Normal file
295
site/glist/lib/GT/Session/File.pm
Normal file
@@ -0,0 +1,295 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Session::File
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: File.pm,v 1.14 2004/01/13 01:35:20 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# A module for implementing session management.
|
||||
#
|
||||
# Todo:
|
||||
# - SQL Support.
|
||||
#
|
||||
|
||||
package GT::Session::File;
|
||||
# ===============================================================
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS $error $DIRECTORY $SESSION);
|
||||
|
||||
# Internal nodules
|
||||
use GT::Base ();
|
||||
use GT::MD5 qw/md5_hex/;
|
||||
use GT::Dumper;
|
||||
|
||||
# Global variable init
|
||||
@ISA = qw/GT::Base/;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ATTRIBS = {
|
||||
id => undef,
|
||||
data => undef,
|
||||
directory => undef,
|
||||
save => 0,
|
||||
subdir => 0,
|
||||
|
||||
_debug => $DEBUG
|
||||
};
|
||||
$ERRORS = {
|
||||
'BADDATA' => "Invalid data in session: '%s'. Reason: '%s'",
|
||||
'NOROOT' => "No root directory was defined!",
|
||||
'CANTOPEN' => "Can't open file: '%s'. Reason: '%s'",
|
||||
'CANTDEL' => "Unable to delete file: '%s'. Reason: '%s'",
|
||||
'CLASSFUNC' => "This is a class function only.",
|
||||
'INVALIDSESSION' => "Invalid session id: '%s'."
|
||||
};
|
||||
$DIRECTORY = "./auth";
|
||||
$SESSION = '';
|
||||
|
||||
sub new {
|
||||
# ---------------------------------------------------------------
|
||||
# Initilizes a session. Expects to find a session id to lookup, some
|
||||
# data to save, or nothing. If no session is defined, then one will
|
||||
# be generated. If an invalid session is specified, nothing is returned.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {}, $class;
|
||||
|
||||
# Set defaults.
|
||||
foreach (keys %$ATTRIBS) {
|
||||
$self->{$_} = $ATTRIBS->{$_};
|
||||
}
|
||||
|
||||
# Don't save by default.
|
||||
$self->{save} = 0;
|
||||
|
||||
# We got passed in a single session id.
|
||||
if (@_ == 1) {
|
||||
$self->load ($_[0]) or return $self->error ('INVALIDSESSION', 'WARN', $_[0]);
|
||||
return $self;
|
||||
}
|
||||
|
||||
# We got passed some options, possibly a session id.
|
||||
if (@_ > 1) {
|
||||
my $opts = $self->common_param(@_);
|
||||
foreach (keys %$opts) {
|
||||
exists $self->{$_} and ($self->{$_} = $opts->{$_});
|
||||
}
|
||||
if ($self->{directory}) {
|
||||
$DIRECTORY = $self->{directory};
|
||||
}
|
||||
}
|
||||
|
||||
# If we have an id, load it or return.
|
||||
if ($self->{id}) {
|
||||
$self->load ($self->{id}) or return $self->error ('INVALIDSESSION', 'WARN', $self->{id});
|
||||
}
|
||||
else {
|
||||
$self->{id} = generate_session_id();
|
||||
$self->{save} = 1;
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# ---------------------------------------------------------------
|
||||
# Makes sure we save the session.
|
||||
#
|
||||
$_[0]->save() if ($_[0]->{save});
|
||||
$_[0]->debug ("Object destroyed.") if ($_[0]->{_debug} > 1);
|
||||
}
|
||||
|
||||
sub data {
|
||||
# ---------------------------------------------------------------
|
||||
# Set/retrieve the data, make sure to set save to 1.
|
||||
#
|
||||
if (@_ > 1) { $_[0]->{data} = $_[1]; $_[0]->{save} = 1; }
|
||||
return $_[0]->{data};
|
||||
}
|
||||
|
||||
sub load {
|
||||
# ---------------------------------------------------------------
|
||||
# Loads a session id and data.
|
||||
#
|
||||
my ($self, $sid) = @_;
|
||||
if (($sid =~ /^[\w\d]+$/) and (length $sid < 40)) {
|
||||
my $root = $DIRECTORY or return $self->error ('NOROOT', 'FATAL');
|
||||
my $file = $root;
|
||||
if ($self->{subdir}) {
|
||||
$file .= '/' . substr ($sid, 0, 1);
|
||||
}
|
||||
$file .= '/' . $sid;
|
||||
if (-e $file) {
|
||||
local ($@, $!, $SESSION);
|
||||
$file =~ /(.*)/;
|
||||
$file = $1;
|
||||
|
||||
do "$file";
|
||||
($@ || $!) and return $self->error ('BADDATA', 'FATAL', $file, "$@" || "$!");
|
||||
$self->{data} = $SESSION;
|
||||
$self->{id} = $sid;
|
||||
$self->debug ("Session '$sid' loaded ok.") if ($self->{_debug});
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
$self->debug ("Attempted to load invalid session: '$sid'.") if ($self->{_debug});
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->debug ("Attempted to load invalid, or blank session '$sid'.") if ($self->{_debug});
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub save {
|
||||
# ---------------------------------------------------------------
|
||||
# Save a session id and data.
|
||||
#
|
||||
my $self = shift;
|
||||
my $sid = $self->{id};
|
||||
|
||||
if (($sid =~ /^[\w\d]+$/) and (length $sid < 40)) {
|
||||
my $root = $DIRECTORY or return $self->error ('NOROOT', 'FATAL');
|
||||
my $file = $root;
|
||||
if ($self->{subdir}) {
|
||||
$file .= '/' . substr ($sid, 0, 1);
|
||||
-d $file or mkdir ($file, 0755) or return $self->error ('CANTOPEN', 'FATAL', $file, "$!");
|
||||
}
|
||||
$file .= '/' . $sid;
|
||||
my $fh = \do {local *FH; *FH};
|
||||
open ($fh, "> $file") or return $self->error ('CANTOPEN', 'FATAL', $file, "$!");
|
||||
my $dump = GT::Dumper->dump(
|
||||
var => '$SESSION',
|
||||
data => $self->{data}
|
||||
);
|
||||
print $fh $dump;
|
||||
close $fh;
|
||||
$self->{save} = 0;
|
||||
$self->debug ("Session '$sid' saved.") if ($self->{_debug});
|
||||
}
|
||||
else {
|
||||
$self->debug ("Attempted to save invalid session '$sid'") if ($self->{_debug});
|
||||
}
|
||||
}
|
||||
|
||||
sub delete {
|
||||
# ---------------------------------------------------------------
|
||||
# Delete a session.
|
||||
#
|
||||
my $self = shift;
|
||||
my $sid;
|
||||
if (! ref $self) {
|
||||
$self = bless { _debug => $DEBUG }, $self;
|
||||
$sid = shift;
|
||||
}
|
||||
else {
|
||||
$sid = $self->{id}
|
||||
}
|
||||
|
||||
if (($sid =~ /^([\w\d]+)$/) and (length $sid < 40)) {
|
||||
$sid = $1;
|
||||
my $root = $DIRECTORY or return $self->error ('NOROOT', 'FATAL');
|
||||
my $file = $root;
|
||||
if ($self->{subdir}) {
|
||||
$file .= '/' . substr ($sid, 0, 1);
|
||||
}
|
||||
$file .= '/' . $sid;
|
||||
unlink $file or return $self->error ('CANTDEL', 'WARN', $file, "$!");
|
||||
$self->{id} = undef;
|
||||
$self->{data} = undef;
|
||||
$self->{save} = 0;
|
||||
$self->debug ("Session '$sid' deleted.") if ($self->{_debug});
|
||||
}
|
||||
}
|
||||
|
||||
sub cleanup {
|
||||
# ---------------------------------------------------------------
|
||||
# CLASS function to cleanup session directory.
|
||||
#
|
||||
my ($self, $seconds, $directory) = @_;
|
||||
(ref $self) or $self = bless { _debug => $DEBUG }, $self;
|
||||
|
||||
if ($seconds == 0) {
|
||||
$self->debug ("Cleanup not erasing anything, seconds set to 0.") if ($self->{_debug});
|
||||
return;
|
||||
}
|
||||
|
||||
defined $seconds or ($seconds = 3600);
|
||||
defined $directory or ($directory = $DIRECTORY);
|
||||
$directory or return $self->error ('NOROOT', 'FATAL');
|
||||
|
||||
my $dir = \do {local *FH; *FH};
|
||||
opendir ($dir, $directory) or return $self->error ('CANTOPEN', 'FATAL', $directory, "$!");
|
||||
my @files = grep { $_ and (!/^\.\.?$/) and (/^[\w\d]+$/) and (length ($_) < 40) } readdir ($dir);
|
||||
closedir ($dir);
|
||||
|
||||
foreach my $file (@files) {
|
||||
my $full_file = "$directory/$file";
|
||||
my $is_dir = -d $full_file;
|
||||
|
||||
if ($self->{subdir} and $is_dir) {
|
||||
my $dir = \do {local *FH; *FH};
|
||||
opendir $dir, $full_file or return $self->error ('CANTOPEN', 'FATAL', $full_file, "$!");
|
||||
push @files, map { $file . '/' . $_ } grep { (!/^\.\.?$/) and (/^[\w\d]+$/) and (length ($_) < 40) } readdir ($dir);
|
||||
closedir $dir;
|
||||
next;
|
||||
}
|
||||
elsif ($is_dir) {
|
||||
next;
|
||||
}
|
||||
|
||||
if (((stat($full_file))[9] + $seconds) <= time()) {
|
||||
$self->debug ("Cleanup is removing '$full_file' older then $seconds s. old.") if ($self->{_debug});
|
||||
$full_file =~ /(.*)/;
|
||||
$full_file = $1;
|
||||
unlink $full_file or return $self->error ('CANTDEL', 'FATAL', $full_file, "$!");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub generate_session_id {
|
||||
# ---------------------------------------------------------------
|
||||
# Generates a session id.
|
||||
#
|
||||
return md5_hex ( time . $$ . rand (16000) );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Session::File - A session management module, with simple data storage/retrieval.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Create a session:
|
||||
my $session = new GT::Session::File;
|
||||
my $id = $session->id();
|
||||
|
||||
Save data with the session:
|
||||
$session->data ("Save this information!");
|
||||
|
||||
Load a session.
|
||||
my $session = new GT::Session::File ( $id ) or die "Can't load session: '$id'."
|
||||
|
||||
Set session directory.
|
||||
my $session = new GT::Session::File ( directory => '/path/to/sessions', id => $id );
|
||||
|
||||
Delete a session
|
||||
$session->delete();
|
||||
|
||||
Cleanup old sessions, takes argument of number of seconds old.
|
||||
$session->cleanup ( 5000 );
|
||||
|
||||
=head1 TODO
|
||||
|
||||
* Integrate SQL interface into flatfile interface.
|
||||
276
site/glist/lib/GT/Session/SQL.pm
Normal file
276
site/glist/lib/GT/Session/SQL.pm
Normal file
@@ -0,0 +1,276 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Session::SQL
|
||||
# Author: Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: SQL.pm,v 1.34 2004/06/11 21:07:43 alex Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# A module for implementing session management in SQL.
|
||||
# Note that it requires a table with the following columns:
|
||||
# session_id - must be CHAR(32) BINARY
|
||||
# session_user_id
|
||||
# session_date - must be INT
|
||||
# session_data
|
||||
|
||||
package GT::Session::SQL;
|
||||
# ===============================================================
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS $error $DIRECTORY);
|
||||
|
||||
# Internal nodules
|
||||
use GT::Base ();
|
||||
|
||||
# Global variable init
|
||||
@ISA = qw/GT::Base/;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
|
||||
$ATTRIBS = {
|
||||
info => {
|
||||
session_date => undef,
|
||||
session_data => undef,
|
||||
session_id => undef,
|
||||
session_user_id => undef
|
||||
},
|
||||
tb => undef,
|
||||
_debug => $DEBUG,
|
||||
expires => 4
|
||||
};
|
||||
|
||||
$ERRORS = {
|
||||
BADDATA => "Invalid data in session: '%s'. Reason: '%s'",
|
||||
CLASSFUNC => "This is a class function only.",
|
||||
INVALIDSESSION => "Invalid session id: '%s'.",
|
||||
BADARGS => "Invalid arguments: %s"
|
||||
};
|
||||
|
||||
sub new {
|
||||
# ---------------------------------------------------------------
|
||||
# Initilizes a session. Expects to find a session id to lookup, some
|
||||
# data to save, or nothing. If no session is defined, then one will
|
||||
# be generated. If an invalid session is specified, nothing is returned.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {}, $class;
|
||||
|
||||
# Set defaults.
|
||||
foreach (keys %$ATTRIBS) {
|
||||
$self->{$_} = ref $ATTRIBS->{$_} eq 'HASH'
|
||||
? {%{$ATTRIBS->{$_}}}
|
||||
: $ATTRIBS->{$_};
|
||||
}
|
||||
|
||||
# We got passed in a single session id.
|
||||
if (@_ == 2) {
|
||||
$self->{tb} = $_[1];
|
||||
$self->load($_[0]) or return $self->error('INVALIDSESSION', 'WARN', $_[0]);
|
||||
$self->{save} = 0;
|
||||
return $self;
|
||||
}
|
||||
|
||||
# We got passed some options, possibly a session id.
|
||||
my $suggested;
|
||||
if (@_ == 1 and ref $_[0] eq 'HASH') {
|
||||
my $opts = $_[0];
|
||||
foreach (keys %{$opts}) {
|
||||
if (exists $self->{$_}) { $self->{$_} = $opts->{$_} }
|
||||
elsif (exists $self->{info}->{$_}) { $self->{info}->{$_} = $opts->{$_} }
|
||||
elsif ($_ eq 'suggested_sid') { $suggested = $opts->{$_}; }
|
||||
}
|
||||
}
|
||||
|
||||
exists($self->{tb}) or return $self->error("BADARGS", "FATAL", "Must pass in a table object");
|
||||
|
||||
# If we have an id, load it or return.
|
||||
if ($self->{info}->{session_id}) {
|
||||
$self->load($self->{info}->{session_id}) or return $self->error('INVALIDSESSION', 'WARN', $self->{info}->{session_id});
|
||||
$self->{save} = 0;
|
||||
}
|
||||
else {
|
||||
my $sid;
|
||||
$sid = defined $suggested ? $suggested : generate_session_id();
|
||||
while ($self->{tb}->count({ session_id => $sid }) > 0) {
|
||||
$sid = generate_session_id();
|
||||
}
|
||||
$self->{info}->{session_id} = $sid;
|
||||
$self->{save} = 1;
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
DESTROY {
|
||||
# ---------------------------------------------------------------
|
||||
# Makes sure we save the session.
|
||||
#
|
||||
local $SIG{__WARN__};
|
||||
my $self = shift;
|
||||
$self->save() if $self->{save};
|
||||
$self->debug("Object destroyed.") if $self->{_debug} and $self->{_debug} > 1;
|
||||
}
|
||||
|
||||
sub data {
|
||||
# ---------------------------------------------------------------
|
||||
# Set/retrieve the data, make sure to set save to 1.
|
||||
#
|
||||
my $self = shift;
|
||||
if (@_ >= 1) {
|
||||
$self->{info}->{session_data} = shift;
|
||||
$self->{save} = 1;
|
||||
}
|
||||
return $self->{info}->{session_data};
|
||||
}
|
||||
|
||||
sub load {
|
||||
# ---------------------------------------------------------------
|
||||
# Loads a session id and data. Also updates the date if the
|
||||
# session is valid
|
||||
#
|
||||
my ($self, $sid) = @_;
|
||||
if (defined($sid) and $sid =~ /^\w{1,32}$/) {
|
||||
my $expires = $self->{expires};
|
||||
my $too_old = ($expires ? time - $expires * 60 * 60 : 0);
|
||||
my $sth = $self->{tb}->select(
|
||||
GT::SQL::Condition->new(
|
||||
'session_id' => '=' => $sid,
|
||||
($too_old ? ('session_date' => '>' => $too_old) : ())
|
||||
)
|
||||
) or return $self->error($GT::SQL::error);
|
||||
|
||||
my $ret = $sth->fetchrow_hashref;
|
||||
if (!$sth->rows or !$ret) {
|
||||
$self->debug("Attempted to load invalid session: '$sid'.") if $self->{_debug};
|
||||
return;
|
||||
}
|
||||
my $cp = {};
|
||||
for (keys %{$self->{info}}) {
|
||||
if ($_ eq 'session_data') {
|
||||
if (defined $self->{info}->{session_data}) {
|
||||
require GT::Dumper;
|
||||
my $data = GT::Dumper->dump(
|
||||
var => '',
|
||||
data => $self->{info}->{session_data},
|
||||
);
|
||||
$cp->{session_data} = $data;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$cp->{$_} = $self->{info}->{$_};
|
||||
}
|
||||
}
|
||||
if (exists $ret->{session_data}) {
|
||||
my $ev = delete $ret->{session_data};
|
||||
local ($@, $SIG{__DIE__});
|
||||
$self->{info}->{session_data} = eval $ev;
|
||||
$@ and return $self->error('BADDATA', 'FATAL', $sid, "$@");
|
||||
}
|
||||
for (keys %$ret) {
|
||||
$self->{info}->{$_} = $ret->{$_};
|
||||
$cp->{$_} = $ret->{$_} unless defined $cp->{$_};
|
||||
}
|
||||
$cp->{session_date} = time;
|
||||
my $s = delete $cp->{session_id};
|
||||
$self->{tb}->update($cp, { session_id => $s }) or return $self->error($GT::SQL::error);
|
||||
}
|
||||
else {
|
||||
$self->debug("Attempted to load invalid, or blank session '" . (defined($sid) ? $sid : '[undefined]') . ".") if $self->{_debug};
|
||||
return;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub save {
|
||||
# ---------------------------------------------------------------
|
||||
# Save a session id and data.
|
||||
#
|
||||
my $self = shift;
|
||||
my $sid = $self->{info}->{session_id};
|
||||
|
||||
if ($sid =~ /^\w{1,32}$/ and (defined $self->{info}->{session_user_id} or defined $self->{info}->{session_data})) {
|
||||
require GT::Dumper;
|
||||
my $data = GT::Dumper->dump(
|
||||
var => '',
|
||||
data => $self->{info}->{session_data},
|
||||
compress => 1 # Eliminates whitespace and changes => to , to shrink the dump
|
||||
);
|
||||
my $info = {%{$self->{info}}}; # Copy $self->{info}
|
||||
$info->{session_data} = $data;
|
||||
$info->{session_date} = time;
|
||||
if ($self->{tb}->count({ session_id => $sid })) {
|
||||
delete $info->{session_id};
|
||||
# need to do an update instead of an insert because it already exists
|
||||
$self->{tb}->update($info, { session_id => $sid }) or return $self->error($GT::SQL::error);
|
||||
$self->debug("Changes to session '$sid' saved.") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
# It doesn't exist, so insert
|
||||
$self->{tb}->insert($info) or return $self->error($GT::SQL::error);
|
||||
$self->debug("Session '$sid' created and saved.") if $self->{_debug};
|
||||
}
|
||||
$self->{save} = 0;
|
||||
}
|
||||
else {
|
||||
$self->debug("Attempted to save invalid session '$sid'") if $self->{_debug};
|
||||
}
|
||||
}
|
||||
|
||||
sub delete {
|
||||
# ---------------------------------------------------------------
|
||||
# Delete a session.
|
||||
#
|
||||
my $self = shift;
|
||||
my $sid = $self->{info}->{session_id};
|
||||
|
||||
if ($sid =~ /^\w{1,32}$/) {
|
||||
$self->{tb}->delete({ session_id => $sid }) or return $self->error($GT::SQL::error);
|
||||
|
||||
$self->{info}->{session_id} = undef;
|
||||
$self->{info}->{session_data} = undef;
|
||||
$self->{save} = 0;
|
||||
$self->debug("Session '$sid' deleted.") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
$self->debug("Attempted to delete an invalid session '$sid'") if $self->{_debug};
|
||||
return;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub cleanup {
|
||||
# ---------------------------------------------------------------
|
||||
# Method to cleanup sessions.
|
||||
#
|
||||
# Takes an optional arguments - the session timeout (in seconds).
|
||||
# If omitted, $self->{expires} will be used for the timeout.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my $seconds;
|
||||
$seconds = @_ ? shift : $self->{expires} * 60 * 60;
|
||||
|
||||
unless ($seconds) {
|
||||
$self->debug("cleanup not deleting anything, seconds set to 0.") if $self->{_debug};
|
||||
return;
|
||||
}
|
||||
|
||||
my $too_old = time - $seconds;
|
||||
|
||||
$self->{tb}->delete(GT::SQL::Condition->new(session_date => '<' => $too_old)) or return $self->error($GT::SQL::error);
|
||||
}
|
||||
|
||||
sub generate_session_id {
|
||||
# ---------------------------------------------------------------
|
||||
# Generates a session id.
|
||||
#
|
||||
require GT::MD5;
|
||||
GT::MD5::md5_hex(rand(16000) . (time() ^ ($$ + ($$ << 15))) . $$);
|
||||
}
|
||||
|
||||
1;
|
||||
310
site/glist/lib/GT/Session/TempTable.pm
Normal file
310
site/glist/lib/GT/Session/TempTable.pm
Normal file
@@ -0,0 +1,310 @@
|
||||
package GT::Session::TempTable;
|
||||
# ===============================================================
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw| $ATTRIBS @ISA $ERRORS |;
|
||||
|
||||
# Internal nodules
|
||||
use GT::Base;
|
||||
use GT::SQL;
|
||||
use GT::MD5 qw| md5_hex |;
|
||||
|
||||
# Global variable init
|
||||
@ISA = qw| GT::Base |;
|
||||
|
||||
$ATTRIBS = {
|
||||
id => undef,
|
||||
tb => undef,
|
||||
|
||||
def_path => '',
|
||||
db => undef,
|
||||
set_name => 'Set_Sessions',
|
||||
create_session => undef,
|
||||
delete_session => undef,
|
||||
seconds => 60*60,
|
||||
sid => ''
|
||||
};
|
||||
|
||||
$ERRORS = {
|
||||
'NODB' => "No GT::SQL object, need to set 'db' or 'def_path'",
|
||||
'NOCS' => "No session creation hook specified",
|
||||
'CSNOTCODE' => "Session creation hook is not a coderef",
|
||||
'NOSID' => "No session ID",
|
||||
'BADDATA' => "Invalid data in session: '%s'. Reason: '%s'",
|
||||
'CLASSFUNC' => "This is a class function only.",
|
||||
'INVALIDSESSION'=> "Invalid session id: '%s'.",
|
||||
'BADARGS' => "Invalid arguments: %s",
|
||||
|
||||
};
|
||||
|
||||
sub install {
|
||||
#-------------------------------------------------------------------------------
|
||||
# creates the controller table
|
||||
#
|
||||
my $self = shift;
|
||||
my $DB = $self->_db();
|
||||
|
||||
my $c = $DB->creator( $self->{set_name} );
|
||||
|
||||
$c->cols(
|
||||
ID => { pos => 1, type => 'INT', not_null => 1, unsigned => 1, regex => '^d+$' },
|
||||
SessID => { pos => 2, type => 'CHAR', size => 100, not_null => 1 },
|
||||
SessTable => { pos => 3, type => 'CHAR', size => 100, not_null => 1 },
|
||||
Timestmp => { pos => 4, type => 'TIMESTAMP', time_check => 1 }
|
||||
);
|
||||
|
||||
$c->pk('ID');
|
||||
$c->ai('ID');
|
||||
$c->create('force');
|
||||
$c->set_defaults();
|
||||
$c->save_schema();
|
||||
}
|
||||
|
||||
sub uninstall {
|
||||
#-------------------------------------------------------------------------------
|
||||
# drops the controller table along with all the
|
||||
#
|
||||
my $self = shift;
|
||||
my $DB = $self->_db() or return;
|
||||
my $err = 1;
|
||||
|
||||
# drop all the associated temp tables...,
|
||||
eval {
|
||||
my $tb = $DB->table( $self->{set_name} );
|
||||
my $sth = $tb->select( [ 'SessTable' ] );
|
||||
while ( my $aref = $sth->fetchrow_arrayref() ) {
|
||||
my $table_name = $aref->[0];
|
||||
eval {
|
||||
my $e = $DB->editor( $table_name );
|
||||
$e->drop_table("remove") or die "Can't drop table";
|
||||
};
|
||||
$@ and $err = undef;
|
||||
|
||||
}
|
||||
|
||||
# now drop the master control table
|
||||
my $e = $DB->editor( $self->{set_name});
|
||||
$e->drop_table("remove") or die "Can't drop table";
|
||||
};
|
||||
|
||||
return $@ ? undef : 1;
|
||||
}
|
||||
|
||||
sub new_set {
|
||||
#-------------------------------------------------------------------------------
|
||||
# creates a new temp table
|
||||
#
|
||||
my $self = shift;
|
||||
my $create_session = ( ref $_[0] eq 'CODE' ? shift : $self->{create_session} ) or return $self->error( 'NOCS', 'WARN' );
|
||||
|
||||
my $sid = $self->{id} or return $self->error( 'NOSID', 'WARN' );
|
||||
my $DB = $self->_db();
|
||||
my $Session = $DB->table( $self->{set_name} );
|
||||
|
||||
# create a new sesson
|
||||
my $table_name = generate_session_id();
|
||||
my $newid = $Session->add({ SessTable => $table_name, SessID => $sid }) or return;
|
||||
|
||||
# create the new table, extra parameters are passed into the create_session sub procedure
|
||||
if ( my $result = &{$create_session}( $DB, $table_name, $newid, @_ ) ) {
|
||||
my $tbl = $DB->table( $table_name );
|
||||
return wantarray ? ( $tbl, $newid ) : $tbl;
|
||||
}
|
||||
else {
|
||||
$Session->delete($newid);
|
||||
return;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub get_set {
|
||||
#-------------------------------------------------------------------------------
|
||||
# returns a table reference to the sethandle
|
||||
#
|
||||
my $self = shift;
|
||||
my $set_id = shift or return;
|
||||
my $sid = $self->{id} or return $self->error( 'NOSID', 'WARN' );
|
||||
|
||||
my $DB = $self->_db();
|
||||
my $Session = $DB->table( $self->{set_name} ) or return;
|
||||
my $sth = $Session->select({ ID => $set_id, SessID => $sid }) or return undef;
|
||||
my $href = $sth->fetchrow_hashref() or return undef;
|
||||
$href->{Timestmp} = \'NOW()';
|
||||
$Session->update( $href );
|
||||
|
||||
if ( my $table_name = $href->{'SessTable'} ) {
|
||||
my $tbl = $DB->table( $table_name );
|
||||
return $tbl;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub list_sets {
|
||||
#-------------------------------------------------------------------------------
|
||||
# returns a hashref of ID => tablenames, of tables that the current session ID owns
|
||||
#
|
||||
my $self = shift;
|
||||
my $DB = $self->_db();
|
||||
|
||||
my $sid = $self->{id} or return $self->error( 'NOSID', 'WARN' );
|
||||
my $Session = $DB->table( $self->{set_name} ) or return;
|
||||
|
||||
my $sth = $Session->select({ SessID => $sid }, [ 'ID', 'SessTable' ]);
|
||||
my $list = {};
|
||||
while ( my $aref = $sth->fetchrow_arrayref() ) {
|
||||
my ( $id, $sesstable ) = @{$aref};
|
||||
$list->{$id} = $sesstable;
|
||||
}
|
||||
|
||||
return $list;
|
||||
}
|
||||
|
||||
sub delete {
|
||||
#-------------------------------------------------------------------------------
|
||||
# deletes all sets associated with the session
|
||||
#
|
||||
my $self = shift;
|
||||
my $DB = $self->_db();
|
||||
|
||||
my $Session = $DB->table( $self->{set_name} ) or return;
|
||||
my $sid = ( shift || $self->{id} ) or return $self->error( 'NOSID', 'WARN' );
|
||||
my $sth = $Session->select({ SessID => $sid },['SessTable']);
|
||||
|
||||
# delete all created temp tables
|
||||
while ( my $aref = $sth->fetchrow_arrayref() ) {
|
||||
my $tbl_name = $aref->[0];
|
||||
eval {
|
||||
my $e = $DB->editor($tbl_name);
|
||||
$e->drop_table( "remove" );
|
||||
}
|
||||
}
|
||||
|
||||
$Session->delete({ SessID => $sid });
|
||||
|
||||
# cheap workaround
|
||||
shift or $self->GT::Session::SQL::delete();
|
||||
}
|
||||
|
||||
sub delete_set {
|
||||
#-------------------------------------------------------------------------------
|
||||
# deletes a single set
|
||||
#
|
||||
my $self = shift;
|
||||
my $set_id = shift;
|
||||
|
||||
my $DB = $self->_db();
|
||||
my $Session = $DB->table( $self->{set_name} ) or return;
|
||||
my $sid = $self->{id} or return $self->error( 'NOSID', 'WARN' );
|
||||
my $sth = $Session->select( { ID => $set_id, SessID => $sid }, [ 'SessTable' ] ) or return;
|
||||
my $aref = $sth->fetchrow_arrayref() or return;
|
||||
|
||||
if ($aref->[0]) {
|
||||
my $e = $DB->editor($aref->[0]);
|
||||
$e->drop_table();
|
||||
$Session->delete( { ID => $set_id } );
|
||||
}
|
||||
}
|
||||
|
||||
sub cleanup {
|
||||
#-------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $seconds = shift || $self->{seconds};
|
||||
|
||||
if ($seconds == 0) {
|
||||
$self->debug ("Cleanup not erasing anything, seconds set to 0.") if ($self->{_debug});
|
||||
return;
|
||||
}
|
||||
|
||||
my $DB = $self->_db() or return;
|
||||
my $tb = $DB->table( $self->{set_name} );
|
||||
|
||||
defined $seconds or ($seconds = 3600);
|
||||
my $new_sec = time - $seconds;
|
||||
my @time = localtime ($new_sec);
|
||||
|
||||
my $date_str = sprintf ("%4d-%02d-%02d %02d:%02d:%02d",
|
||||
$time[5] + 1900, $time[4] + 1, $time[3], $time[2], $time[1], $time[0]);
|
||||
|
||||
my $sth = $tb->select( GT::SQL::Condition->new('Timestmp', '<', $date_str), [ 'SessID' ] ) or return $self->error ($GT::SQL::error);
|
||||
while ( my $aref = $sth->fetchrow_arrayref() ) {
|
||||
$self->delete( $aref->[0], 1 );
|
||||
}
|
||||
$tb->delete (GT::SQL::Condition->new ('Timestmp', '<', $date_str)) or return $self->error ($GT::SQL::error);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _db {
|
||||
#-------------------------------------------------------------------------------
|
||||
# returns a database handle
|
||||
#
|
||||
my $self = shift;
|
||||
if ( my $db = $self->{'db'} ) {
|
||||
return $db;
|
||||
}
|
||||
|
||||
elsif ( my $def_path = $self->{'def_path'} ) {
|
||||
$db = GT::SQL->new( $def_path );
|
||||
return $db;
|
||||
}
|
||||
|
||||
else {
|
||||
$self->error( 'NODB', 'FATAL' );
|
||||
}
|
||||
}
|
||||
|
||||
sub generate_session_id {
|
||||
# ---------------------------------------------------------------
|
||||
# Generates a session id.
|
||||
#
|
||||
return md5_hex( time . $$ . rand (16000) );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Session::TempTable - A session management module, subclassing GT::Session::SQL providing temp table support
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Create a session:
|
||||
my $session = new GT::Session::TempTable({
|
||||
db => GT::SQL->new( '/path/to/defs' ),
|
||||
def_path => '/path/to/defs',
|
||||
create_session => \&create_table_sub
|
||||
});
|
||||
|
||||
Create temp table controller table. (do once before using this module)
|
||||
$session->initial_create();
|
||||
|
||||
Create a new temp table:
|
||||
my ( $GT_SQL_Table_ref, $tmp_id ) = $session->new_set();
|
||||
|
||||
Get the GT::SQL::Table ref to a previous table:
|
||||
my $GT_SQL_Table_ref = $session->get_set( $tmp_id );
|
||||
|
||||
List all the sets for current session:
|
||||
my $href = $session->list_sets();
|
||||
|
||||
Save data with the session:
|
||||
$session->data ("Save this information!");
|
||||
|
||||
Load a session.
|
||||
my $session = new GT::Session::TempTable ( $id ) or die "Can't load session: '$id'."
|
||||
|
||||
Delete a session:
|
||||
$session->delete();
|
||||
|
||||
Delete a table set:
|
||||
$session->delete_set( $tmp_id );
|
||||
|
||||
Cleanup old sessions, takes argument of number of seconds old.
|
||||
$session->cleanup ( 5000 );
|
||||
|
||||
=cut
|
||||
|
||||
800
site/glist/lib/GT/Socket.pm
Normal file
800
site/glist/lib/GT/Socket.pm
Normal file
@@ -0,0 +1,800 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Socket
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: Socket.pm,v 1.43 2004/08/23 20:07:44 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Handles stuff related to INET connections
|
||||
#
|
||||
|
||||
package GT::Socket;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use GT::Base;
|
||||
use vars qw/$ATTRIBS $VERSION $ERRORS @ISA $ERRORS $DEBUG $SHUTDOWN/;
|
||||
use Symbol;
|
||||
use Socket;
|
||||
use Config;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.43 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERRORS = {
|
||||
NO_HOST => 'No host specified',
|
||||
NO_PORT => 'No port specified',
|
||||
UNRESOLV => 'IP of Host: %s is unresolveable. System Error: (%s)',
|
||||
SOCKET => 'Socket error: %s',
|
||||
SOCKOPTS => 'Error setting socket options: %s',
|
||||
BIND => 'Bind error onto port(%i): %s',
|
||||
LISTEN => 'Listen call file: ',
|
||||
UNKNOWN_HOST => 'Host: %s is unknown',
|
||||
UNKNOWN_PORT => 'Port: %s is unknown',
|
||||
TIMEOUT => 'Host %s connect timed out',
|
||||
CONNECT => 'Cant connect to host: %s (%s)',
|
||||
MAX_DOWN => 'Maximum number of bytes (%i) received',
|
||||
MAX_UP => 'Maximum number of bytes (%i) sent'
|
||||
};
|
||||
|
||||
$ATTRIBS = {
|
||||
host => undef,
|
||||
port => 23,
|
||||
sock => undef,
|
||||
max_down => 0,
|
||||
max_up => 0,
|
||||
received => 0,
|
||||
sent => 0,
|
||||
server => 0,
|
||||
timeout => 40
|
||||
};
|
||||
|
||||
sub DESTROY {
|
||||
#-------------------------------------------------------------------------------
|
||||
# Make sure we close the connection.
|
||||
#
|
||||
$_[0]->close if $_[0]->{sock};
|
||||
}
|
||||
|
||||
sub init {
|
||||
#-------------------------------------------------------------------------------
|
||||
# Called on new() from GT::Base.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
$self->close() if $self->{sock}; # If there is an existing socket, close it
|
||||
$self->_set_options(@_) if @_;
|
||||
|
||||
# If host and port were provided, open the new socket
|
||||
$self->_open() if $self->{host} and $self->{port} and not $self->{sock};
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub open {
|
||||
#-------------------------------------------------------------------------------
|
||||
# Open a new connection to the host. Returns undef if the connection failed, or
|
||||
# the GT::Socket object if the connection was established.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Create a new GT::Socket object if called as a class method
|
||||
$self = UNIVERSAL::isa($self, __PACKAGE__) ? $self->new() : __PACKAGE__->new()
|
||||
unless ref $self and UNIVERSAL::isa($self, __PACKAGE__);
|
||||
|
||||
$self->close() if $self->{sock}; # if there is an existing socket, close it
|
||||
$self->_set_options(@_) if @_;
|
||||
|
||||
$self->_open() or return; # open the new socket
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub server {
|
||||
#-------------------------------------------------------------------------------
|
||||
# Create a server socket.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Create a new GT::Socket object if called as a class method
|
||||
$self = UNIVERSAL::isa($self, __PACKAGE__) ? $self->new() : __PACKAGE__->new()
|
||||
unless ref $self and UNIVERSAL::isa($self, __PACKAGE__);
|
||||
|
||||
$self->close() if $self->{sock}; # If there is an existing socket, close it
|
||||
$self->{server} = 1;
|
||||
|
||||
$self->_set_options(@_) if @_;
|
||||
|
||||
$self->_server() or return; # open the new socket
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub close {
|
||||
#-------------------------------------------------------------------------------
|
||||
# closes the socket if it is open
|
||||
#
|
||||
close $_[0]->{sock} if $_[0]->{sock};
|
||||
}
|
||||
|
||||
sub _open {
|
||||
#-------------------------------------------------------------------------------
|
||||
# this does the real opening of the socket
|
||||
#
|
||||
# IN: host to connect to, and port to connect to (names such as "ftp" allowed)
|
||||
#
|
||||
my $self = shift;
|
||||
my $host = $self->{host} or return $self->error(NO_HOST => 'WARN');
|
||||
my $port = $self->{port} or return $self->error(NO_PORT => 'WARN');
|
||||
|
||||
if ($port =~ /\D/) { # Port is a name, such as "ftp". Get the port number.
|
||||
$port = getservbyname($port, 'tcp');
|
||||
}
|
||||
int $port or return $self->error(NO_PORT => 'WARN');
|
||||
|
||||
# get the packed ip address
|
||||
my $iaddr = inet_aton($host) or return $self->error(UNRESOLV => 'WARN', $host, "$!");
|
||||
my $paddr = sockaddr_in($port, $iaddr);
|
||||
|
||||
# connect with timeout
|
||||
my $fh = gensym();
|
||||
my $proto = getprotobyname('tcp');
|
||||
socket($fh, PF_INET, SOCK_STREAM, $proto) or return $self->error(SOCKET => 'WARN', "$!");
|
||||
|
||||
if ($Config{d_alarm} and $self->{timeout}) {
|
||||
{
|
||||
local $SIG{__DIE__};
|
||||
eval {
|
||||
local $SIG{ALRM} = sub { undef $fh };
|
||||
alarm($self->{timeout});
|
||||
connect($fh, $paddr) or die 'CONNECT';
|
||||
};
|
||||
}
|
||||
alarm(0);
|
||||
if (not defined $fh) {
|
||||
return $self->error(TIMEOUT => 'WARN', $host, "$!");
|
||||
}
|
||||
elsif ($@) {
|
||||
return $self->error(CONNECT => 'WARN', $host, "$!");
|
||||
}
|
||||
}
|
||||
else {
|
||||
connect($fh, $paddr) or return $self->error(CONNECT => 'WARN', $host, $!);
|
||||
}
|
||||
|
||||
$self->{sock} = $fh;
|
||||
$self->autoflush();
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub _server {
|
||||
#-------------------------------------------------------------------------------
|
||||
# creates the required server ports
|
||||
#
|
||||
my $self = shift;
|
||||
my $port = $self->{port} or return $self->error(NO_PORT => 'WARN');
|
||||
my $host = inet_aton($self->{host}) || INADDR_ANY;
|
||||
|
||||
my $fh = gensym();
|
||||
my $proto = getprotobyname('tcp');
|
||||
|
||||
socket($fh, PF_INET, SOCK_STREAM, $proto) or return $self->error(SOCKET => 'WARN', "$!");
|
||||
setsockopt($fh, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or return $self->error(SOCKOPTS => 'WARM', "$!");
|
||||
bind($fh, sockaddr_in($port, $host)) or return $self->error(BIND => 'WARN', $port, "$!");
|
||||
listen($fh, SOMAXCONN) or return $self->error(LISTEN => 'WARN', "$!");
|
||||
|
||||
# get a ref to the connect
|
||||
$self->{sock} = $fh;
|
||||
|
||||
$self->autoflush();
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub accept {
|
||||
#-------------------------------------------------------------------------------
|
||||
# accepts a server's tcpip connection from a client
|
||||
#
|
||||
my $self = shift;
|
||||
my $sock = $self->{sock};
|
||||
|
||||
if ($self->pending() and $self->{server}) {
|
||||
my $ch = gensym();
|
||||
accept($ch, $sock);
|
||||
|
||||
my $client = new GT::Socket(
|
||||
max_down => $self->{max_down} || undef,
|
||||
max_up => $self->{max_up} || undef,
|
||||
server => $self->{server},
|
||||
timeout => $self->{timeout},
|
||||
port => $self->{port},
|
||||
host => $self->{host},
|
||||
sock => $ch
|
||||
);
|
||||
|
||||
return $client;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub autoflush {
|
||||
#-------------------------------------------------------------------------------
|
||||
# turns on auto flushing of socket handles.
|
||||
#
|
||||
my $self = shift;
|
||||
my $status = defined($_[0]) ? $_[0] : 1;
|
||||
my $sock = $self->{sock};
|
||||
|
||||
select((select($sock), $| = $status)[0]) if $sock;
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub vec {
|
||||
#-------------------------------------------------------------------------------
|
||||
# IN: clean or partially preped $bits for select
|
||||
# OUT: the $bits
|
||||
#
|
||||
my ($self, $bits) = @_;
|
||||
$bits ||= '';
|
||||
|
||||
# setup the filehandle vecs
|
||||
my $sock = $self->{sock} or return $bits;
|
||||
CORE::vec($bits, fileno($sock), 1) = 1;
|
||||
|
||||
return $bits;
|
||||
}
|
||||
|
||||
sub pending {
|
||||
#-------------------------------------------------------------------------------
|
||||
# returns non-zero if data is pending
|
||||
# IN: <0 : value for blocking
|
||||
# non zero : wait for N seconds
|
||||
# 0 : don't wait (nonblocking)
|
||||
# OUT: non-zero if data is pending
|
||||
#
|
||||
my $self = shift;
|
||||
my $tics = defined $_[0] ? ($_[0] < 0 ? undef : shift) : 0;
|
||||
|
||||
# if the sock has closed we have no data pending
|
||||
return 0 if $self->{closed};
|
||||
|
||||
my $bits = $self->vec() or return;
|
||||
|
||||
# find out the number of bytes to read
|
||||
return select($bits, undef, undef, $tics);
|
||||
}
|
||||
|
||||
sub EOF {
|
||||
#-------------------------------------------------------------------------------
|
||||
# returns number of bytes to be read if there is input pending
|
||||
# IN: nothing
|
||||
# OUT: number of bytes
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# if the sock has closed we have no data pending
|
||||
return 1 if $self->{closed};
|
||||
|
||||
# setup the filehandle vecs
|
||||
my $sock = $self->{sock} or return;
|
||||
CORE::vec(my $bits = '', fileno($sock), 1) = 1;
|
||||
|
||||
# find out if the socket is closed
|
||||
return select(undef, undef, my $ebits = $bits, 0);
|
||||
}
|
||||
|
||||
sub read {
|
||||
#-------------------------------------------------------------------------------
|
||||
# reads a certain number of bytes from the socket
|
||||
#
|
||||
my $self = shift;
|
||||
my $bytes = int(shift) or return;
|
||||
my $max = $self->{max_down} || 0;
|
||||
my $buf;
|
||||
|
||||
# find out how many bytes to read
|
||||
if ($max) {
|
||||
my $received = $self->{received};
|
||||
|
||||
if ($received == $max) {
|
||||
return $self->error('MAX_DOWN', 'WARN', $self->{received});
|
||||
}
|
||||
|
||||
# Lower the number of bytes requested if that would push us over the max byte limit
|
||||
elsif (($max - $received) < $bytes) {
|
||||
if (($bytes = $max - $received) < 0) {
|
||||
return $self->error('MAX_DOWN', 'WARN', $self->{received});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Attempt to read the requested amount of data.
|
||||
# If sysread returns 0, it means that there is no more data to be read
|
||||
my $b_read = sysread($self->{'sock'}, $buf, $bytes);
|
||||
unless ($b_read) {
|
||||
$self->{closed} = 1;
|
||||
return $buf;
|
||||
}
|
||||
|
||||
# Finish up the read
|
||||
if ((($self->{received} += $b_read) >= $max) and $max) {
|
||||
$self->{closed} = 1;
|
||||
$self->close();
|
||||
}
|
||||
|
||||
return $buf;
|
||||
}
|
||||
|
||||
sub gulpread {
|
||||
#-------------------------------------------------------------------------------
|
||||
# reads a certain number of bytes from the socket
|
||||
#
|
||||
my $self = shift;
|
||||
my $tics = shift || 0;
|
||||
my $max_tics = time + $tics;
|
||||
my $max = $self->{max_down};
|
||||
my $sock = $self->{sock};
|
||||
my $buf;
|
||||
|
||||
# if there's data pending
|
||||
while ($tics
|
||||
? ($max_tics >= time and not $self->EOF() and $self->pending($max_tics - time))
|
||||
: ($self->pending() and not $self->EOF())
|
||||
) {
|
||||
my $bytes = 4096;
|
||||
|
||||
# Find out how many bytes to read
|
||||
if ($max) {
|
||||
my $received = $self->{received};
|
||||
|
||||
if ($received == $max) {
|
||||
$self->error('MAX_DOWN', 'WARN', $self->{received});
|
||||
return $buf;
|
||||
}
|
||||
elsif (($max - $received) < $bytes) {
|
||||
if (($bytes = $max - $received) < 0) {
|
||||
$self->error('MAX_DOWN', 'WARN', $self->{received});
|
||||
return $buf;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Attempt to read the requested amount of data.
|
||||
# If sysread returns 0, it means that there is no more data to be read
|
||||
my $tmp;
|
||||
my $b_read = sysread($sock, $tmp, $bytes);
|
||||
unless ($b_read) {
|
||||
$self->{closed} = 1;
|
||||
return $buf . $tmp;
|
||||
}
|
||||
|
||||
# Finish up the read
|
||||
if ((($self->{received} += $b_read ) >= $max ) and $max) {
|
||||
$self->{closed} = 1;
|
||||
$self->close();
|
||||
}
|
||||
|
||||
$buf .= $tmp;
|
||||
return $buf;
|
||||
}
|
||||
|
||||
return $buf;
|
||||
}
|
||||
|
||||
sub write {
|
||||
#-------------------------------------------------------------------------------
|
||||
# writes a certain number of bytes to the socket
|
||||
#
|
||||
my $self = shift;
|
||||
my $buf = shift;
|
||||
my $bytes = length( $buf );
|
||||
my $max = $self->{max_up};
|
||||
|
||||
# if we're using limit caps on the number of bytes that the service can send out
|
||||
# tweak the buf to make sure we can!
|
||||
if ($max) {
|
||||
# the current buffer would throw us over the top, fix it
|
||||
if ((my $len = $max - $self->{'sent'}) < $bytes) {
|
||||
|
||||
# check the vector
|
||||
if (($bytes = $len) > 0) {
|
||||
$buf = substr($buf, 0, $len);
|
||||
}
|
||||
else {
|
||||
return $buf = undef;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# now with all the tweaked values, send off the information
|
||||
my $sock = $self->{sock};
|
||||
my $b_sent = syswrite($sock, $buf, length $buf);
|
||||
|
||||
$self->{sent} = $b_sent;
|
||||
}
|
||||
|
||||
sub fh {
|
||||
#-------------------------------------------------------------------------------
|
||||
# returns the file handle associated
|
||||
my $self = shift;
|
||||
return $self->{sock};
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# PRIVATE PARTS
|
||||
################################################################################
|
||||
|
||||
sub _set_options {
|
||||
#-------------------------------------------------------------------------------
|
||||
# cleverly tries to set the options for connection
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# called with { host => HOST, port => PORT }
|
||||
if (ref $_[0]) {
|
||||
$self->set($_[0]);
|
||||
}
|
||||
|
||||
# called with HOST,PORT
|
||||
elsif (@_ == 2) {
|
||||
$self->set({
|
||||
host => $_[0],
|
||||
port => $_[1]
|
||||
});
|
||||
}
|
||||
|
||||
# called with ( host => HOST, port => PORT )
|
||||
elsif (!(@_ % 2)) {
|
||||
$self->set(@_);
|
||||
}
|
||||
|
||||
# called with "HOST:PORT" or just "PORT"
|
||||
elsif (@_ == 1) {
|
||||
if ($_[0] =~ /(.*)\:(.*)/) {
|
||||
$self->set({
|
||||
host => $1,
|
||||
port => $2
|
||||
});
|
||||
}
|
||||
else {
|
||||
$self->set( {
|
||||
host => 'localhost',
|
||||
port => int($_[0])
|
||||
});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Socket - A simple internet socket handling interface
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Socket;
|
||||
|
||||
my $sock = GT::Socket->open({
|
||||
host => 'www.gossamer-threads.com',
|
||||
port => 80
|
||||
});
|
||||
|
||||
$sock->write("GET / HTTP/1.0\n\n");
|
||||
|
||||
print "REQUEST RETURNED:\n\n", $sock->gulpread(-1);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Socket provides a simple interface for tcp client/server socket services.
|
||||
|
||||
=head2 Method List
|
||||
|
||||
Object Creation
|
||||
|
||||
open() Creates a new client socket
|
||||
server() Creates a new server socket
|
||||
|
||||
Reading and Writing
|
||||
|
||||
write() Sends all or up to max_up bytes of data to remote
|
||||
read() Receives an amount or max_down bytes of data from remote
|
||||
gulpread() Gets all or up to max_down bytes of data from remote
|
||||
|
||||
Socket Administration
|
||||
|
||||
close() Closes the socket
|
||||
EOF() Returns open/closed status of socket
|
||||
autoflush() Sets the socket so that no data is buffered
|
||||
vec() Sets bits in a bitmask for select calls
|
||||
pending() Returns true if data/clients awaiting
|
||||
fh() Returns the raw socket handle
|
||||
|
||||
Server Handling
|
||||
|
||||
accept() Accepts a incoming client request
|
||||
|
||||
=head2 Creating a new Client Socket
|
||||
|
||||
To instantiate a new Client Socket connection, the open() method must be
|
||||
called.
|
||||
|
||||
my $sock = GT::Socket->open({
|
||||
host => 'hostname', # hostname/ip to connect to
|
||||
port => 1234, # port to connect to
|
||||
max_down => 0, # maximum number of bytes to download (optional)
|
||||
max_up => 0, # maximum number of bytes to upload (optional)
|
||||
timeout => 10 # maximum time to wait for host connect (optional)
|
||||
});
|
||||
|
||||
The parameters are somewhat flexible, to connect to www.gossamer-threads.com on
|
||||
port 80, any of the following calling methods can be used.
|
||||
|
||||
my $sock = GT::Socket->open({
|
||||
host => 'www.gossamer-threads.com',
|
||||
port => 80
|
||||
});
|
||||
|
||||
my $sock = GT::Socket->open(
|
||||
host => 'www.gossamer-threads.com',
|
||||
port => 80
|
||||
);
|
||||
|
||||
my $sock = GT::Socket->open('www.gossamer-threads.com', 80);
|
||||
|
||||
my $sock = GT::Socket->open('www.gossamer-threads.com:80');
|
||||
|
||||
Note that as port 80 is the HTTP port, and port gets tested and handled with
|
||||
the getservbyname function, the following can be done:
|
||||
|
||||
# 'http' here but can be 'pop3', 'telnet', etc. depending on service wanted
|
||||
my $sock = GT::Socket->open('www.gossamer-threads.com', 'http');
|
||||
|
||||
Note that if the value passed to open() is a hash ref, with a host and port, a
|
||||
handful of other options may be set.
|
||||
|
||||
=head2 Limiting maximum amount of data downloaded
|
||||
|
||||
This affects the $sock->read() and the $sock->gulpread() methods.
|
||||
|
||||
The option 'max_down' can be used to put a cap on the number of bytes recieved
|
||||
through the socket.
|
||||
|
||||
For example to limit the number of bytes downloaded to 2k, set max_down to 2048
|
||||
|
||||
my $sock = GT::Socket->open(
|
||||
host => 'www.gossamer-threads.com',
|
||||
port => 80,
|
||||
max_down => 2048
|
||||
);
|
||||
|
||||
WARNING, once the download maximum has been reached, the socket is closed. Then
|
||||
no more information can be uploaded to the remote host.
|
||||
|
||||
=head2 Limiting maximum amount of data uploaded
|
||||
|
||||
The option 'max_up' is used to limit the number of bytes that can be sent to
|
||||
the remote host.
|
||||
|
||||
After the maximum number of bytes is hit, the object will no longer carry out
|
||||
$sock->write() requests.
|
||||
|
||||
This does not affect the number of bytes that can be downloaded. Until max_down
|
||||
is hit or the remote host finishes the transmission, the socket will keep
|
||||
listening.
|
||||
|
||||
In the following example. The maximum number of bytes for both download and
|
||||
upload have been set to 2K.
|
||||
|
||||
Keep in mind, with this example, if the maximum download limit is reached
|
||||
before the maximum upload, the socket will be closed so the remote server will
|
||||
stop responding to $sock->write() as well!
|
||||
|
||||
my $sock = GT::Socket->open(
|
||||
host => 'www.gossamer-threads.com',
|
||||
port => 80,
|
||||
max_down => 2048,
|
||||
max_up => 2048
|
||||
);
|
||||
|
||||
=head2 Limiting time taken to connect to a host
|
||||
|
||||
When the module tries to connect to a host, if the host is not running or
|
||||
simply not present, it may take over 30 seconds for the connect call to give
|
||||
up.
|
||||
|
||||
The 'timout' option allows the forcing the waiting period to be a certain
|
||||
number of seconds. By default, the value is set to 10 seconds.
|
||||
|
||||
Since this uses alarm, it will not function on Win32 machines.
|
||||
|
||||
With the following example, the module will spend a maximum of 3 seconds trying
|
||||
to connect to www.gossamer-threads.com.
|
||||
|
||||
my $sock = GT::Socket->open(
|
||||
host => 'www.gossamer-threads.com',
|
||||
port => 80,
|
||||
timeout => 3
|
||||
);
|
||||
|
||||
|
||||
=head2 Methods
|
||||
|
||||
The following methods are available to the Client object
|
||||
|
||||
=head2 autoflush ( flag BOOLEAN )
|
||||
|
||||
$sock->autoflush(1) # turn on flushing
|
||||
$sock->autoflush(0) # turn off flushing
|
||||
|
||||
Turns off buffering for the socket. By default, the socket is
|
||||
autoflushed/buffering turned off.
|
||||
|
||||
This prevents peculiar errors like stalling when trying to communicate with
|
||||
http servers.
|
||||
|
||||
=head2 close
|
||||
|
||||
Closes the socket if open.
|
||||
|
||||
=head2 EOF
|
||||
|
||||
Returns true of the socket is closed.
|
||||
|
||||
=head2 fh
|
||||
|
||||
Returns the filehandle.
|
||||
|
||||
The return value is file glob, because of this, the upload/download limits
|
||||
cannot be enforced and the accounting can fall to bits of both the object and
|
||||
the file glob are being used simultaneously.
|
||||
|
||||
=head2 gulpread ( tics INTEGER )
|
||||
|
||||
Attempts to read all the data it can into a buffer and return. If max_down is
|
||||
non zero, it will read till the remote closes or the limit has been reached and
|
||||
returns.
|
||||
|
||||
Tics is a non-zero value that will determine how long the function will run for
|
||||
or wait:
|
||||
|
||||
$tics Action
|
||||
----------------------------------------
|
||||
>0 Wait $tics seconds till returning with results
|
||||
0 Don't wait, simply get what's there and return
|
||||
<0 Block, wait until all the data (up to max_down) has been received
|
||||
|
||||
=head2 pending ( tics INTEGER )
|
||||
|
||||
Returns true if socket has data pending to be received. Usually this would be
|
||||
followed with a call to $sock->gulpread() or $sock->read()
|
||||
|
||||
$tics Action
|
||||
----------------------------------------
|
||||
>0 Wait $tics seconds till returning with results
|
||||
0 Don't wait, simply get what's there and return
|
||||
<0 Block, wait until all the data (up to max_down) has been received
|
||||
|
||||
=head2 read ( number_bytes INTEGER )
|
||||
|
||||
Reads a max of number_bytes from the socket or up to max_down and returns the
|
||||
result. This is nonblocking so it is possible to get no data or less than the
|
||||
requested amount.
|
||||
|
||||
=head2 vec ( [ bits SCALAR ] )
|
||||
|
||||
Sets the bits appropriate for the object's socket handle. The returned value
|
||||
can be used in select(RBITS,WBITS,EBITS,TIMEOUT) function calls.
|
||||
|
||||
To test a series of socket handles, vec accepts an already set bit list from
|
||||
another vec call.
|
||||
|
||||
$bits = $sock1->vec();
|
||||
$bits = $sock2->vec($bits);
|
||||
$bits = $sock3->vec($bits);
|
||||
|
||||
And $bits can now be used to test on all three handles.
|
||||
|
||||
=head2 write ( buffer SCALAR )
|
||||
|
||||
Takes the buffer and send it into the socket or up to the max_up limit.
|
||||
|
||||
Returns the number of bytes sent.
|
||||
|
||||
=head2 Creating a new Server Socket
|
||||
|
||||
Creating a server socket is almost identical to creating a client socket except
|
||||
no hostname is specified.
|
||||
|
||||
my $server = GT::Socket->server({
|
||||
port => 1234, # port to host services
|
||||
max_down => 0, # maximum number of bytes to download (optional)
|
||||
max_up => 0, # maximum number of bytes to upload (optional)
|
||||
timeout => 10 # maximum time to wait for host connect (optional)
|
||||
});
|
||||
|
||||
The only option that affects the server directly is the port. The optional
|
||||
values, max_down, max_up, and timeout are passed on to the child socket when
|
||||
the server accepts a new connection.
|
||||
|
||||
=head2 Methods
|
||||
|
||||
The following methods are available to the Client object
|
||||
|
||||
=head2 accept
|
||||
|
||||
Accepts an incoming connection and returns a GT::Socket client object for
|
||||
further interations with the client.
|
||||
|
||||
=head2 fh
|
||||
|
||||
Returns the filehandle.
|
||||
|
||||
=head2 pending ( tics INTEGER )
|
||||
|
||||
Returns true if server has awaiting connections. Usually this would be followed
|
||||
with a call to $server->accept();
|
||||
|
||||
$tics Action
|
||||
----------------------------------------
|
||||
>0 Wait $tics seconds till returning with results
|
||||
0 Don't wait, simply get what's there and return
|
||||
<0 Block, wait until all the data (up to max_down) has been received
|
||||
|
||||
=head2 vec ( [ bits SCALAR ] )
|
||||
|
||||
Sets the bits appropriate for the object's socket handle. The returned value
|
||||
can be used in select(RBITS,WBITS,EBITS,TIMEOUT) function calls.
|
||||
|
||||
To test a series of socket handles, vec accepts an already set bit list from
|
||||
another vec call.
|
||||
|
||||
$bits = $sock1->vec();
|
||||
$bits = $sock2->vec($bits);
|
||||
$bits = $sock3->vec($bits);
|
||||
|
||||
And $bits can now be used to test on all three handles.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
=head2 Server
|
||||
|
||||
use GT::Socket;
|
||||
|
||||
my $server = GT::Socket->server({
|
||||
port => 7890
|
||||
});
|
||||
|
||||
while (1) {
|
||||
if ($server->pending(-1)) {
|
||||
print "Accepting a connection\n";
|
||||
my $sock = $server->accept();
|
||||
$sock->write("The time is: " . localtime() . "\n");
|
||||
}
|
||||
}
|
||||
|
||||
=head2 Client for Server
|
||||
|
||||
use GT::Socket;
|
||||
|
||||
my $client = GT::Socket->open("localhost:7890");
|
||||
print "Server Said: ", $client->gulpread(-1);
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Socket.pm,v 1.43 2004/08/23 20:07:44 jagerman Exp $
|
||||
|
||||
=cut
|
||||
749
site/glist/lib/GT/Socket/Client.pm
Normal file
749
site/glist/lib/GT/Socket/Client.pm
Normal file
@@ -0,0 +1,749 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Socket::Client
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Client.pm,v 1.15 2004/02/17 01:33:07 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Client socket module that handles TCP client functionality, including
|
||||
# SSL capabilities (via GT::Socket::Client::SSLHandle and Net::SSLeay).
|
||||
#
|
||||
|
||||
# Perl 5.004 doesn't like: $$$self{foo} mixed with a tied filehandle (as used
|
||||
# by the SSL capabilities) - it confuses Perl into thinking we have a tied
|
||||
# scalar. Unfortunately, this means the rather more ugly ${*$self}{foo} syntax
|
||||
# has to be used instead.
|
||||
|
||||
package GT::Socket::Client;
|
||||
use strict;
|
||||
use vars qw/$ERROR @ISA $MAX_READALL @EXPORT_OK %EXPORT_TAGS $CR $LF $CRLF $VERSION/;
|
||||
use Carp;
|
||||
use Net::servent;
|
||||
use Socket;
|
||||
use POSIX qw/:fcntl_h EINTR EAGAIN EWOULDBLOCK BUFSIZ/;
|
||||
require Exporter;
|
||||
@ISA = 'Exporter';
|
||||
use constants
|
||||
CR => "\015",
|
||||
LF => "\012",
|
||||
CRLF => "\015\012",
|
||||
LINE_SAFETY => 100_000,
|
||||
READALL_MAX => 20 * 1024 * 1024; # Default 20 MB max, but you can pass something larger to readall()
|
||||
|
||||
$CR = CR; $LF = LF; $CRLF = CRLF;
|
||||
@EXPORT_OK = qw/CR LF CRLF $CR $LF $CRLF/;
|
||||
%EXPORT_TAGS = (
|
||||
crlf => [qw/CR LF CRLF $CR $LF $CRLF/]
|
||||
);
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
sub open {
|
||||
my $class = ref($_[0]) || $_[0]; shift;
|
||||
|
||||
my $self = \do { local *GLOB; *GLOB };
|
||||
|
||||
if (!@_ or @_ % 2) {
|
||||
croak('Invalid options: Usage: ' . __PACKAGE__ . '->new(HASH)');
|
||||
}
|
||||
my %opts = @_;
|
||||
|
||||
$opts{host} or croak 'No host entered';
|
||||
$opts{port} or croak 'No port entered';
|
||||
|
||||
if ($opts{port} =~ /\D/) { # Port is a name such as 'ftp' - get the port number
|
||||
my $serv = getservbyname($opts{port});
|
||||
if (!$serv) {
|
||||
$ERROR = "Invalid port entered: $opts{port}";
|
||||
carp $ERROR if $opts{debug};
|
||||
return undef;
|
||||
}
|
||||
$opts{port} = $serv->port;
|
||||
}
|
||||
|
||||
my $iaddr = inet_aton($opts{host});
|
||||
if (!$iaddr) {
|
||||
$ERROR = "Unresolvable host entered: $opts{host}";
|
||||
carp $ERROR if $opts{debug};
|
||||
return undef;
|
||||
}
|
||||
my $paddr = pack_sockaddr_in($opts{port}, $iaddr);
|
||||
|
||||
not $opts{timeout} or $opts{timeout} > 0 or croak "Invalid timeout specified";
|
||||
|
||||
my $use_alarm;
|
||||
if ($opts{timeout} and $^O ne 'MSWin32') { # Perl on Win32 doesn't support alarm
|
||||
require Config;
|
||||
$use_alarm = !!$Config::Config{d_alarm};
|
||||
}
|
||||
|
||||
unless (socket($self, PF_INET, SOCK_STREAM, scalar getprotobyname('tcp'))) {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if $opts{debug};
|
||||
return undef;
|
||||
}
|
||||
|
||||
my ($connected, $timeout);
|
||||
if ($use_alarm) { # This OS supports alarm
|
||||
local $SIG{__DIE__};
|
||||
local $SIG{ALRM} = sub { $timeout = 1; die "timeout\n" };
|
||||
|
||||
alarm($opts{timeout});
|
||||
|
||||
eval { $connected = connect($self, $paddr) };
|
||||
|
||||
alarm(0);
|
||||
}
|
||||
else {
|
||||
$connected = connect($self, $paddr);
|
||||
}
|
||||
unless ($connected) {
|
||||
if ($timeout) {
|
||||
$ERROR = "Unable to connect: Connection timed out";
|
||||
}
|
||||
else {
|
||||
$ERROR = "Unable to connect: $!";
|
||||
}
|
||||
carp $ERROR if $opts{debug};
|
||||
return undef;
|
||||
}
|
||||
|
||||
${*$self}{timeout} = $opts{timeout};
|
||||
|
||||
if ($opts{ssl}) {
|
||||
require GT::Socket::Client::SSLHandle;
|
||||
my $sock = $self;
|
||||
$self = \do { local *SSL; *SSL };
|
||||
tie *$self, "GT::Socket::Client::SSLHandle", \*$sock;
|
||||
%{*$self} = %{*$sock}; # Copy the hash options
|
||||
${*$self}{ssl} = 1; # Keep track of this being an SSL socket
|
||||
bless $self, $class;
|
||||
}
|
||||
else {
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
if (not exists $opts{autoflush} or $opts{autoflush}) {
|
||||
select((select($self), $|++)[0]);
|
||||
${*$self}{autoflush} = 1;
|
||||
}
|
||||
if ($opts{non_blocking}) {
|
||||
${*$self}{ssl} and croak "Unable to use non_blocking with ssl sockets";
|
||||
$self->_non_blocking;
|
||||
}
|
||||
|
||||
${*$self}{host} = $opts{host};
|
||||
${*$self}{iaddr} = $iaddr;
|
||||
${*$self}{port} = $opts{port};
|
||||
${*$self}{debug} = $opts{debug};
|
||||
${*$self}{eol} = LF; # Set the default EOL, for ->readline()
|
||||
|
||||
if (${*$self}{non_blocking}) {
|
||||
my %default = (read_wait => 5, select_time => 0.05, read_size => BUFSIZ);
|
||||
# These options do nothing on blocking GT::Socket::Client objects:
|
||||
for (qw/read_wait select_time read_size/) {
|
||||
if (exists $opts{$_}) {
|
||||
$self->$_($opts{$_});
|
||||
}
|
||||
else {
|
||||
${*$self}{$_} = $default{$_};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
sub _non_blocking {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
|
||||
if ($] >= 5.006) {
|
||||
# Using IO::Handle is much easier for 5.6.x and above; previous
|
||||
# versions need the two (Windows/non-Windows) code below.
|
||||
require IO::Handle;
|
||||
$self->IO::Handle::blocking(0);
|
||||
}
|
||||
else {
|
||||
if ($^O eq 'MSWin32') {
|
||||
# 126 is FIONBIO (some docs say 0x7F << 16)
|
||||
ioctl(
|
||||
$self,
|
||||
0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
|
||||
1
|
||||
) or die "ioctl: $^E";
|
||||
}
|
||||
else {
|
||||
my $flags = fcntl($self, F_GETFL, 0) or die "getfl: $!";
|
||||
$flags |= O_NONBLOCK;
|
||||
fcntl($self, F_SETFL, $flags) or die "setfl: $!";
|
||||
}
|
||||
}
|
||||
|
||||
${*$self}{non_blocking} = 1;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub eol {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
${*$self}{eol} = shift;
|
||||
defined ${*$self}{eol} and length ${*$self}{eol} or croak "No valid EOL character entered";
|
||||
return 1;
|
||||
}
|
||||
return ${*$self}{eol};
|
||||
}
|
||||
|
||||
sub readline {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
if (not ${*$self}{non_blocking} or ${*$self}{ssl}) {
|
||||
local $/ = ${*$self}{eol};
|
||||
$_[0] = <$self>;
|
||||
}
|
||||
else {
|
||||
$_[0] = '';
|
||||
require POSIX;
|
||||
local $!;
|
||||
vec(my $rin = '', fileno($self), 1) = 1;
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
my $safety;
|
||||
|
||||
my $select_time = ${*$self}{select_time};
|
||||
while () {
|
||||
if ($safety++ >= LINE_SAFETY) {
|
||||
$ERROR = 'Line reads exceeded safety line cutoff (' . LINE_SAFETY . ')';
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
my $nfound;
|
||||
my $rout = $rin;
|
||||
do {
|
||||
$! = 0;
|
||||
$nfound = select($rout, undef, undef, $select_time);
|
||||
} while $! == EINTR;
|
||||
if ($nfound > 0) {
|
||||
my $ret = sysread($self, my $buff, 1);
|
||||
unless ($ret) {
|
||||
next if $! == EAGAIN or $! == EWOULDBLOCK;
|
||||
|
||||
$ERROR = "Unable to read from socket: $!. Read: $_[0]";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
$_[0] .= $buff;
|
||||
last if length($_[0]) >= length(${*$self}{eol}) and
|
||||
rindex($_[0], ${*$self}{eol}) == (length($_[0]) - length(${*$self}{eol}))
|
||||
}
|
||||
elsif ($nfound < 0) {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub select_time {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $select_time = shift;
|
||||
unless ($select_time > 0) {
|
||||
croak 'Usage: $obj->select_time(SELECT_TIME)';
|
||||
}
|
||||
${*$self}{select_time} = $select_time;
|
||||
return 1;
|
||||
}
|
||||
|
||||
return ${*$self}{select_time};
|
||||
}
|
||||
|
||||
sub read_wait {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $read_wait = shift;
|
||||
unless ($read_wait eq '0' or $read_wait > 0) {
|
||||
croak 'Usage: $obj->read_wait(READ_WAIT)';
|
||||
}
|
||||
${*$self}{read_wait} = $read_wait;
|
||||
return 1;
|
||||
}
|
||||
|
||||
return ${*$self}{read_wait};
|
||||
}
|
||||
|
||||
sub read_size {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $read_size = shift;
|
||||
unless ($read_size >= 1) {
|
||||
croak 'Usage: $obj->read_size(READ_SIZE)';
|
||||
}
|
||||
${*$self}{read_size} = $read_size;
|
||||
return 1;
|
||||
}
|
||||
|
||||
return ${*$self}{read_size};
|
||||
}
|
||||
|
||||
# Reads all (allowing for a timeout of read_wait, if non-blocking) data from the socket
|
||||
sub readall {
|
||||
my $self = shift;
|
||||
$self->readblock($_[0], -1);
|
||||
}
|
||||
|
||||
sub readblock {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
$_[0] = '';
|
||||
my $read_wait = ${*$self}{read_wait};
|
||||
my $select_time = ${*$self}{select_time};
|
||||
|
||||
my $max_size = pop;
|
||||
unless (@_ == 1 and int($max_size) != 0) {
|
||||
croak 'Usage: $obj->readblock($scalar, BLOCK_SIZE)';
|
||||
}
|
||||
|
||||
unless (fileno $self) {
|
||||
$ERROR = "Socket closed";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
# Don't return undef - there could still be something waiting on the
|
||||
# socket.
|
||||
}
|
||||
|
||||
local $!;
|
||||
|
||||
if (not ${*$self}{non_blocking} or ${*$self}{ssl}) {
|
||||
if ($max_size > 0) {
|
||||
read($self, $_[0], $max_size);
|
||||
}
|
||||
else {
|
||||
local $/;
|
||||
$_[0] = <$self>;
|
||||
}
|
||||
if (not defined $_[0] and $!) {
|
||||
$ERROR = "Blocking block read failed: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef unless length($_[0]);
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $read_size = ${*$self}{read_size};
|
||||
|
||||
vec(my $rin = '', fileno($self), 1) = 1;
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
my $try = 0;
|
||||
|
||||
while () {
|
||||
my $nfound;
|
||||
my $rout = $rin;
|
||||
do {
|
||||
$! = 0;
|
||||
$nfound = select($rout, undef, undef, $select_time);
|
||||
} while $! == EINTR;
|
||||
if ($nfound > 0) {
|
||||
my $read_size = $read_size;
|
||||
if ($max_size > 0 and length($_[0]) + $read_size > $max_size) {
|
||||
$read_size = $max_size - length($_[0]);
|
||||
}
|
||||
my $ret = sysread($self, my $buff, $read_size);
|
||||
unless ($ret) {
|
||||
if ($! == EAGAIN or $! == EWOULDBLOCK) {
|
||||
if (++$try * $select_time > $read_wait) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
elsif ($! == 0) {
|
||||
$ERROR = "Connection closed";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
close $self;
|
||||
length($_[0]) ? last : undef;
|
||||
}
|
||||
else {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
close $self;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$try = 0;
|
||||
$_[0] .= $buff;
|
||||
undef $buff;
|
||||
last if $max_size > 0 and length($_[0]) >= $max_size;
|
||||
}
|
||||
}
|
||||
elsif ($nfound < 0) {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
elsif (++$try * $select_time > $read_wait) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
return length($_[0]);
|
||||
}
|
||||
|
||||
sub readalluntil {
|
||||
$ERROR = undef;
|
||||
my $self = shift;
|
||||
my $until = shift;
|
||||
$until = [$until] unless ref $until;
|
||||
@_ or croak 'Usage: $obj->readalluntil($string-or-\@strings, $scalar[, $scalar])';
|
||||
|
||||
my $initial;
|
||||
$initial = pop if @_ > 1;
|
||||
|
||||
return $self->readblock($_[0], -1) if not ${*$self}{non_blocking} or ${*$self}{ssl};
|
||||
|
||||
$_[0] = '';
|
||||
|
||||
my $read_wait = ${*$self}{read_wait};
|
||||
my $select_time = ${*$self}{select_time};
|
||||
my $read_size = ${*$self}{read_size};
|
||||
|
||||
unless (fileno $self) {
|
||||
$ERROR = "Socket closed";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
# Don't return undef - there could still be something waiting on the socket.
|
||||
}
|
||||
|
||||
local $!;
|
||||
|
||||
vec(my $rin = '', fileno($self), 1) = 1;
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
my ($try, $first) = (0);
|
||||
|
||||
UNTIL: while () {
|
||||
my $nfound;
|
||||
my $rout = $rin;
|
||||
do {
|
||||
$! = 0;
|
||||
$nfound = select($rout, undef, undef, $select_time);
|
||||
} while $! == EINTR;
|
||||
if ($nfound > 0) {
|
||||
my $ret = sysread($self, my $buff, $read_size);
|
||||
unless ($ret) {
|
||||
if ($! == EAGAIN or $! == EWOULDBLOCK) {
|
||||
if (++$try * $select_time > $read_wait) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
elsif ($! == 0) {
|
||||
$ERROR = "Connection closed";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
close $self;
|
||||
length($_[0]) ? last : undef;
|
||||
}
|
||||
else {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
close $self;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$try = 0;
|
||||
$_[0] .= $buff;
|
||||
undef $buff;
|
||||
|
||||
if (defined $initial and length($_[0]) >= length($initial) and not $first++) {
|
||||
last if $_[0] eq $initial;
|
||||
}
|
||||
for (@$until) {
|
||||
last UNTIL if rindex($_[0], $_) == length($_[0]) - length($_);
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($nfound < 0) {
|
||||
$ERROR = "Socket error: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
elsif (++$try * $select_time > $read_wait) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
return length($_[0]);
|
||||
}
|
||||
|
||||
sub write {
|
||||
my ($self, $msg) = @_;
|
||||
|
||||
unless (fileno $self) {
|
||||
$ERROR = "Socket closed";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
}
|
||||
|
||||
return unless defined $msg and length $msg;
|
||||
if (not ${*$self}{non_blocking} or ${*$self}{ssl}) {
|
||||
unless (print $self $msg) {
|
||||
$ERROR = "print failed: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
else {
|
||||
for (1 .. 10) { # Maximum 10 "EAGAIN" tries
|
||||
my $rv = syswrite $self, $msg, length $msg;
|
||||
if (!defined $rv and $! == EAGAIN) {
|
||||
next;
|
||||
}
|
||||
elsif (!defined $rv or $rv != length $msg) {
|
||||
$ERROR = "Could not write to socket: $!";
|
||||
carp $ERROR if ${*$self}{debug};
|
||||
return undef;
|
||||
}
|
||||
else {
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
# Returns the IP that we ended up connecting to.
|
||||
# This is the value returned from Socket.pm's inet_aton function.
|
||||
sub iaddr {
|
||||
my $self = shift;
|
||||
${*$self}{iaddr};
|
||||
}
|
||||
|
||||
# This is the _numeric_ port that was connected to, regardless of whether or
|
||||
# not you passed a number or string port.
|
||||
sub port {
|
||||
my $self = shift;
|
||||
${*$self}{port};
|
||||
}
|
||||
|
||||
sub error { $ERROR }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Socket::Client - Socket module designed for TCP clients
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Socket::Client qw/:crlf/;
|
||||
|
||||
my $socket = GT::Socket::Client->open(
|
||||
host => "gossamer-threads.com",
|
||||
port => "shell", # AKA port 514
|
||||
timeout => 10
|
||||
) or die GT::Socket::Client->error;
|
||||
|
||||
# $socket is now a socket connected to the host. Use
|
||||
# it as you would use any socket.
|
||||
$sock->readline(my $line);
|
||||
print "Read this line from the socket: $line";
|
||||
print $sock "That line" . CRLF;
|
||||
|
||||
$sock->readblock(my $block, 4096);
|
||||
print "Read 4KB from the socket: $block";
|
||||
print $sock "QUIT" . CRLF;
|
||||
|
||||
$sock->readall(my $all);
|
||||
print "Everything else from the socket: $all";
|
||||
print $sock "Something else" . CRLF;
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is a basic socket module that is designed to only handle basic
|
||||
socket connection and simple read capabilities. Anything else that you want to
|
||||
do with the socket is entirely up to you - this doesn't try to support
|
||||
superfluous options that only a few connections will ever use, or options that
|
||||
should be done in the code using this module instead of the module itself. See
|
||||
the GT::WWW::http and GT::WWW::https modules for a good working example.
|
||||
|
||||
By default, GT::Socket::Client exports nothing, however it can export the LF,
|
||||
CR, CRLF, $LF, $CR, and $CRLF constants, individually, or together via the
|
||||
':crlf' export tag.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 open
|
||||
|
||||
Takes a hash (not hash reference) of socket options, as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item host
|
||||
|
||||
[REQUIRED] The name or IP of the host to connect to.
|
||||
|
||||
=item port
|
||||
|
||||
[REQUIRED] The numeric value (25) or service name ("smtp") of the port to
|
||||
connect to.
|
||||
|
||||
=item ssl
|
||||
|
||||
[OPTIONAL] If this option is provided, the connection will use SSL. Note that
|
||||
this requires the Net::SSLeay module.
|
||||
|
||||
=item timeout
|
||||
|
||||
[OPTIONAL] A connection timeout period, in integral seconds. Note that this is
|
||||
only supported on systems that support the alarm() function; on other systems
|
||||
(such as Windows), this argument has no effect.
|
||||
|
||||
=item non_blocking
|
||||
|
||||
[OPTIONAL] Before returning it to you, the connected socket will be set up as
|
||||
non-blocking if this option is enabled. Note that this option B<DOES NOT WORK>
|
||||
with the ssl option, due to the Net::SSLeay interface.
|
||||
|
||||
=item autoflush
|
||||
|
||||
[OPTIONAL] Before returning to you, the connected socket will be made non-
|
||||
buffering. If you want your socket to be buffered, pass in autoflush with a
|
||||
false value.
|
||||
|
||||
=item ssl
|
||||
|
||||
[OPTIONAL] GT::Socket::Client has the ability to establish an SSL connection to
|
||||
a server for protocols such as HTTPS, SMTPS, POP3S, IMAPS, etc. Note that it
|
||||
currently has a limitation of not being able to change to or from an SSL
|
||||
connection once the connection is established, for protocols like FTPS.
|
||||
|
||||
=item debug
|
||||
|
||||
[OPTIONAL] If debugging is enabled, internal warnings (such as invalid port,
|
||||
unresolvable host, connection failure, etc.) will be warn()ed. This does not
|
||||
affect the error() method, which will always be set to the error message when
|
||||
a problem occurs. Provide a true value if you want the warn()s to appear.
|
||||
|
||||
=back
|
||||
|
||||
=head2 readline
|
||||
|
||||
This method reads a single line from the socket. It takes one argument, which
|
||||
must be a scalar which will be set to the line read. See the eol() method,
|
||||
which allows you to specify an EOL character other than "\012". Note that on a
|
||||
blocking socket, this will block until it can read a full line (or the server
|
||||
closes the connection). On a non-blocking socket, the amount of time it will
|
||||
wait for input is dependent on the value of the read_wait() method.
|
||||
|
||||
1 is returned on success, undef on failure.
|
||||
|
||||
=head2 readblock
|
||||
|
||||
This method attempts to read a certain number of bytes from the server. This
|
||||
takes two arguments: like readline(), the first argument is a scalar that will
|
||||
be set to the data read. The second argument is the amount of data that may be
|
||||
read. Note that on a blocking socket, this will block until the required
|
||||
amount of data is read, or the socket is closed. On a non-blocking socket, this
|
||||
will return once the requested amount of data is read, the socket closes, or
|
||||
there is no input for C<read_wait> seconds (See L</read_wait>).
|
||||
|
||||
Note that a block size of -1 makes the socket read until the connection is
|
||||
closed, in the case of blocking sockets, or until the read_wait() is hit.
|
||||
|
||||
The number of bytes read is returned on success, undef on failure.
|
||||
|
||||
=head2 readall
|
||||
|
||||
A synonym for C<$obj-E<gt>readblock($_[0], -1)> - in other words, it reads all
|
||||
available data (waiting for up to C<read_wait> seconds, if non-blocking).
|
||||
|
||||
=head2 readalluntil
|
||||
|
||||
A useful function for non-blocking sockets (completely useless for blocking
|
||||
sockets, on which it simply becomes a readall call). Basically, this works
|
||||
like readall(), above, but it will terminate immediately if it encounters a
|
||||
pattern that you provide on the end of the data read. Note that this does NOT
|
||||
work as a delimiter, but is useful for protocols such as POP3 when you want to
|
||||
read as much as you can, but know what should be at the end of what you read.
|
||||
The sole advantage of this is that it allows you to avoid the read_wait timeout
|
||||
that would otherwise be required at the end of a data stream.
|
||||
|
||||
It takes two arguments - the first is a string or array reference of strings
|
||||
containing the trailing string data. The second is a scalar that will be set
|
||||
to the data read. For example, for POP3 you might use: C<"\n.\r\n">. You can
|
||||
optionally pass in a third argument, which is used during the first read - if
|
||||
the result of the first read is equal to the string passed in, it's returned.
|
||||
Using the POP3 example again, this might be C<".\r\n"> - to handle an empty
|
||||
response.
|
||||
|
||||
=head2 select_time
|
||||
|
||||
[Non-blocking sockets only] This adjusts the number of seconds passed to
|
||||
select() to poll the socket for available data. The default value is 0.05,
|
||||
which should work in most situations.
|
||||
|
||||
=head2 read_wait
|
||||
|
||||
[Non-blocking sockets only] This method is used to set the wait time for reads.
|
||||
On a local or very fast connection, this can be set to a low value (i.e. 0.1
|
||||
seconds), but on a typical slower internet connection, longer wait times for
|
||||
reading are usually necessary. Hence, the default is a wait time of 5 seconds.
|
||||
In effect, an attempt to read all data will end after nothing has been received
|
||||
for this many seconds.
|
||||
|
||||
=head2 write
|
||||
|
||||
Sends data to the server. Takes the data to send. This does The Right Thing
|
||||
for either non-blocking or blocking sockets.
|
||||
|
||||
=head2 eol
|
||||
|
||||
This method takes one or more character, and uses it for the EOL character(s)
|
||||
used by readline. If called without any argument, the EOL character for the
|
||||
current object is returned.
|
||||
|
||||
=head2 error
|
||||
|
||||
If an error (such as connection, socket, etc.) occurs, you can access it via
|
||||
the error() method. This can be called as either a class or instance method,
|
||||
since open() return C<undef> instead of an object if the connection fails.
|
||||
|
||||
=head2 iaddr
|
||||
|
||||
Once a connection has been established, you can call this method to get the
|
||||
iaddr value for the connection. This value is as returned by
|
||||
L<Socket.pm|Socket>'s inet_aton function.
|
||||
|
||||
=head2 port
|
||||
|
||||
Once a connection has been established, this method can be used to determine
|
||||
the port connected to. Note that this is not necessarily the same as the value
|
||||
of the C<port> option passed to open() - the return value of this function will
|
||||
always be numeric (e.g. C<25>), even if a service name (e.g. C<"smtp">) was
|
||||
passed to open().
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::Socket> - A socket module made for Links SQL.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Client.pm,v 1.15 2004/02/17 01:33:07 jagerman Exp $
|
||||
|
||||
=cut
|
||||
124
site/glist/lib/GT/Socket/Client/SSLHandle.pm
Normal file
124
site/glist/lib/GT/Socket/Client/SSLHandle.pm
Normal file
@@ -0,0 +1,124 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Socket::Client::SSLHandle
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: SSLHandle.pm,v 1.3 2004/01/13 01:35:20 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# A tied filehandle for SSL connections with GT::Socket::Client (via
|
||||
# Net::SSLeay::Handle).
|
||||
#
|
||||
|
||||
package GT::Socket::Client::SSLHandle;
|
||||
use strict;
|
||||
use vars qw/$VERSION $ERROR/;
|
||||
use GT::Socket::Client;
|
||||
use Net::SSLeay 1.06 qw/print_errs/;
|
||||
|
||||
*ERROR = \$GT::Socket::Client::ERROR;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
Net::SSLeay::load_error_strings();
|
||||
Net::SSLeay::SSLeay_add_ssl_algorithms();
|
||||
Net::SSLeay::randomize();
|
||||
|
||||
sub TIEHANDLE {
|
||||
my ($class, $socket) = @_;
|
||||
|
||||
my $ctx = Net::SSLeay::CTX_new()
|
||||
or return ssl_err("Failed to create new SSL CTX: $!", "SSL CTX_new");
|
||||
my $ssl = Net::SSLeay::new($ctx)
|
||||
or return ssl_err("Failed to create SSL: $!", "SSL new");
|
||||
|
||||
my $fileno = fileno($socket);
|
||||
Net::SSLeay::set_fd($ssl, $fileno);
|
||||
|
||||
my $connect = Net::SSLeay::connect($ssl);
|
||||
|
||||
${*$socket}{SSLHandle_ssl} = $ssl;
|
||||
${*$socket}{SSLHandle_ctx} = $ctx;
|
||||
${*$socket}{SSLHandle_fileno} = $fileno;
|
||||
|
||||
return bless $socket, $class;
|
||||
}
|
||||
|
||||
sub PRINT {
|
||||
my $socket = shift;
|
||||
my $ssl = ${*$socket}{SSLHandle_ssl};
|
||||
my $ret = 0;
|
||||
for (@_) {
|
||||
defined or last;
|
||||
$ret = Net::SSLeay::write($ssl, $_);
|
||||
if (!$ret) {
|
||||
ssl_err("Could not write to SSL socket: $!", "SSL write");
|
||||
last;
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub READLINE {
|
||||
my $socket = shift;
|
||||
my $ssl = ${*$socket}{SSLHandle_ssl};
|
||||
my $line = Net::SSLeay::ssl_read_until($ssl);
|
||||
if (!$line) {
|
||||
ssl_err("Could not readline from SSL socket: $!", "SSL ssl_read_until");
|
||||
return undef;
|
||||
}
|
||||
return $line;
|
||||
}
|
||||
|
||||
sub READ {
|
||||
my ($socket, $buffer, $length, $offset) = \(@_);
|
||||
my $ssl = ${*$$socket}{SSLHandle_ssl};
|
||||
if (defined $$offset) {
|
||||
my $read = Net::SSLeay::ssl_read_all($ssl, $$length)
|
||||
or return ssl_err("Could not read_all from SSL socket: $!", "SSL ssl_read_all");
|
||||
my $buf_length = length($$buffer);
|
||||
$$offset > $buf_length and $$buffer .= chr(0) x ($$offset - $buf_length);
|
||||
substr($$buffer, $$offset) = $read;
|
||||
return length($read);
|
||||
}
|
||||
else {
|
||||
return length(
|
||||
$$buffer = Net::SSLeay::ssl_read_all($ssl, $$length)
|
||||
or return ssl_err("Could not read_all from SSL socket: $!", "SSL ssl_read_all")
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub WRITE {
|
||||
my $socket = shift;
|
||||
my ($buffer, $length, $offset) = @_;
|
||||
$offset = 0 unless defined $offset;
|
||||
|
||||
# Return number of characters written
|
||||
my $ssl = ${*$socket}{SSLHandle_ssl};
|
||||
Net::SSLeay::write($ssl, substr($buffer, $offset, $length))
|
||||
or return ssl_err("Could not write to SSL socket: $!", "SSL write");
|
||||
return $length;
|
||||
}
|
||||
|
||||
sub CLOSE {
|
||||
my $socket = shift;
|
||||
my $fileno = fileno($socket);
|
||||
Net::SSLeay::free(${*$socket}{SSLHandle_ssl});
|
||||
Net::SSLeay::CTX_free(${*$socket}{SSLHandle_ctx});
|
||||
close $socket;
|
||||
}
|
||||
|
||||
sub FILENO { fileno($_[0]) }
|
||||
|
||||
sub ssl_err {
|
||||
my ($msg, $key) = @_;
|
||||
$ERROR = "$msg\n" . print_errs($key); # Also sets $GT::Socket::Client::ERROR
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
1187
site/glist/lib/GT/Tar.pm
Normal file
1187
site/glist/lib/GT/Tar.pm
Normal file
File diff suppressed because it is too large
Load Diff
199
site/glist/lib/GT/TempFile.pm
Normal file
199
site/glist/lib/GT/TempFile.pm
Normal file
@@ -0,0 +1,199 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::TempFile
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: TempFile.pm,v 1.36 2005/03/23 04:27:26 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements a tempfile.
|
||||
#
|
||||
|
||||
package GT::TempFile;
|
||||
# ===================================================================
|
||||
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw/$VERSION $TMP_DIR %OBJECTS/;
|
||||
use bases 'GT::Base' => ':all';
|
||||
use overload '""' => \&as_string;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.36 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
sub find_tmpdir {
|
||||
# -------------------------------------------------------------------
|
||||
# Sets the tmpdir.
|
||||
#
|
||||
return $TMP_DIR if $TMP_DIR;
|
||||
my @tmp_dirs;
|
||||
for (qw/GT_TMPDIR TEMP TMP TMPDIR/) {
|
||||
push @tmp_dirs, $ENV{$_} if exists $ENV{$_};
|
||||
}
|
||||
push @tmp_dirs, $ENV{windir} . '/temp' if exists $ENV{windir};
|
||||
eval { push @tmp_dirs, (getpwuid $>)[7] . '/tmp' };
|
||||
push @tmp_dirs, '/usr/tmp', '/var/tmp', 'c:/temp', '/tmp', '/temp', '/sys$scratch', '/WWW_ROOT', 'c:/windows/temp', 'c:/winnt/temp';
|
||||
|
||||
for my $dir (@tmp_dirs) {
|
||||
return $TMP_DIR = $dir if $dir and -d $dir and -w _ and -x _;
|
||||
}
|
||||
$TMP_DIR = '.';
|
||||
}
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Create a new tempfile.
|
||||
#
|
||||
$TMP_DIR ||= find_tmpdir();
|
||||
my $self = bless {}, 'GT::TempFile::Tmp';
|
||||
$self->reset;
|
||||
|
||||
# Backwards compatibility
|
||||
if ( @_ == 2 and not ref( $_[1] ) ) {
|
||||
( $self->{tmp_dir} ) = $_[1];
|
||||
}
|
||||
elsif ( @_ > 1 ) {
|
||||
$self->set( @_[1 .. $#_] );
|
||||
}
|
||||
|
||||
my $dir = $self->{tmp_dir} || $TMP_DIR;
|
||||
my $count = substr(time, -4) . int(rand(10000));
|
||||
my $filename = '';
|
||||
|
||||
# Directory for locking
|
||||
my $lock_dir = "$dir/$self->{prefix}GT_TempFile_lock";
|
||||
|
||||
# W need to create the directory
|
||||
my $safety = 0;
|
||||
until ( mkdir( $lock_dir, 0777 ) ) {
|
||||
|
||||
# If we wait 10 seconds and still no lock we assume the lockfile is stale
|
||||
if ( $safety++ > 10 ) {
|
||||
rmdir $lock_dir or $self->fatal( 'RMDIR', $lock_dir, "$!" );
|
||||
}
|
||||
sleep 1;
|
||||
}
|
||||
|
||||
# Now lets get our temp file
|
||||
for (1 .. 20) {
|
||||
$filename = "$dir/$self->{prefix}GTTemp$count";
|
||||
last if (! -f $filename);
|
||||
$count++;
|
||||
}
|
||||
|
||||
# If the open fails we need to remove the lockdir
|
||||
if ( !open( FH, ">$filename" ) ) {
|
||||
rmdir $lock_dir or $self->fatal( 'RMDIR', $lock_dir, "$!" );
|
||||
$self->fatal( 'WRITEOPEN', $filename, "$!" );
|
||||
}
|
||||
close FH;
|
||||
|
||||
# All done searching for a temp file, now release the directory lock
|
||||
rmdir $lock_dir or $self->fatal( 'RMDIR', $lock_dir, "$!" );
|
||||
($filename =~ /^(.+)$/) and ($filename = $1); # Detaint.
|
||||
|
||||
$self->{filename} = $filename;
|
||||
my $object = bless \$filename, 'GT::TempFile';
|
||||
$OBJECTS{overload::StrVal $object} = $self;
|
||||
$self->debug("New tmpfile created ($filename).") if ($self->{_debug});
|
||||
$object;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
# -------------------------------------------------------------------
|
||||
# Backwards compatibility
|
||||
my ( $self ) = @_;
|
||||
return $$self;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# -------------------------------------------------------------------
|
||||
my $obj = shift;
|
||||
my $self = $OBJECTS{$obj};
|
||||
$self->debug("Deleteing $self->{filename}") if $self->{_debug};
|
||||
|
||||
# unlink the file if they wanted it deleted
|
||||
if ($self->{destroy}) {
|
||||
unless (unlink $self->{filename}) {
|
||||
$self->debug("Unable to remove temp file: $self->{filename} ($!)") if $self->{_debug};
|
||||
}
|
||||
}
|
||||
delete $OBJECTS{$obj};
|
||||
}
|
||||
|
||||
package GT::TempFile::Tmp;
|
||||
use bases 'GT::Base' => '';
|
||||
use vars qw/$ATTRIBS $ERRORS/;
|
||||
$ATTRIBS = {
|
||||
prefix => '',
|
||||
destroy => 1,
|
||||
tmp_dir => undef,
|
||||
};
|
||||
$ERRORS = { SAFETY => "Safety reached while trying to create lock directory %s, (%s)" };
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::TempFile - implements a very simple temp file.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $file = new GT::TempFile;
|
||||
open (FILE, "> $file");
|
||||
print FILE "somedata";
|
||||
close FILE;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::TempFile implements a very simple temp file system that will remove
|
||||
itself once the variable goes out of scope.
|
||||
|
||||
When you call new, it creates a random file name and looks for a
|
||||
tmp directory. What you get back is an object that when dereferenced
|
||||
is the file name. You can also pass in a temp dir to use:
|
||||
|
||||
my $file = new GT::Tempfile '/path/to/tmpfiles';
|
||||
|
||||
Other option you may use are:
|
||||
my $file = new GT::TempFile(
|
||||
destroy => 1,
|
||||
prefix => '',
|
||||
tmp_dir => '/tmp'
|
||||
);
|
||||
|
||||
|
||||
When the object is destroyed, it automatically unlinks the temp file
|
||||
unless you specify I<destroy> => 0.
|
||||
|
||||
I<prefix> will be prepended to the start of all temp files created
|
||||
and the lock directory that is created. It is used to keep programs
|
||||
using the tempfile module that do not have the temp files destroyed
|
||||
from clashing.
|
||||
|
||||
I<tmp_dir> is the same as calling new with just one argument, it is
|
||||
the directory where files will be stored.
|
||||
|
||||
TempFile picks a temp directory based on the following:
|
||||
|
||||
1. ENV{GT_TMPDIR}
|
||||
2. ~/tmp
|
||||
3. ENV{TMPDIR}, ENV{TEMP}, ENV{TMP}
|
||||
4. /usr/tmp, /var/tmp, c:/temp, /tmp, /temp,
|
||||
/WWW_ROOT, c:/windows/temp, c:/winnt/temp
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: TempFile.pm,v 1.36 2005/03/23 04:27:26 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1208
site/glist/lib/GT/Template.pm
Normal file
1208
site/glist/lib/GT/Template.pm
Normal file
File diff suppressed because it is too large
Load Diff
417
site/glist/lib/GT/Template/Editor.pm
Normal file
417
site/glist/lib/GT/Template/Editor.pm
Normal file
@@ -0,0 +1,417 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Template::Editor
|
||||
# Author: Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Editor.pm,v 2.19 2004/10/19 23:34:44 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# A module for editing templates via an HTML browser.
|
||||
#
|
||||
|
||||
package GT::Template::Editor;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use GT::Base;
|
||||
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS);
|
||||
@ISA = qw/GT::Base/;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 2.19 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ATTRIBS = {
|
||||
cgi => undef,
|
||||
root => undef,
|
||||
backup => undef,
|
||||
default_dir => '',
|
||||
default_file => '',
|
||||
date_format => '',
|
||||
class => undef,
|
||||
skip_dir => undef,
|
||||
skip_file => undef,
|
||||
select_dir => 'tpl_dir',
|
||||
demo => undef
|
||||
};
|
||||
$ERRORS = {
|
||||
CANTOVERWRITE => "Unable to overwrite file: %s (Permission Denied). Please set permissions properly and save again.",
|
||||
CANTCREATE => "Unable to create new files in directory %s. Please set permissions properly and save again.",
|
||||
CANTMOVE => "Unable to move file %s to %s: %s",
|
||||
CANTMOVE => "Unable to copy file %s to %s: %s",
|
||||
FILECOPY => "File::Copy is required in order to make backups.",
|
||||
};
|
||||
|
||||
sub process {
|
||||
# ------------------------------------------------------------------
|
||||
# Loads the template editor.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my $sel_tpl_dir = $self->{select_dir};
|
||||
my $selected_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default';
|
||||
my $selected_file = $self->{cgi}->param('tpl_file') || '';
|
||||
my $tpl_text = '';
|
||||
my $error_msg = '';
|
||||
my $success_msg = '';
|
||||
my ($local, $restore) = (0, 0);
|
||||
|
||||
# Check the template directory and file
|
||||
if ($selected_dir =~ m[[\\/\x00-\x1f]] or $selected_dir eq '..') {
|
||||
$error_msg = "Invalid template directory $selected_dir";
|
||||
$selected_dir = '';
|
||||
$selected_file = '';
|
||||
}
|
||||
if ($selected_file =~ m[[\\/\x00-\x1f]]) {
|
||||
$error_msg = "Invalid template $selected_file";
|
||||
$selected_dir = '';
|
||||
$selected_file = '';
|
||||
}
|
||||
|
||||
# Create the local directory if it doesn't exist.
|
||||
my $tpl_dir = $self->{root} . '/' . $selected_dir;
|
||||
my $local_dir = $tpl_dir . "/local";
|
||||
if ($selected_dir and ! -d $local_dir) {
|
||||
mkdir($local_dir, 0777) or return $self->error('MKDIR', 'FATAL', $local_dir, "$!");
|
||||
chmod(0777, $local_dir);
|
||||
}
|
||||
my $dir = $local_dir;
|
||||
|
||||
my $save = $self->{cgi}->param('tpl_name') || $self->{cgi}->param('tpl_file');
|
||||
# Perform a save if requested.
|
||||
if ($self->{cgi}->param('saveas') and $save and !$self->{demo}) {
|
||||
$tpl_text = $self->{cgi}->param('tpl_text');
|
||||
if (-e "$dir/$save" and ! -w _) {
|
||||
$error_msg = sprintf($ERRORS->{CANTOVERWRITE}, $save);
|
||||
}
|
||||
elsif (! -e _ and ! -w $dir) {
|
||||
$error_msg = sprintf($ERRORS->{CANTCREATE}, $dir);
|
||||
}
|
||||
else {
|
||||
if ($self->{backup} and -e "$dir/$save") {
|
||||
$self->copy("$dir/$save", "$dir/$save.bak");
|
||||
}
|
||||
local *FILE;
|
||||
open (FILE, "> $dir/$save") or return $self->error(CANTOPEN => FATAL => "$dir/$save", "$!");
|
||||
$tpl_text =~ s/\r\n/\n/g;
|
||||
print FILE $tpl_text;
|
||||
close FILE;
|
||||
chmod 0666, "$dir/$save";
|
||||
$success_msg = "File has been successfully saved.";
|
||||
$local = 1;
|
||||
$restore = 1 if -e "$self->{root}/$selected_dir/$save";
|
||||
$selected_file = $save;
|
||||
$tpl_text = '';
|
||||
}
|
||||
}
|
||||
# Delete a local template (thereby restoring the system template)
|
||||
elsif (my $restore = $self->{cgi}->param("restore") and !$self->{demo}) {
|
||||
if ($self->{backup}) {
|
||||
if ($self->move("$dir/$restore", "$dir/$restore.bak")) {
|
||||
$success_msg = "System template '$restore' restored";
|
||||
}
|
||||
else {
|
||||
$error_msg = "Unable to restore system template '$restore': Cannot move '$dir/$restore': $!";
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (unlink "$dir/$restore") {
|
||||
$success_msg = "System template '$restore' restored";
|
||||
}
|
||||
else {
|
||||
$error_msg = "Unable to remove $dir/$restore: $!";
|
||||
}
|
||||
}
|
||||
}
|
||||
# Delete a local template (This is like restore, but happens when there is no system template)
|
||||
elsif (my $delete = $self->{cgi}->param("delete") and !$self->{demo}) {
|
||||
if ($self->{backup}) {
|
||||
if ($self->move("$dir/$delete", "$dir/$delete.bak")) {
|
||||
$success_msg = "Template '$delete' deleted";
|
||||
}
|
||||
else {
|
||||
$error_msg = "Unable to delete template '$delete': Cannot move '$dir/$delete': $!";
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (unlink "$dir/$delete") {
|
||||
$success_msg = "Template '$delete' deleted";
|
||||
}
|
||||
else {
|
||||
$error_msg = "Unable to remove $dir/$delete: $!";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Load any selected template file.
|
||||
if ($selected_file and ! $tpl_text) {
|
||||
if (-f "$dir/$selected_file") {
|
||||
local (*FILE, $/);
|
||||
open FILE, "$dir/$selected_file" or die "Unable to open file $dir/$selected_file: $!";
|
||||
$tpl_text = <FILE>;
|
||||
close FILE;
|
||||
$local = 1;
|
||||
$restore = 1 if -e "$self->{root}/$selected_dir/$selected_file";
|
||||
}
|
||||
elsif (-f "$self->{root}/$selected_dir/$selected_file") {
|
||||
local (*FILE, $/);
|
||||
open FILE, "$self->{root}/$selected_dir/$selected_file" or die "Unable to open file $self->{root}/$selected_dir/$selected_file: $!";
|
||||
$tpl_text = <FILE>;
|
||||
close FILE;
|
||||
}
|
||||
else {
|
||||
$selected_file = '';
|
||||
}
|
||||
}
|
||||
|
||||
# Load a README if it exists.
|
||||
my $readme;
|
||||
if (-e "$dir/README") {
|
||||
local (*FILE, $/);
|
||||
open FILE, "$dir/README" or die "unable to open readme: $dir/README ($!)";
|
||||
$readme = <FILE>;
|
||||
close FILE;
|
||||
}
|
||||
|
||||
# Set the textarea width and height.
|
||||
my $editor_rows = $self->{cgi}->param('cookie-editor_rows') || $self->{cgi}->cookie('editor_rows') || 15;
|
||||
my $editor_cols = $self->{cgi}->param('cookie-editor_cols') || $self->{cgi}->cookie('editor_cols') || 55;
|
||||
my $file_select = $self->template_file_select;
|
||||
my $dir_select = $self->template_dir_select;
|
||||
$tpl_text = $self->{cgi}->html_escape($tpl_text);
|
||||
my $stats = $selected_file ? $self->template_file_stats($selected_file) : {};
|
||||
|
||||
if ($self->{demo} and ($self->{cgi}->param('saveas') or $self->{cgi}->param("delete") or $self->{cgi}->param("restore"))) {
|
||||
$error_msg = 'This feature has been disabled in the demo!';
|
||||
}
|
||||
return {
|
||||
tpl_name => $selected_file,
|
||||
tpl_file => $selected_file,
|
||||
local => $local,
|
||||
restore => $restore,
|
||||
tpl_text => \$tpl_text,
|
||||
error_message => $error_msg,
|
||||
success_message => $success_msg,
|
||||
tpl_dir => $selected_dir,
|
||||
readme => $readme,
|
||||
editor_rows => $editor_rows,
|
||||
editor_cols => $editor_cols,
|
||||
dir_select => $dir_select,
|
||||
file_select => $file_select,
|
||||
%$stats
|
||||
};
|
||||
}
|
||||
|
||||
sub _skip_files {
|
||||
my ($skip, $file) = @_;
|
||||
return 1 if $skip->{$file}
|
||||
or substr($file, 0, 1) eq '.' # skip dotfiles
|
||||
or substr($file, -4) eq '.bak'; # skip .bak files
|
||||
foreach my $f (keys %$skip) {
|
||||
my $match = quotemeta $f;
|
||||
$match =~ s/\\\*/.*/g;
|
||||
$match =~ s/\\\?/./g;
|
||||
return 1 if $file =~ /^$match$/;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub template_file_select {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a select list of templates in a given dir.
|
||||
#
|
||||
my $self = shift;
|
||||
my $path = $self->{root};
|
||||
my %files;
|
||||
my $sel_tpl_dir = $self->{select_dir};
|
||||
my $selected_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default';
|
||||
my $selected_file = $self->{cgi}->param('tpl_file') || $self->{default_file} || 'default';
|
||||
$selected_file = $self->{cgi}->param('tpl_name') if $self->{cgi}->param('saveas');
|
||||
my %skip;
|
||||
if ($self->{skip_file}) {
|
||||
for (@{$self->{skip_file}}) {
|
||||
$skip{$_}++;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$skip{README} = $skip{'language.txt'} = $skip{'globals.txt'} = 1;
|
||||
}
|
||||
|
||||
# Check the template directory
|
||||
return if $selected_dir =~ m[[\\/\x00-\x1f]] or $selected_dir eq '..';
|
||||
|
||||
my $system_dir = $path . "/" . $selected_dir;
|
||||
my $local_dir = $path . "/" . $selected_dir . '/local';
|
||||
foreach my $dir ($system_dir, $local_dir) {
|
||||
opendir (TPL, $dir) or next;
|
||||
while (defined(my $file = readdir TPL)) {
|
||||
next unless -f "$dir/$file" and -r _;
|
||||
next if _skip_files(\%skip, $file);
|
||||
|
||||
$files{$file} = 1;
|
||||
}
|
||||
closedir TPL;
|
||||
}
|
||||
my $f_select_list = '<select name="tpl_file"';
|
||||
$f_select_list .= qq' class="$self->{class}"' if $self->{class};
|
||||
$f_select_list .= ">\n";
|
||||
|
||||
foreach (sort keys %files) {
|
||||
my $system = -e $path . '/' . $selected_dir . '/' . $_;
|
||||
my $local = -e $path . '/' . $selected_dir . '/local/' . $_;
|
||||
my $changed = $system && $local ? ' *' : $local ? ' +' : '';
|
||||
$f_select_list .= qq' <option value="$_"';
|
||||
$f_select_list .= ' selected' if $_ eq $selected_file;
|
||||
$f_select_list .= ">$_$changed</option>\n";
|
||||
}
|
||||
$f_select_list .= "</select>";
|
||||
|
||||
return $f_select_list;
|
||||
}
|
||||
|
||||
sub template_dir_select {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a select list of template directories.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($dir, $file, @dirs);
|
||||
my $name = $self->{select_dir};
|
||||
my $selected_dir = $self->{cgi}->param($name) || $self->{default_dir} || 'default';
|
||||
|
||||
$dir = $self->{root};
|
||||
|
||||
my %skip = ('..' => 1, '.' => 1);
|
||||
if ($self->{skip_dir}) {
|
||||
for (@{$self->{skip_dir}}) { $skip{$_}++ }
|
||||
}
|
||||
else {
|
||||
$skip{admin} = $skip{help} = $skip{CVS} = 1;
|
||||
}
|
||||
|
||||
opendir (TPL, $dir) or die "unable to open directory: '$dir' ($!)";
|
||||
while (defined($file = readdir TPL)) {
|
||||
next if $skip{$file};
|
||||
next unless (-d "$dir/$file");
|
||||
push @dirs, $file;
|
||||
}
|
||||
closedir TPL;
|
||||
|
||||
my $d_select_list = qq'<select name="$name"';
|
||||
$d_select_list .= qq' class="$self->{class}"' if $self->{class};
|
||||
$d_select_list .= ">\n";
|
||||
foreach (sort @dirs) {
|
||||
$d_select_list .= qq' <option value="$_"';
|
||||
$d_select_list .= ' selected' if $_ eq $selected_dir;
|
||||
$d_select_list .= ">$_</option>\n";
|
||||
}
|
||||
$d_select_list .= "</select>";
|
||||
return $d_select_list;
|
||||
}
|
||||
|
||||
sub template_file_stats {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns information about a file. Takes the following arguments:
|
||||
# - filename
|
||||
# - template set
|
||||
# The following tags are returned:
|
||||
# - file_path - the full path to the file, relative to the admin root directory
|
||||
# - file_size - the size of the file in bytes
|
||||
# - file_local - 1 or 0 - true if it is a local file
|
||||
# - file_restore - 1 or 0 - true if it is a local file and a non-local file of the same name exists (The non-local can be restored)
|
||||
# - file_mod_time - the date the file was last modified
|
||||
#
|
||||
require GT::Date;
|
||||
my ($self, $file) = @_;
|
||||
my $sel_tpl_dir = $self->{select_dir};
|
||||
my $tpl_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default';
|
||||
my $return = { file_local => 1, file_restore => 1 };
|
||||
my $dir = "$self->{root}/$tpl_dir";
|
||||
if (-f "$dir/local/$file" and -r _) {
|
||||
$return->{file_path} = "templates/$tpl_dir/local/$file";
|
||||
$return->{file_size} = -s _;
|
||||
$return->{file_local} = 1;
|
||||
my $mod_time = (stat _)[9];
|
||||
$return->{file_restore} = (-f "$dir/$file" and -r _) ? 1 : 0;
|
||||
if ($self->{date_format}) {
|
||||
require GT::Date;
|
||||
$return->{file_mod_time} = GT::Date::date_get($mod_time, $self->{date_format});
|
||||
}
|
||||
else {
|
||||
$return->{file_mod_time} = localtime($mod_time);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$return->{file_path} = "templates/$tpl_dir/$file";
|
||||
$return->{file_size} = -s "$dir/$file";
|
||||
$return->{file_local} = 0;
|
||||
$return->{file_restore} = 0;
|
||||
my $mod_time = (stat _)[9];
|
||||
if ($self->{date_format}) {
|
||||
require GT::Date;
|
||||
$return->{file_mod_time} = GT::Date::date_get($mod_time, $self->{date_format});
|
||||
}
|
||||
else {
|
||||
$return->{file_mod_time} = localtime($mod_time);
|
||||
}
|
||||
}
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub move {
|
||||
# -------------------------------------------------------------------
|
||||
# Uses File::Copy to move a file.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($from, $to) = @_;
|
||||
eval { require File::Copy; };
|
||||
if ($@) {
|
||||
return $self->error('FILECOPY', $@);
|
||||
}
|
||||
File::Copy::mv($from, $to) or return $self->error('CANTMOVE', $from, $to, "$!");
|
||||
}
|
||||
|
||||
sub copy {
|
||||
# -------------------------------------------------------------------
|
||||
# Uses File::Copy to move a file.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($from, $to) = @_;
|
||||
eval { require File::Copy; };
|
||||
if ($@) {
|
||||
return $self->error('FILECOPY', $@);
|
||||
}
|
||||
File::Copy::cp($from, $to) or return $self->error('CANTCOPY', $from, $to, "$!");
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Template::Editor - This module provides an easy way to edit templates.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Should be called like:
|
||||
|
||||
require GT::Template::Editor;
|
||||
my $editor = new GT::Template::Editor (
|
||||
root => $CFG->{admin_root_path} . '/templates',
|
||||
default_dir => $CFG->{build_default_tpl},
|
||||
backup => 1,
|
||||
cgi => $IN
|
||||
);
|
||||
return $editor->process;
|
||||
|
||||
and it returns a hsah ref of variables used for displaying a template editor page.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Editor.pm,v 2.19 2004/10/19 23:34:44 jagerman Exp $
|
||||
|
||||
=cut
|
||||
|
||||
250
site/glist/lib/GT/Template/Inheritance.pm
Normal file
250
site/glist/lib/GT/Template/Inheritance.pm
Normal file
@@ -0,0 +1,250 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Template::Inheritance
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Inheritance.pm,v 1.7 2005/02/09 20:51:27 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Provides class methods to deal with template
|
||||
# inheritance.
|
||||
#
|
||||
|
||||
package GT::Template::Inheritance;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use vars qw($ERRORS);
|
||||
use bases 'GT::Base' => '';
|
||||
use GT::Template;
|
||||
|
||||
$ERRORS = { RECURSION => q _Recursive inheritance detected and interrupted: '%s'_ };
|
||||
|
||||
sub get_all_paths {
|
||||
# ----------------------------------------------------------------------------
|
||||
my ($class, %opts) = @_;
|
||||
|
||||
my $file = delete $opts{file};
|
||||
my $single = delete $opts{_single};
|
||||
$class->fatal(BADARGS => "No file specified to $class->" . ($single ? 'get_path' : 'get_all_paths')) unless defined $file;
|
||||
|
||||
my $root = delete $opts{path};
|
||||
$class->fatal(BADARGS => "No path specified to $class->" . ($single ? 'get_path' : 'get_all_paths')) unless defined $root;
|
||||
$class->fatal(BADARGS => "Path $root does not exist or is not a directory") unless -d $root;
|
||||
|
||||
my $local = exists $opts{local} ? delete $opts{local} : 1;
|
||||
my $inheritance = exists $opts{inheritance} ? delete $opts{inheritance} : 1;
|
||||
|
||||
# Old no-longer-supported option:
|
||||
delete @opts{qw/use_inheritance use_local local_inheritance/};
|
||||
|
||||
$class->fatal(BADARGS => "Unknown arguments: " . join ", ", keys %opts) if keys %opts;
|
||||
|
||||
my @paths = $class->tree(path => $root, local => $local, inheritance => $inheritance);
|
||||
my @files;
|
||||
for (@paths) {
|
||||
if (-f "$_/$file" and -r _) {
|
||||
return "$_/$file" if $single;
|
||||
push @files, "$_/$file";
|
||||
}
|
||||
}
|
||||
return if $single;
|
||||
return @files;
|
||||
}
|
||||
|
||||
sub get_path {
|
||||
# ----------------------------------------------------------------------------
|
||||
shift->get_all_paths(@_, _single => 1);
|
||||
}
|
||||
|
||||
sub tree {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $class = shift;
|
||||
my %opts = @_ > 1 ? @_ : (path => shift);
|
||||
|
||||
my $root = delete $opts{path};
|
||||
$class->fatal(BADARGS => "No path specified for $class->tree") unless defined $root;
|
||||
$class->fatal(BADARGS => "Path '$root' does not exist or is not a directory") unless -d $root;
|
||||
|
||||
my $local = exists $opts{local} ? delete $opts{local} : 1;
|
||||
my $inheritance = exists $opts{inheritance} ? delete $opts{inheritance} : 1;
|
||||
|
||||
$class->fatal(BADARGS => "Unknown arguments: " . join ", ", keys %opts) if keys %opts;
|
||||
|
||||
my @paths;
|
||||
push @paths, $root;
|
||||
my %encountered = ($root => 1);
|
||||
if ($inheritance) {
|
||||
for my $path (@paths) {
|
||||
my $tplinfo = GT::Template->load_tplinfo($path);
|
||||
next if not defined $tplinfo->{inheritance};
|
||||
my @inherit = ref $tplinfo->{inheritance} eq 'ARRAY' ? @{$tplinfo->{inheritance}} : $tplinfo->{inheritance};
|
||||
|
||||
for (@inherit) {
|
||||
my $inh = m!^(?:[a-zA-Z]:)?[\\/]! ? $_ : "$path/$_";
|
||||
if (length $inh > 500 or $encountered{$inh}++) {
|
||||
return $class->fatal(RECURSION => $inh);
|
||||
}
|
||||
|
||||
push @paths, $inh;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($local) {
|
||||
for (my $i = 0; $i < @paths; $i++) {
|
||||
if (-d "$paths[$i]/local") {
|
||||
splice @paths, $i, 0, "$paths[$i]/local";
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return @paths;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Template::Inheritance - Provides GT::Template inheritance/local file
|
||||
determination.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Template::Inheritance;
|
||||
|
||||
my $file = GT::Template::Inheritance->get_path(
|
||||
file => "foo.htm",
|
||||
path => "/path/to/my/template/set"
|
||||
);
|
||||
|
||||
my @files = GT::Template::Inheritance->get_all_paths(
|
||||
file => "foo.htm",
|
||||
path => "/path/to/my/template/set"
|
||||
);
|
||||
|
||||
my @paths = GT::Template::Inheritance->tree(
|
||||
path => "/path/to/my/template/set"
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Template::Inheritance provides an interface to accessing files for
|
||||
GT::Template template parsing and include handling. It supports following
|
||||
inheritance directories and respects "local" template directories.
|
||||
|
||||
|
||||
=head2 Inheritance
|
||||
|
||||
GT::Template inheritance works by looking for a .tplinfo file in the template
|
||||
directory (or local/.tplinfo, if it exists). In order for the template
|
||||
directory to inherit from another template directory, this file must exist and
|
||||
must evaluate to a hash reference containing an C<inheritance> key. The
|
||||
following is a possible .tplinfo file contents:
|
||||
|
||||
{
|
||||
inheritance => '../other'
|
||||
}
|
||||
|
||||
The above example would indicate that files in this template set can be
|
||||
inherited from the ../other path, relative to the current template set
|
||||
directory. The inheritance directory may also contain a full path.
|
||||
|
||||
=head2 Inheriting from multiple locations
|
||||
|
||||
You may also inherit from multiple locations by using an array reference for
|
||||
the inheritance value:
|
||||
|
||||
{
|
||||
inheritance => ['../other', '/full/path/to/a/third']
|
||||
}
|
||||
|
||||
With the above .tplinfo file, files would be checked for in the current path,
|
||||
then C<../other>, then any of C<../other>'s inherited directories, then in
|
||||
C<third>, then in any of C<third>'s inherited directories.
|
||||
|
||||
Also keep in mind that "local" directories, if they exist, will be checked for
|
||||
the file before each of their respective directories.
|
||||
|
||||
Assuming that the initial template path was C</full/path/one>, and assuming
|
||||
that C<../other> inherited from C<../other2>, the directories checked would be
|
||||
as follows:
|
||||
|
||||
/full/path/one/local
|
||||
/full/path/one
|
||||
/full/path/one/../other/local # i.e. /full/path/other/local
|
||||
/full/path/one/../other # i.e. /full/path/other
|
||||
/full/path/one/../other/../other2/local # i.e. /full/path/other2/local
|
||||
/full/path/one/../other/../other2 # i.e. /full/path/other2
|
||||
/full/path/to/a/third/local
|
||||
/full/path/to/a/third
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
All methods in GT::Template::Inheritance are class methods. Each method takes
|
||||
a hash of options as an argument.
|
||||
|
||||
=head2 get_path
|
||||
|
||||
=head2 get_all_paths
|
||||
|
||||
These methods are used to obtain the location of the file GT::Template will
|
||||
use, taking into account all inherited and "local" template directories. The
|
||||
get_path option will return the path to the file that will be included, while
|
||||
the get_all_paths option returns the path to B<all> copies of the file found in
|
||||
the local/inheritance tree. Both methods take a hash containing the following:
|
||||
|
||||
=over 4
|
||||
|
||||
=item file
|
||||
|
||||
The name of the file desired.
|
||||
|
||||
=item path
|
||||
|
||||
The template directory at which to start looking for the above file. Depending
|
||||
on the existance of "local" directories and template inheritance, more than
|
||||
just this directory will be checked for the file.
|
||||
|
||||
=item local
|
||||
|
||||
Optional. Can be passed with a false value to override the checking of "local"
|
||||
directories for files.
|
||||
|
||||
=item inheritance
|
||||
|
||||
Optional. Can be passed with a false value to override the checking of
|
||||
inheritance directories for files.
|
||||
|
||||
=back
|
||||
|
||||
=head2 tree
|
||||
|
||||
This method returns a list of directories that would be searched for a given
|
||||
file, in the order they would be searched. It takes the C<path>, C<local>, and
|
||||
C<inheritance> options above, but not the C<file> option.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::Template>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Inheritance.pm,v 1.7 2005/02/09 20:51:27 jagerman Exp $
|
||||
|
||||
=cut
|
||||
987
site/glist/lib/GT/Template/Parser.pm
Normal file
987
site/glist/lib/GT/Template/Parser.pm
Normal file
@@ -0,0 +1,987 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Template::Parser
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Parser.pm,v 2.140 2005/07/05 00:33:57 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# A module for parsing templates. This module actually generates
|
||||
# Perl code that will print the template.
|
||||
#
|
||||
|
||||
package GT::Template::Parser;
|
||||
# ===============================================================
|
||||
|
||||
use 5.004_04;
|
||||
use strict;
|
||||
|
||||
use GT::Base;
|
||||
use GT::Template;
|
||||
|
||||
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS %ESCAPE_MAP);
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 2.140 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ATTRIBS = { root => '.', indent => ' ', begin => '<%', end => '%>', print => 0 };
|
||||
$ERRORS = {
|
||||
NOTEMPLATE => "No template file was specified.",
|
||||
BADINC => $GT::Template::ERRORS->{BADINC},
|
||||
CANTOPEN => "Unable to open template file '%s': %s",
|
||||
DEEPINC => $GT::Template::ERRORS->{DEEPINC},
|
||||
EXTRAELSE => "Error: extra else tag",
|
||||
EXTRAELSIF => "Error: extra elsif/elseif tag",
|
||||
NOSCALAR => "Error: Variable '%s' is not scalar",
|
||||
UNMATCHEDELSE => "Error: Unmatched else tag",
|
||||
UNMATCHEDELSIF => "Error: Unmatched elsif/elseif tag",
|
||||
UNMATCHEDENDIF => "Error: Unmatched endif/endifnot/endunless tag",
|
||||
UNMATCHEDENDLOOP => "Error: endloop found outside of loop",
|
||||
UNMATCHEDNEXTLOOP => "Error: nextloop found outside of loop",
|
||||
UNMATCHEDLASTLOOP => "Error: lastloop found outside of loop",
|
||||
UNKNOWNTAG => $GT::Template::ERRORS->{UNKNOWNTAG},
|
||||
UNKNOWNINCLUDETAG => "Unknown tag in include: '%s'"
|
||||
};
|
||||
|
||||
use vars qw/%FILTERS $RE_FILTERS $RE_SET $RE_MATH $RE_EXPR/;
|
||||
|
||||
%FILTERS = (
|
||||
escape_html => '$tmp = GT::CGI::html_escape($tmp);',
|
||||
unescape_html => '$tmp = GT::CGI::html_unescape($tmp);',
|
||||
escape_url => '$tmp = GT::CGI::escape($tmp);',
|
||||
unescape_url => '$tmp = GT::CGI::unescape($tmp);',
|
||||
escape_js => q{$tmp =~ s{([\\\/'"])}{\\\$1}g; $tmp =~ s{(?:\r\n|\r|\n)}{\\\n}g;},
|
||||
nbsp => '$tmp =~ s/\s/ /g;'
|
||||
);
|
||||
@FILTERS{qw/escapeHTML unescapeHTML escapeURL unescapeURL escapeJS/} = @FILTERS{qw/escape_html unescape_html escape_url unescape_url escape_js/};
|
||||
for (qw/uc lc ucfirst lcfirst/) {
|
||||
$FILTERS{$_} = '$tmp = ' . $_ . '($tmp);';
|
||||
}
|
||||
$RE_FILTERS = '(?:(?:' . join('|', map quotemeta, keys %FILTERS) . ')\b\s*)+';
|
||||
|
||||
$RE_SET = q(set\s+(\w+(?:\.\$?\w+)*)\s*([-+*/%^.]|\bx|\|\||&&)?=\s*); # Two captures - the variable and the (optional) assignment modifier
|
||||
$RE_EXPR = qq{($RE_FILTERS)?('(?:[^\\\\']|\\\\.)*'|"(?:[^\\\\"]|\\\\.)*"|(?!$RE_FILTERS)[^\\s('"]+)}; # Two captures - the (optional) filters, and the value/variable
|
||||
$RE_MATH = q(\bx\b|/\d+(?=\s)|\bi/|[+*%~^/-]|\|\||&&);
|
||||
|
||||
sub parse {
|
||||
# ---------------------------------------------------------------
|
||||
# Can be called as either a class method or object method. This
|
||||
# returns three things - the first is a scalar reference to a string
|
||||
# containing all the perl code, the second is an array reference
|
||||
# of dependencies, and the third is the filetype of the template -
|
||||
# matching this regular expression: /^((INH:)*(REL|LOCAL)|STRING)$/.
|
||||
# For example, 'INH:INH:INH:INH:LOCAL', 'LOCAL', 'INH:REL', 'REL', or 'STRING'
|
||||
#
|
||||
my $self = ref $_[0] ? shift : (shift->new);
|
||||
my ($template, $opt, $print) = @_; # The third argument should only be used internally.
|
||||
defined $template or return $self->fatal(NOTEMPLATE => $template);
|
||||
defined $opt or $opt = {};
|
||||
|
||||
# Set print to 1 if we were called via parse_print.
|
||||
$opt->{print} = 1 if $print;
|
||||
|
||||
# Load the template which can either be a filename, or a string passed in.
|
||||
$self->{root} = $opt->{root} if $opt->{root};
|
||||
|
||||
my ($full, $string);
|
||||
my $type = '';
|
||||
if (exists $opt->{string}) {
|
||||
$full = $template;
|
||||
$string = $opt->{string};
|
||||
$type = "STRING";
|
||||
}
|
||||
else {
|
||||
require GT::Template::Inheritance;
|
||||
$full = GT::Template::Inheritance->get_path(path => $self->{root}, file => $template)
|
||||
or return $self->fatal(CANTOPEN => $template, "File does not exist.");
|
||||
}
|
||||
|
||||
my ($mtime, $size, $tpl) = (0, 0);
|
||||
if (defined $string) {
|
||||
$tpl = \$string;
|
||||
}
|
||||
else {
|
||||
($mtime, $size, $tpl) = $self->load_template($full);
|
||||
}
|
||||
|
||||
# Parse the template.
|
||||
$self->debug("Parsing '$template' (found '$full') with (print => $opt->{print})") if $self->{_debug};
|
||||
my @files = ([$template, $full, $mtime, $size]);
|
||||
my $code = $self->_parse($template, $opt, $tpl, \@files);
|
||||
|
||||
# Return the code, and an array reference of [filename, path, mtime, size] items
|
||||
return ($code, \@files);
|
||||
}
|
||||
|
||||
sub parse_print {
|
||||
# ---------------------------------------------------------------
|
||||
# Print output as template is parsed.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->parse(@_[0..1], 1)
|
||||
}
|
||||
|
||||
sub load_template {
|
||||
# ---------------------------------------------------------------
|
||||
# Loads either a given filename, or a template string, and returns a reference to it.
|
||||
#
|
||||
my ($self, $full_file) = @_;
|
||||
|
||||
$self->debug("Reading '$full_file'") if $self->{_debug};
|
||||
|
||||
-e $full_file or return $self->fatal(CANTOPEN => $full_file, "File does not exist.");
|
||||
local *TPL;
|
||||
open TPL, "< $full_file" or return $self->fatal(CANTOPEN => $full_file, "$!");
|
||||
my ($mtime, $size) = (stat TPL)[9, 7];
|
||||
my $ret = \do { local $/; <TPL> };
|
||||
close TPL;
|
||||
|
||||
return $mtime, $size, $ret;
|
||||
}
|
||||
|
||||
sub _parse {
|
||||
# ---------------------------------------------------------------
|
||||
# Parses a template.
|
||||
#
|
||||
my ($self, $template, $opt, $tpl, $files) = @_;
|
||||
|
||||
local $self->{opt} = {};
|
||||
$self->{opt}->{print} = exists $opt->{print} ? $opt->{print} : $self->{print};
|
||||
$self->{opt}->{indent} = exists $opt->{indent} ? $opt->{indent} : $self->{indent};
|
||||
|
||||
unless (defined $opt->{string}) {
|
||||
# Set the root if this is a full path so includes can be relative to template.
|
||||
if ((not $self->{root} or $self->{root} eq '.') and ((index($template, '/') == 0) or (index($template, ':') == 1))) {
|
||||
$self->{root} = substr($template, 0, rindex($template, '/'));
|
||||
substr($template, 0, rindex($template, '/') + 1) = '';
|
||||
}
|
||||
}
|
||||
|
||||
return $self->_parse_tags($tpl, $files);
|
||||
}
|
||||
|
||||
sub _text_escape {
|
||||
my $text = shift;
|
||||
$text =~ s/(\\(?=[{}\\]|$)|[{}])/\\$1/g;
|
||||
$text;
|
||||
}
|
||||
|
||||
sub _filter {
|
||||
my ($filter, $var) = @_;
|
||||
my $f = $FILTERS{$filter};
|
||||
$f =~ s/\$tmp\b/$var/g if $var;
|
||||
$f . " # $filter";
|
||||
}
|
||||
|
||||
sub _comment {
|
||||
my $comment = shift;
|
||||
$comment =~ s/^/#/gm;
|
||||
$comment . "\n";
|
||||
}
|
||||
|
||||
sub _parse_tags {
|
||||
# ---------------------------------------------------------------
|
||||
# Returns a string containing perl code that, when run (the code should be
|
||||
# passed a template object as its argument) will produce the template.
|
||||
# Specifically, the returned from this is a scalar reference (containing the
|
||||
# perl code) and an array reference of the file's dependencies.
|
||||
#
|
||||
my ($self, $tplref, $files) = @_;
|
||||
|
||||
my $tpl = $$tplref;
|
||||
|
||||
my $begin = quotemeta($self->{begin});
|
||||
my $end = quotemeta($self->{end});
|
||||
my $root = $self->{root};
|
||||
my $loop_depth = 0;
|
||||
my $i = -1;
|
||||
my @seen_else = ();
|
||||
my @if_level = ();
|
||||
my $print = $self->{opt}->{print};
|
||||
my $indent = $self->{opt}->{indent};
|
||||
my $indent_level = 0; # The file is already going to be in a hash
|
||||
|
||||
my %deps;
|
||||
|
||||
my $last_pos = 0;
|
||||
|
||||
# Can only go up to GT::Template::INCLUDE_LIMIT includes inside includes.
|
||||
my $include_safety = 0;
|
||||
# Store the "if" depth so that too many or too few <%endif%>'s in an include
|
||||
# won't break things:
|
||||
my @include_ifdepth;
|
||||
|
||||
my $return = <<'CODE';
|
||||
|
||||
local $^W; # Get rid of warnings. unfortunately, this won't work for Perl 5.6's -W switch
|
||||
my $self = shift;
|
||||
my $return = '';
|
||||
my $tags = $self->vars;
|
||||
my $escape = $self->{opt}->{escape};
|
||||
my $strict = $self->{opt}->{strict};
|
||||
my ($tmp, $tmp2, $tmp3);
|
||||
CODE
|
||||
|
||||
# We loop through the text looking for <% and %> tags, but also watching out for comments
|
||||
# <%-- some comment --%> as they can contain other tags.
|
||||
my $text = sub {
|
||||
my $text = shift;
|
||||
length $text or return;
|
||||
$return .= ($indent x ($indent_level)) . ($print ? q|print q{| : q|$return .= q{|);
|
||||
$return .= _text_escape($text) . q|};
|
||||
|; };
|
||||
|
||||
# $1 $2
|
||||
while ($tpl =~ /(\s*$begin\s*~\s*$end\s*|(?:\s*$begin\s*~|$begin)\s*(--.*?(?:--(?=\s*(?:~\s*)?$end)|$)|.+?)\s*(?:~\s*$end\s*|$end|$))/gs) {
|
||||
my $tag = $2;
|
||||
my $tag_len = length $1;
|
||||
my $print_start = $last_pos;
|
||||
$last_pos = pos $tpl;
|
||||
# Print out the text before the tag.
|
||||
$text->(substr($tpl, $print_start, $last_pos - $tag_len - $print_start));
|
||||
|
||||
next unless defined $tag; # Won't be defined for: <%~%>, which is a special cased no-op, whitespace reduction tag
|
||||
|
||||
# Handle nested comments
|
||||
if (substr($tag,0,2) eq '--') {
|
||||
my $save_pos = pos($tag);
|
||||
while ($tag =~ /\G.*?$begin\s*(?:~\s*)?--/gs) {
|
||||
$save_pos = pos($tag);
|
||||
my $tpl_save_pos = pos($tpl);
|
||||
if ($tpl =~ /\G(.*?--\s*(?:~\s*$end\s*|$end))/gs) {
|
||||
$tag .= $1;
|
||||
pos($tag) = $save_pos;
|
||||
$last_pos = pos($tpl);
|
||||
}
|
||||
else {
|
||||
$last_pos = pos($tpl) = length($tpl);
|
||||
$tag .= substr($tpl, $last_pos);
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
# Tag consists of only \w's and .'s - it's either a variable or some sort of
|
||||
# keyword (else, endif, etc.)
|
||||
elsif ($tag !~ /[^\w.]/) {
|
||||
|
||||
# 'else' - If $i is already at -1, we have an umatched tag.
|
||||
if ($tag eq 'else') {
|
||||
if ($i == -1 or $indent_level != $if_level[$i]) {
|
||||
$return .= _comment($ERRORS->{UNMATCHEDELSE});
|
||||
$text->($ERRORS->{UNMATCHEDELSE});
|
||||
}
|
||||
elsif ($seen_else[$i]++) {
|
||||
$return .= _comment($ERRORS->{EXTRAELSE});
|
||||
$text->($ERRORS->{EXTRAELSE});
|
||||
}
|
||||
else {
|
||||
$return .= $indent x ($indent_level - 1) . q|}
|
||||
|; $return .= $indent x ($indent_level - 1) . q|else {
|
||||
|; }
|
||||
}
|
||||
|
||||
# 'endif', 'endunless', 'endifnot' - decrement our level. If $i is already at -1, we have an umatched tag.
|
||||
elsif ($tag eq 'endif' or $tag eq 'endifnot' or $tag eq 'endunless') {
|
||||
if ($i == -1 or @include_ifdepth and $i <= $include_ifdepth[-1][0] or $indent_level != $if_level[$i]) {
|
||||
$return .= _comment($ERRORS->{UNMATCHEDENDIF});
|
||||
$text->($ERRORS->{UNMATCHEDENDIF});
|
||||
}
|
||||
else {
|
||||
--$i; --$#seen_else; --$#if_level; # for vim: {
|
||||
$return .= $indent x --$indent_level . q|}
|
||||
|; }
|
||||
}
|
||||
# 'endloop' - ends a loop
|
||||
elsif ($tag eq 'endloop') {
|
||||
if ($loop_depth <= 0) {
|
||||
$return .= _comment($ERRORS->{UNMATCHEDENDLOOP});
|
||||
$text->($ERRORS->{UNMATCHEDENDLOOP});
|
||||
}
|
||||
else {
|
||||
$loop_depth--; # for vim: {{{{
|
||||
$return .= $indent x --$indent_level . q|}
|
||||
|; $return .= $indent x --$indent_level . q|}
|
||||
|; $return .= $indent x --$indent_level . q|}
|
||||
|; $return .= $indent x $indent_level . q|for (keys %loop_set) { $self->{VARS}->{$_} = $orig->{$_} }
|
||||
|; $return .= $indent x --$indent_level . q|}
|
||||
|; }
|
||||
}
|
||||
# 'lastloop' - simply put in a last;
|
||||
elsif ($tag eq 'lastloop') {
|
||||
if ($loop_depth <= 0) {
|
||||
$return .= _comment($ERRORS->{UNMATCHEDLASTLOOP});
|
||||
$text->($ERRORS->{UNMATCHEDLASTLOOP});
|
||||
}
|
||||
else {
|
||||
$return .= $indent x $indent_level . q|last LOOP| . $loop_depth . q|;
|
||||
|; }
|
||||
}
|
||||
# 'nextloop' - simply put in a next;
|
||||
elsif ($tag eq 'nextloop') {
|
||||
if ($loop_depth <= 0) {
|
||||
$return .= _comment($ERRORS->{UNMATCHEDNEXTLOOP});
|
||||
$text->($ERRORS->{UNMATCHEDNEXTLOOP});
|
||||
}
|
||||
else {
|
||||
$return .= $indent x $indent_level . q|next;
|
||||
|; }
|
||||
}
|
||||
# 'endparse' - stops the parser.
|
||||
elsif ($tag eq 'endparse') {
|
||||
$return .= $indent x $indent_level . q|return | . ($print ? q|1| : q|\$return|) . q|;
|
||||
|; }
|
||||
# 'endinclude' - this is put at the end of an include when the include is inserted into the current template data.
|
||||
elsif ($tag eq 'endinclude') {
|
||||
if (@include_ifdepth) {
|
||||
while ($indent_level > $include_ifdepth[-1][1]) { # for vim: {
|
||||
$return .= ($indent x --$indent_level) . q|}
|
||||
|; }
|
||||
$i = $include_ifdepth[-1][0];
|
||||
}
|
||||
$include_safety--;
|
||||
pop @include_ifdepth; # for vim: {
|
||||
$return .= $indent x --$indent_level . q|} # Done include
|
||||
|; }
|
||||
elsif ($tag eq 'DUMP') {
|
||||
my $func = $self->_check_func('GT::Template::dump(-auto => 1)');
|
||||
$return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|
||||
|; }
|
||||
# Function call (without spaces)
|
||||
elsif (my $func = $self->_check_func($tag)) {
|
||||
$return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|
||||
|; }
|
||||
# Variable
|
||||
else {
|
||||
$return .= $indent x $indent_level;
|
||||
$return .= ($print ? q|print| : q|$return .=|) . q| $tmp if defined($tmp = $self->_get_var(q{| . _text_escape($tag) . q|}, $escape, $strict));
|
||||
|; }
|
||||
}
|
||||
# 'if', 'ifnot', 'unless', 'elsif', 'elseif'
|
||||
elsif ($tag =~ s/^(if(?:not)?|unless|else?if)\b\s*//) {
|
||||
my $op = $1;
|
||||
$op = "unless" if $op eq "ifnot";
|
||||
$op = "elsif" if $op eq "elseif";
|
||||
if ($op eq 'elsif') {
|
||||
if ($i == -1 or $indent_level != $if_level[$i]) {
|
||||
$return .= _comment($ERRORS->{UNMATCHEDELSIF});
|
||||
$text->($ERRORS->{UNMATCHEDELSIF});
|
||||
next;
|
||||
}
|
||||
elsif ($seen_else[$i]) {
|
||||
$return .= _comment($ERRORS->{EXTRAELSIF});
|
||||
$text->($ERRORS->{EXTRAELSIF});
|
||||
next;
|
||||
}
|
||||
# for vim: {
|
||||
$return .= $indent x ($indent_level - 1) . q|}
|
||||
|; $return .= $indent x ($indent_level - 1) . q|elsif (|;
|
||||
}
|
||||
else {
|
||||
$seen_else[++$i] = 0;
|
||||
$return .= $indent x $indent_level++;
|
||||
$return .= "$op (";
|
||||
$if_level[$i] = $indent_level;
|
||||
}
|
||||
|
||||
my @tests;
|
||||
my $bool = '';
|
||||
if ($tag =~ /\sor\s*(?:not)?\s/i) {
|
||||
@tests = grep $_, split /\s+or\s*(not)?\s+/i, $tag;
|
||||
$bool = ' or ';
|
||||
}
|
||||
elsif ($tag =~ /\sand\s*(?:not)?\s/i) {
|
||||
@tests = grep $_, split /\s+and\s*(not)?\s+/i, $tag;
|
||||
$bool = ' and ';
|
||||
}
|
||||
else {
|
||||
@tests = $tag;
|
||||
}
|
||||
if ($tests[0] =~ s/^not\s+//) {
|
||||
unshift @tests, "not";
|
||||
}
|
||||
my @all_tests;
|
||||
my $one_neg;
|
||||
for my $tag (@tests) {
|
||||
if ($tag eq 'not') {
|
||||
$one_neg = 1;
|
||||
next;
|
||||
}
|
||||
my $this_neg = $one_neg ? $one_neg-- : 0;
|
||||
$tag =~ s/^\$?([\w:.\$-]+)\b\s*// or next;
|
||||
my $var = $1;
|
||||
if (index($var, '::') > 0) {
|
||||
$var = $self->_check_func($var);
|
||||
}
|
||||
else {
|
||||
$var = q|$self->_get_var(q{| . _text_escape($var) . q|}, 0, 0)|;
|
||||
}
|
||||
my ($comp, $casei, $val);
|
||||
if (length($tag)) {
|
||||
if ($tag =~ s/^(==?|!=|>=?|<=?|%|(i?)(?:eq|ne|g[et]|l[et]))\s*//) { $casei = $2 ? 1 : 0; $comp = " " . ($casei ? substr($1, 1) : $1) . " " }
|
||||
elsif ($tag =~ s/^(i?)(?:like|contains)\s+//i) { $casei = $1 ? 1 : 0; $comp = "contains" }
|
||||
elsif ($tag =~ s/^(i?)(start|end)s?\s+//i) { $casei = $1 ? 1 : 0; $comp = $2 }
|
||||
$val = $tag if defined $comp;
|
||||
}
|
||||
$comp = ' == ' if $comp and $comp eq ' = ';
|
||||
my $full_comp = defined($comp);
|
||||
my $result = $this_neg ? 'not(' : '';
|
||||
if ($full_comp) {
|
||||
if (substr($val,0,1) eq '$') {
|
||||
substr($val,0,1) = '';
|
||||
$val = q|$self->_get_var(q{| . _text_escape($val) . q|}, 0, 0)|;
|
||||
}
|
||||
elsif ($val =~ /^['"]/) {
|
||||
$val = _quoted_string($val);
|
||||
}
|
||||
elsif (index($val, '::') > 0) {
|
||||
$val = $self->_check_func($val);
|
||||
}
|
||||
elsif ($val !~ /^[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?$/) {
|
||||
$val = "q{" . _text_escape($val) . "}";
|
||||
}
|
||||
if ($casei) {
|
||||
$val = "lc($val)";
|
||||
$var = "lc($var)";
|
||||
}
|
||||
if ($comp eq 'contains') {
|
||||
$result .= qq|index($var, $val) >= 0|;
|
||||
}
|
||||
elsif ($comp eq 'start') {
|
||||
$result .= qq|substr($var, 0, length $val) eq $val|;
|
||||
}
|
||||
elsif ($comp eq 'end') {
|
||||
$result .= qq|substr($var, -length $val) eq $val|;
|
||||
}
|
||||
elsif ($comp) {
|
||||
$result .= qq|$var $comp $val|;
|
||||
}
|
||||
}
|
||||
else { # Just a simple <%if var%> (Or something we don't understand, in which case we'll treat it like a simple <%if var%>)
|
||||
$result .= $var;
|
||||
}
|
||||
$result .= ")" if $this_neg;
|
||||
push @all_tests, $result;
|
||||
}
|
||||
my $final_result = join $bool, @all_tests;
|
||||
$return .= $final_result;
|
||||
$return .= q|) {
|
||||
|; # for vim: }
|
||||
}
|
||||
# 'loop' - <%loop var%>, <%loop Pkg::Func(arg, $arg => arg)%>, <%loop var(arg, $arg => arg)%>, <%loop 1 .. $end%>
|
||||
elsif ($tag =~ /^loop\s+(.+)/s) {
|
||||
$loop_depth++;
|
||||
my $loopon = $1;
|
||||
$return .= $self->_loop_on($loopon, $indent, $indent_level, $loop_depth);
|
||||
}
|
||||
# 'include $foo' - runtime includes based on variable value.
|
||||
elsif ($tag =~ /^include\s*\$(.*)/) {
|
||||
my $include_var = $1;
|
||||
$return .= $indent x $indent_level++;
|
||||
$return .= q|if (defined($tmp = $self->_get_var(q{| . _text_escape($include_var) . q|}, $escape))) {
|
||||
|; $return .= $indent x $indent_level . ($print ? 'print ' : '$return .= ');
|
||||
$return .= q|$self->_include(ref $tmp eq 'SCALAR' ? $$tmp : $escape ? GT::CGI::html_escape($tmp) : $tmp);
|
||||
|; $return .= $indent x ($indent_level - 1) . q|}
|
||||
|; $return .= $indent x ($indent_level - 1) . q|else {
|
||||
|; $return .= $indent x $indent_level; # for vim: }
|
||||
$return .= ($print ? q|print q{| : q|$return .= q{|) . _text_escape(sprintf($ERRORS->{UNKNOWNINCLUDETAG}, $include_var)) . q|};
|
||||
|; $return .= $indent x --$indent_level . q|}
|
||||
|; }
|
||||
# 'include' - load the file into the current template and continue parsing.
|
||||
# The template must be added to this template's dependancy list.
|
||||
# 'include $foo' is handled completely differently, above.
|
||||
elsif ($tag =~ /^include\b\s*([^\$].*)/) {
|
||||
my $include = $1;
|
||||
|
||||
# If inside an if, but not a loop, turn this into a runtime include, so that:
|
||||
# <%if foo%><%include bar.html%><%endif%>
|
||||
# is faster -- at least when foo is not set. Compile-time includes are still
|
||||
# faster (as long as they are actually used) - but not by a significant amount
|
||||
# unless inside a largish loop.
|
||||
if (!$loop_depth and $i > -1 and not ($include eq '.' or $include eq '..' or $include =~ m{[/\\]})) {
|
||||
$return .= $indent x $indent_level;
|
||||
$return .= ($print ? 'print' : '$return .=') . q| $self->_include(q{| . _text_escape($include) . q|}, 1);
|
||||
|; next;
|
||||
}
|
||||
|
||||
my $filename;
|
||||
if ($include =~ m{^(?:\w:)?[/\\]}) {
|
||||
$filename = $include;
|
||||
}
|
||||
else {
|
||||
require GT::Template::Inheritance;
|
||||
$filename = GT::Template::Inheritance->get_path(path => $root, file => $include);
|
||||
}
|
||||
|
||||
local *INCL;
|
||||
if ($filename and open INCL, "<$filename") {
|
||||
push @$files, [$include, $filename, (stat INCL)[9, 7]]; # mtime, size
|
||||
my $data = do { local $/; <INCL> };
|
||||
close INCL;
|
||||
substr($tpl, $last_pos - $tag_len, $tag_len) = $data . "$self->{begin}endinclude$self->{end}";
|
||||
$last_pos -= $tag_len;
|
||||
pos($tpl) = $last_pos;
|
||||
++$include_safety <= GT::Template::INCLUDE_LIMIT or return $self->fatal('DEEPINC');
|
||||
|
||||
$return .= $indent x $indent_level++ . q|{; | # The ; allows empty include files. for vim: }
|
||||
. _comment("Including $filename");
|
||||
|
||||
push @include_ifdepth, [$i, $indent_level];
|
||||
}
|
||||
else {
|
||||
push @$files, [$include, $filename, -1, -1];
|
||||
my $errfile = $filename || "$root/$include";
|
||||
$return .= _comment(sprintf($ERRORS->{BADINC}, $errfile, "$!" || 'File does not exist'));
|
||||
$text->(sprintf($ERRORS->{BADINC}, $errfile, "$!" || 'File does not exist'));
|
||||
}
|
||||
next;
|
||||
}
|
||||
# 'set' - set a value from the templates, optionally with a modifier (i.e. set
|
||||
# foo = 4 vs. set foo += 4), also look for things like <%... x ...%>, <%... ~
|
||||
# ...%>, etc., optionally with a 'set' on the front. Filters are permitted as
|
||||
# well.
|
||||
#
|
||||
# $1-3 $4, $5 $6 $7, $8 $9 $10 $11
|
||||
elsif ($tag =~ m{^(?:($RE_SET)(?:$RE_EXPR\s*($RE_MATH))?|$RE_EXPR\s*($RE_MATH))\s*($RE_FILTERS)?(.+)}os) {
|
||||
# $set is set if this is a 'set' (set foo = 3) as opposed to merely a modifier (foo + 3)
|
||||
# $setvar is the variable to set (obviously only if $set is set)
|
||||
# $change is set if this is a modifier assignment (i.e. 'set foo += 3' as opposed to 'set foo = 3')
|
||||
# $var is the value to set in a multi-value expression - i.e. bar in 'set foo = bar + 3', but undefined in 'set foo = $bar'
|
||||
# or 'set foo = 3' - it can be a variable (i.e. without a $) or quoted string.
|
||||
# $var_filters are any filters that apply to $var, such as the 'escape_html' in 'set foo = escape_html $bar x 5'
|
||||
# $comp is the modifer to the value - such as the 'x' in 'set foo = $bar x 3'
|
||||
# $val is the actual value to set, and is the only parameter common to all cases handled here. It can be a $variable,
|
||||
# quoted string, or bareword string.
|
||||
# $val_filters are any filters to apply to $val
|
||||
my ($set, $setvar, $change, $var_filters, $var, $comp);
|
||||
my ($val_filters, $val) = ($10, $11);
|
||||
if ($1) {
|
||||
($set, $setvar, $change, $var_filters, $var, $comp) = ($1, $2, $3 || '', $4, $5, $6);
|
||||
}
|
||||
else {
|
||||
($var_filters, $var, $comp) = ($7, $8, $9);
|
||||
}
|
||||
|
||||
if (defined $var) {
|
||||
if ($var =~ /^['"]/) {
|
||||
$var = _quoted_string($var);
|
||||
}
|
||||
else {
|
||||
substr($var,0,1) = '' if substr($var,0,1) eq '$';
|
||||
$var = q|$self->_get_var(q{| . _text_escape($var) . q|})|;
|
||||
}
|
||||
|
||||
if ($var_filters) {
|
||||
$return .= $indent x $indent_level;
|
||||
$return .= "\$tmp2 = $var;\n";
|
||||
$var = '$tmp2';
|
||||
for (reverse split ' ', $var_filters) {
|
||||
$return .= $indent x $indent_level;
|
||||
$return .= _filter($_, '$tmp2') . "\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (substr($val,0,1) eq '$') {
|
||||
substr($val,0,1) = '';
|
||||
$val = q|$self->_get_var(q{| . _text_escape($val) . q|})|;
|
||||
}
|
||||
elsif ($val =~ /^['"]/) {
|
||||
$val = _quoted_string($val);
|
||||
}
|
||||
elsif (my $funccode = $self->_check_func($val)) {
|
||||
$val = q|(| . $funccode . q< || '')>;
|
||||
}
|
||||
else {
|
||||
$val = q|q{| . _text_escape($val) . q|}|;
|
||||
}
|
||||
if ($val_filters) {
|
||||
$return .= $indent x $indent_level;
|
||||
$return .= "\$tmp3 = $val;\n";
|
||||
$val = '$tmp3';
|
||||
for (reverse split ' ', $val_filters) {
|
||||
$return .= $indent x $indent_level;
|
||||
$return .= _filter($_, '$tmp3') . "\n";
|
||||
}
|
||||
}
|
||||
|
||||
my $calc;
|
||||
if ($set and not defined $var) {
|
||||
$calc = $val;
|
||||
}
|
||||
else {
|
||||
$calc = _math($var, $comp, $val);
|
||||
}
|
||||
|
||||
$return .= $indent x $indent_level;
|
||||
if ($set) {
|
||||
$return .= q|$tags->{q{| . _text_escape($setvar) . q|}} = \do { my $none = (|;
|
||||
|
||||
if ($change) {
|
||||
# Passing $escape is required here, because what we save back
|
||||
# is always a reference, thus the escaping has to occur here.
|
||||
# $strict, however, is NOT passed because we aren't interested
|
||||
# in variables becoming "Unknown tag: '....'"-type values.
|
||||
$return .= _math(q|$self->_get_var(q{| . _text_escape($setvar) . q|}, $escape)|, $change, $calc);
|
||||
}
|
||||
else {
|
||||
$return .= $calc;
|
||||
}
|
||||
$return .= ') }';
|
||||
}
|
||||
else {
|
||||
$return .= ($print ? 'print ' : q|$return .= |) . $calc;
|
||||
}
|
||||
|
||||
$return .= qq|;
|
||||
|; }
|
||||
# Filters: 'escape_url', 'unescape_url', 'escape_html', 'unescape_html', 'escape_js', 'uc', 'ucfirst', 'lc', 'lcfirst', 'nbsp'
|
||||
elsif ($tag =~ /^($RE_FILTERS)(\S+)/o) {
|
||||
my $var = $2;
|
||||
my @filters = reverse split ' ', $1;
|
||||
|
||||
$return .= $indent x $indent_level++;
|
||||
$return .= q|if (($tmp) = $self->_raw_value(q{| . _text_escape($var) . q|})) {
|
||||
|; $return .= $indent x $indent_level;
|
||||
$return .= q|$tmp = $$tmp if ref $tmp eq 'SCALAR' or ref $tmp eq 'LVALUE';
|
||||
|; $return .= $indent x $indent_level++;
|
||||
$return .= q|if (ref $tmp) {
|
||||
|; $return .= $indent x $indent_level;
|
||||
$text->(sprintf $ERRORS->{NOSCALAR}, $var);
|
||||
$return .= $indent x ($indent_level - 1) . q|}
|
||||
|; $return .= $indent x ($indent_level - 1) . q|else {
|
||||
|; $return .= $indent x $indent_level;
|
||||
$return .= q|$tmp = $self->_get_var(q{| . _text_escape($var) . q|}, $escape);
|
||||
|; for (@filters) {
|
||||
$return .= $indent x $indent_level;
|
||||
$return .= _filter($_) . "\n";
|
||||
}
|
||||
$return .= $indent x $indent_level;
|
||||
$return .= ($print ? q|print| : q|$return .=|) . q| $tmp;
|
||||
|; $return .= $indent x --$indent_level . q|}
|
||||
|; $return .= $indent x ($indent_level - 1) . q|}
|
||||
|; $return .= $indent x ($indent_level - 1) . q|else {
|
||||
|; $return .= $indent x $indent_level;
|
||||
$text->(sprintf $ERRORS->{UNKNOWNTAG}, $var);
|
||||
$return .= $indent x --$indent_level . q|}
|
||||
|; }
|
||||
# 'DUMP variable'
|
||||
elsif ($tag =~ /^DUMP\s+\$?(\w+(?:\.\$?\w+)*)$/) {
|
||||
my $func = qq{\$self->_call_func('GT::Template::dump', -auto => 1, -var => '$1')};
|
||||
$return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|
||||
|; }
|
||||
elsif (my $func = $self->_check_func($tag)) {
|
||||
$return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|
||||
|; }
|
||||
else {
|
||||
# Check to see if it's a valid variable, function call, etc. Force
|
||||
# strict on because this is some sort of strange tag that doesn't
|
||||
# appear to be a variable, which should always produce an "Unknown
|
||||
# tag" warning.
|
||||
$return .= $indent x $indent_level;
|
||||
$return .= ($print ? q|print| : q|$return .=|) . q| $tmp if defined($tmp = $self->_get_var(q{| . _text_escape($tag) . q|}, $escape, 1));
|
||||
|; }
|
||||
}
|
||||
$text->(substr($tpl, $last_pos));
|
||||
while ($indent_level > 0) {
|
||||
$return .= ($indent x --$indent_level) . q|}
|
||||
| }
|
||||
$return .= $print ? q|return 1;| : q|return \$return;|;
|
||||
return \$return;
|
||||
}
|
||||
|
||||
# Handles quoted string semantics.
|
||||
#
|
||||
# Inside double-quote strings:
|
||||
# \ can preceed any non-word character to mean the character itself - following
|
||||
# word characters the following escapes are currently supported: \n, \r, \t,
|
||||
# \000 (octal character value), \x00 (hex character value). \ followed by any
|
||||
# other word character is undefined behaviour and should not be used.
|
||||
# Variables are interpolated - you can write a variable as $foo.bar or
|
||||
# ${foo.bar}. Inner-variable interpolation (such as what happens in
|
||||
# <%foo.$bar%> is supported only in the latter form: ${foo.$bar} - $foo.$bar
|
||||
# would end up becoming the value of foo, a ., then the value of bar.
|
||||
#
|
||||
# Inside single-quote strings:
|
||||
# \ can preceed \ or ' to mean the value; preceeding anything else a \ is a
|
||||
# literal \
|
||||
%ESCAPE_MAP = (
|
||||
t => '\t',
|
||||
n => '\n',
|
||||
r => '\r',
|
||||
);
|
||||
sub _quoted_string {
|
||||
my $string = shift;
|
||||
if ($string =~ s/^"//) {
|
||||
$string =~ s/"$//;
|
||||
$string =~ s[
|
||||
(\\) # $1 A backslash escape of some sort
|
||||
(?:
|
||||
(x[0-9a-fA-F]{2}) # $2 - \x5b - a hex char
|
||||
|
|
||||
([0-7]{1,3}) # $3 - \123 - an octal char
|
||||
|
|
||||
(\w) # $4 - a word char - \n, \t, etc.
|
||||
|
|
||||
(\W) # $5 - a non word char - \\, \", etc.
|
||||
)
|
||||
|
|
||||
\$ # The dollar sign that starts a variable
|
||||
(?:
|
||||
{ # opening { in a ${var}-style variable ## vim: }
|
||||
(\w+(?:\.\$?\w+)*) # $6 - the inner part of a ${var} variable
|
||||
}
|
||||
|
|
||||
(\w+) # $7 - the name of a $var-style variable
|
||||
)
|
||||
|
|
||||
([{}\\]) # $8 - a character that needs to be escaped inside the q{}-delimited string - the \\ will only
|
||||
# match at the very end of the string - though "string\" isn't really valid.
|
||||
][
|
||||
if ($1) { # a \ escape
|
||||
if (my $code = $2 || $3) {
|
||||
qq|}."\\$code".q{|;
|
||||
}
|
||||
elsif (exists $ESCAPE_MAP{$4}) {
|
||||
qq|}."$ESCAPE_MAP{$4}".q{|;
|
||||
}
|
||||
elsif (defined $4) {
|
||||
qq|}."$4".q{|;
|
||||
}
|
||||
else {
|
||||
qq|}."\\$5".q{|;
|
||||
}
|
||||
}
|
||||
elsif ($8) {
|
||||
"\\$8"
|
||||
}
|
||||
else { # A variable
|
||||
my $variable = $6 || $7;
|
||||
q|}.$self->_get_var(q{| . _text_escape($variable) . q|}).q{|;
|
||||
}
|
||||
]egsx;
|
||||
}
|
||||
elsif ($string =~ s/^'//) {
|
||||
$string =~ s/'$//;
|
||||
$string =~ s/\\(['\\])/$1/g;
|
||||
$string = _text_escape($string);
|
||||
}
|
||||
"q{$string}";
|
||||
}
|
||||
sub _math {
|
||||
my ($left, $comp, $right) = @_; # var => left, val => right
|
||||
my $calc;
|
||||
if ($comp =~ /^[.*+-]$/ or $comp eq '||' or $comp eq '&&') { $calc = "+(($left) $comp ($right))" }
|
||||
elsif ($comp =~ m{^/(\d+)$}) { $calc = "+sprintf(q{%.$1f}, (((\$tmp = ($right)) != 0) ? (($left) / \$tmp) : 0))" }
|
||||
elsif ($comp eq '/') { $calc = "+(((\$tmp = ($right)) != 0) ? ($left / \$tmp) : 0)" }
|
||||
elsif ($comp eq 'i/') { $calc = "int(((\$tmp = ($right)) != 0) ? (int($left) / int(\$tmp)) : 0)" }
|
||||
elsif ($comp eq '%') { $calc = "+(((\$tmp = ($right)) != 0) ? ($left % \$tmp) : 0)" }
|
||||
elsif ($comp eq '~') { $calc = "+(((\$tmp = ($right)) != 0) ? (\$tmp - ($left % \$tmp)) : 1)" }
|
||||
elsif ($comp eq '^') { $calc = "+(($left) ** ($right))" }
|
||||
elsif ($comp eq 'x') { $calc = "+(scalar($left) x ($right))" }
|
||||
$calc ||= '';
|
||||
$calc;
|
||||
}
|
||||
|
||||
sub _loop_on {
|
||||
my ($self, $on, $indent, $indent_level, $loop_depth) = @_;
|
||||
|
||||
my $var;
|
||||
|
||||
if ($on =~ /^(\d+|\$[\w.\$-]+)\s+(?:\.\.|to)\s+(\d+|\$[\w.\$-]+)$/) {
|
||||
my ($start, $end) = ($1, $2);
|
||||
for ($start, $end) {
|
||||
$_ = q|int(do { my $v = $self->_get_var(q{| . _text_escape($_) . q|}); ref $v ? 0 : $v })|
|
||||
if s/^\$//;
|
||||
}
|
||||
$var = "[$start .. $end]";
|
||||
}
|
||||
elsif (index($on, '::') > 0 or index($on, '(') > 0) {
|
||||
$var = $self->_check_func($on);
|
||||
}
|
||||
else {
|
||||
$on =~ s/^\$//;
|
||||
$var = q|$self->_raw_value(q{| . _text_escape($on) . q|})|;
|
||||
}
|
||||
|
||||
my $print = $self->{opt}->{print};
|
||||
my $i0 = $indent x $indent_level;
|
||||
my $i = $indent x ($indent_level + 1);
|
||||
my $i____ = $indent x ($indent_level + 2);
|
||||
my $i________ = $indent x ($indent_level + 3);
|
||||
my $i____________ = $indent x ($indent_level + 4);
|
||||
my $i________________ = $indent x ($indent_level + 5);
|
||||
my $return = <<CODE;
|
||||
${i0}\{
|
||||
${i}my \$orig = {\%{\$self->{VARS}}};
|
||||
${i}my %loop_set;
|
||||
${i}LOOP$loop_depth: \{
|
||||
${i____}my \$loop_var = $var;
|
||||
${i____}my \$loop_type = ref \$loop_var;
|
||||
${i____}if (\$loop_type eq 'CODE' or \$loop_type eq 'ARRAY') {
|
||||
${i________}my \$next;
|
||||
${i________}my \$row_num = 0;
|
||||
${i________}my \$i = 0;
|
||||
${i________}my \$current = \$loop_type eq 'CODE' ? \$loop_var->() : \$loop_var->[\$i++];
|
||||
${i________}if (ref \$current eq 'ARRAY') {
|
||||
${i____________}\$loop_type = 'ARRAY';
|
||||
${i____________}\$loop_var = \$current;
|
||||
${i____________}\$current = \$loop_var->[\$i++];
|
||||
${i________}}
|
||||
${i________}while (defined \$current) {
|
||||
${i____________}if (\$loop_type eq 'CODE') {
|
||||
${i________________}\$next = \$loop_var->();
|
||||
${i____________}}
|
||||
${i____________}else {
|
||||
${i________________}\$next = \$loop_var->[\$i++];
|
||||
${i____________}}
|
||||
${i____________}my \$copy = {\%{\$self->{VARS}}};
|
||||
${i____________}for (keys %loop_set) {
|
||||
${i________________}\$copy->{\$_} = \$orig->{\$_};
|
||||
${i________________}delete \$loop_set{\$_};
|
||||
${i____________}}
|
||||
${i____________}for (qw/row_num first last inner even odd loop_value/, keys \%\$current) { \$loop_set{\$_} = 1 }
|
||||
${i____________}\$copy->{row_num} = ++\$row_num;
|
||||
${i____________}\$copy->{first} = (\$row_num == 1) || 0;
|
||||
${i____________}\$copy->{last} = (!\$next) || 0;
|
||||
${i____________}\$copy->{inner} = (!\$copy->{first} and !\$copy->{last}) || 0;
|
||||
${i____________}\$copy->{even} = (\$row_num % 2 == 0) || 0;
|
||||
${i____________}\$copy->{odd} = (not \$copy->{even}) || 0;
|
||||
${i____________}if (ref \$current ne 'HASH') { \$current = { loop_value => \$current } }
|
||||
${i____________}else { \$loop_set{loop_value} = 1; \$copy->{loop_value} = \$current }
|
||||
${i____________}for (keys \%\$current) { \$copy->{\$_} = \$current->{\$_} }
|
||||
${i____________}\$self->{VARS} = \$copy;
|
||||
${i____________}\$current = \$next;
|
||||
|
||||
CODE
|
||||
$_[3] += 4; # Update the indent level
|
||||
return $return;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub _check_func {
|
||||
# ---------------------------------------------------------------
|
||||
# Takes a string and if it looks like a function, returns a string
|
||||
# that will call the function with the appropriate arguments.
|
||||
#
|
||||
# So, you enter the tag (without the <% and %>):
|
||||
# <%GFoo::function($foo, $bar, $boo, $far, '7', 'text')%>
|
||||
# and you'll get back:
|
||||
|
||||
|
||||
# $self->_call_func('GFoo::function', $self->_get_var(q{foo},0,0), $self->_get_var(q{bar},0,0), ..., q{7}, q{text});
|
||||
|
||||
|
||||
# <%codevar($foo, $bar, $boo, $far => 7, text)%>
|
||||
# $self->_call_func('codevar', $self->_get_var(q{foo},0,0), $self->_get_var(q{bar},0,0), ..., q{7}, q{text});
|
||||
|
||||
|
||||
# NOTE: NO SEMICOLON (;) ON THE END
|
||||
# which will require GFoo and call GFoo::function with the arguments provided.
|
||||
#
|
||||
# If you call this with a tag that doesn't look like a function, undef is returned.
|
||||
#
|
||||
my ($self, $str) = @_;
|
||||
my $ret;
|
||||
if (((index($str, '(') >= 0 and rindex($str, ')') >= 0) or index($str, '::') >= 1) and $str =~ /^
|
||||
(?:
|
||||
# Package $1
|
||||
(
|
||||
\w+
|
||||
(?:
|
||||
::
|
||||
\w+
|
||||
)*
|
||||
)
|
||||
::
|
||||
)?
|
||||
# Function $2
|
||||
(
|
||||
\w+
|
||||
)
|
||||
\s*
|
||||
# Any possible arguments
|
||||
(?:
|
||||
\(
|
||||
\s*
|
||||
(
|
||||
.+? # Arguments list $3
|
||||
)?
|
||||
\s*
|
||||
\)
|
||||
)?
|
||||
$/sx) {
|
||||
my ($package, $func, $args) = ($1, $2, $3);
|
||||
$ret = '';
|
||||
$args = '' if not defined $args;
|
||||
|
||||
$args = join ", ", _parse_args($args) if length $args;
|
||||
|
||||
$ret = q|$self->_call_func('| . ($package ? "$package\::$func" : $func) . q|'|;
|
||||
$ret .= ", $args" if $args;
|
||||
$ret .= ")";
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub _parse_args {
|
||||
# --------------------------------------------------------
|
||||
# Splits up arguments on commas outside of quotes. Unquotes
|
||||
#
|
||||
my $line = shift;
|
||||
my ($word, @pieces);
|
||||
local $^W;
|
||||
while (length $line) {
|
||||
my ($quoted, undef, $bareword, $delim) = $line =~ m{
|
||||
^
|
||||
(?:
|
||||
( # $quoted test
|
||||
(["']) # the actual quote
|
||||
(?:\\.|(?!\2)[^\\])* # the text
|
||||
\2 # followed by the same quote
|
||||
)
|
||||
| # --OR--
|
||||
((?:\\.|[^\\"'])*?) # $bareword text, plus:
|
||||
( # $delim
|
||||
\Z(?!\n) # EOL
|
||||
|
|
||||
\s*(?:,|=>)\s* # delimiter
|
||||
|
|
||||
(?!^)(?=["']) # or quote
|
||||
)
|
||||
)
|
||||
(.*) # and the rest ($+)
|
||||
}sx;
|
||||
return unless $quoted or length $bareword or length $delim;
|
||||
|
||||
$line = $+;
|
||||
|
||||
my $val;
|
||||
if ($quoted) {
|
||||
$val = _quoted_string($quoted);
|
||||
}
|
||||
elsif ($bareword =~ s/^\$//) {
|
||||
$val = q|$self->_get_var(q{| . _text_escape($bareword) . q|},0,0)|;
|
||||
}
|
||||
elsif (length $bareword) {
|
||||
$bareword =~ s/\\(.)/$1/g;
|
||||
$val = q|q{| . _text_escape($bareword) . q|}|;
|
||||
}
|
||||
|
||||
$word = $word ? "$word.$val" : $val if defined $val;
|
||||
|
||||
if (length $delim) {
|
||||
push @pieces, $word;
|
||||
$word = undef;
|
||||
}
|
||||
}
|
||||
push @pieces, $word if defined $word;
|
||||
return @pieces;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
198
site/glist/lib/GT/Template/Vars.pm
Normal file
198
site/glist/lib/GT/Template/Vars.pm
Normal file
@@ -0,0 +1,198 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Template::Vars
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Vars.pm,v 1.3 2005/03/05 01:17:20 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# GT::Template variable handling tied hash reference.
|
||||
#
|
||||
|
||||
package GT::Template::Vars;
|
||||
use strict;
|
||||
use Carp 'croak';
|
||||
|
||||
sub TIEHASH {
|
||||
my ($class, $tpl) = @_;
|
||||
|
||||
my $self = { t => $tpl, keys => [] };
|
||||
bless $self, ref $class || $class;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my ($self, $key, $value) = @_;
|
||||
if ($key =~ /^\w+(?:\.\$?\w+)+$/) {
|
||||
my $cur = \$self->{t}->{VARS};
|
||||
my @set = split /\./, $key;
|
||||
for (my $i = 0; $i < @set; $i++) {
|
||||
if ($set[$i] =~ /^\$/) {
|
||||
my $val = $self->{t}->_get_var(substr($set[$i], 1));
|
||||
$val = '' if not defined $val;
|
||||
my @pieces = split /\./, $val;
|
||||
@pieces = '' if !@pieces;
|
||||
splice @set, $i, 1, @pieces;
|
||||
$i += @pieces - 1 if @pieces > 1;
|
||||
}
|
||||
}
|
||||
while (@set) {
|
||||
my $k = shift @set;
|
||||
if ($k =~ s/^\$//) {
|
||||
$k = '' . ($self->FETCH($k) || '');
|
||||
}
|
||||
if ($k =~ /^\d+$/ and ref $$cur eq 'ARRAY') {
|
||||
$cur = \$$cur->[$k];
|
||||
}
|
||||
elsif (ref $$cur eq 'HASH' or not defined $$cur or UNIVERSAL::isa($$cur, 'GT::Config')) {
|
||||
$cur = \$$cur->{$k};
|
||||
}
|
||||
elsif (UNIVERSAL::isa($$cur, 'GT::CGI') and !@set) {
|
||||
# You can set a GT::CGI parameter, but only to a scalar value (or reference to a scalar value)
|
||||
return $$cur->param(
|
||||
$k => ((ref $value eq 'SCALAR' or ref $value eq 'LVALUE') and not ref $$value) ? $$value : "$value"
|
||||
);
|
||||
}
|
||||
else {
|
||||
croak 'Not a HASH reference';
|
||||
}
|
||||
}
|
||||
$$cur = $value;
|
||||
}
|
||||
else {
|
||||
$self->{t}->{VARS}->{$key} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
# Fetching wraps around _get_var, using the template parser's escape value.
|
||||
# Strict is never passed because we want $tags->{foo} to be false if it isn't
|
||||
# set, instead of "Unknown tag 'foo'". In cases where overriding escape is
|
||||
# necessary, _get_var is used directly. _get_var's fourth argument is used
|
||||
# here to avoid a potential infinite loop caused by recalling code references
|
||||
# when their value is implicitly retrieved (for example, in a "while-each"
|
||||
# loop).
|
||||
sub FETCH {
|
||||
my ($self, $key) = @_;
|
||||
my $value = $self->{t}->_raw_value($key, 1);
|
||||
$value = $$value if ref $value eq 'SCALAR' or ref $value eq 'LVALUE';
|
||||
return $value;
|
||||
}
|
||||
|
||||
# Keys/exists are a little strange - if "foo" is set to { a => 1 }, exists
|
||||
# $tags->{"foo.a"} will be true, but only "foo", not "foo.a", will be returned
|
||||
# by keys %$tags.
|
||||
sub FIRSTKEY {
|
||||
my $self = shift;
|
||||
my @keys;
|
||||
for (keys %{$self->{t}->{VARS}}) {
|
||||
push @keys, $_;
|
||||
}
|
||||
for (keys %{$self->{t}->{ALIAS}}) {
|
||||
push @keys, $_ unless exists $self->{t}->{VARS}->{$_};
|
||||
}
|
||||
|
||||
$self->{keys} = \@keys;
|
||||
|
||||
return shift @keys;
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my ($self, $key) = @_;
|
||||
my @val = $self->{t}->_raw_value($key);
|
||||
return !!@val;
|
||||
}
|
||||
|
||||
sub NEXTKEY {
|
||||
my $self = shift;
|
||||
if (!$self->{keys}) {
|
||||
return $self->FIRSTKEY;
|
||||
}
|
||||
elsif (!@{$self->{keys}}) {
|
||||
delete $self->{keys};
|
||||
return;
|
||||
}
|
||||
return shift @{$self->{keys}};
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $key) = @_;
|
||||
my $value = $self->FETCH($key);
|
||||
delete $self->{t}->{VARS}->{$key};
|
||||
$value;
|
||||
}
|
||||
sub CLEAR { %{$_[0]->{t}->{VARS}} = () }
|
||||
sub SCALAR { scalar %{$_[0]->{t}->{VARS}} }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Template::Vars - Tied hash for template tags handling
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $vars = GT::Template->vars;
|
||||
print $vars->{foo};
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is designed to provide a simple interface to GT::Template tags from
|
||||
Perl code. Prior to this module, the tags() method of GT::Template returned a
|
||||
hash reference which could contain all sorts of different values - scalar
|
||||
references, LVALUE references, GT::Config objects, etc. This new interface
|
||||
provides a tied hash reference designed to aid in retrieving and setting values
|
||||
in the same way template variables are retrieved and set from templates.
|
||||
|
||||
=head1 INTERFACE
|
||||
|
||||
=head2 Accessing values
|
||||
|
||||
Accessing a value is simple - just access C<$vars-E<gt>{name}>. The regular
|
||||
rules of escaping apply here: if the value would have been HTML-escaped in the
|
||||
template, it will be escaped when you get it.
|
||||
|
||||
=head2 Setting values
|
||||
|
||||
Setting a value is easy - simply do: C<$vars-E<gt>{name} = $value;>. "name"
|
||||
can be anything GT::Template recognises as a variable, so
|
||||
C<$vars-E<gt>{'name.key'}> would set C<-E<gt>{name}-E<gt>{key}> (see
|
||||
L<GT::Template::Tutorial/"Advanced variables using references"> for more
|
||||
information on complex variables).
|
||||
|
||||
The regular rules of escaping apply here: if escaping is turned on, a value you
|
||||
set will be escaped when accessed again via $vars or in a template. If you
|
||||
want to set a tag containing raw HTML, you should set a scalar reference, such
|
||||
as: C<$vars-E<gt>{name} = \$value;>.
|
||||
|
||||
=head2 Keys, Exists
|
||||
|
||||
You can use C<keys %$vars> to get a list of keys of the tag object, but you
|
||||
should note that while C<$vars-E<gt>{"a.b"}> is valid and
|
||||
C<exists $vars-E<gt>{"a.b"}> may return true, it will B<not> be present in the
|
||||
list of keys returned by C<keys %$vars>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::Template>
|
||||
|
||||
L<GT::Template::Tutorial>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Vars.pm,v 1.3 2005/03/05 01:17:20 jagerman Exp $
|
||||
|
||||
=cut
|
||||
213
site/glist/lib/GT/Text/Tools.pm
Normal file
213
site/glist/lib/GT/Text/Tools.pm
Normal file
@@ -0,0 +1,213 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Text::Tools
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Tools.pm,v 1.9 2005/06/09 23:42:16 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose text parsing module.
|
||||
#
|
||||
package GT::Text::Tools;
|
||||
# ==================================================================
|
||||
# Pragmas
|
||||
use strict;
|
||||
|
||||
# Internal mules
|
||||
use bases 'GT::Base' => '';
|
||||
|
||||
sub linesplit {
|
||||
# --------------------------------------------------------------------
|
||||
# my @words = GT::Text::Tools->linesplit($regex, $line);
|
||||
# ------------------------------------------------------
|
||||
# Splits $line by $regex outside of quotes ['"]
|
||||
# If regex is false defaults to \s+.
|
||||
#
|
||||
|
||||
# Ganged and modified from Text::ParseWords
|
||||
local $^W;
|
||||
|
||||
my ($class, $delimiter, $line) = @_;
|
||||
$delimiter ||= '\s+';
|
||||
$delimiter =~ s/(\s)/\\$1/g;
|
||||
my ($quote, $quoted, $unquoted, $delim, $word, @pieces);
|
||||
|
||||
while (length($line)) {
|
||||
|
||||
($quote, $quoted, undef, $unquoted, $delim, undef) =
|
||||
$line =~ m/^(["']) # a $quote
|
||||
((?:\\.|(?!\1)[^\\])*) # and $quoted text
|
||||
\1 # followed by the same quote
|
||||
([\000-\377]*) # and the rest
|
||||
| # --OR--
|
||||
^((?:\\.|[^\\"'])*?) # an $unquoted text
|
||||
(\Z(?!\n)|(?:$delimiter)|(?!^)(?=["']))
|
||||
# plus EOL, delimiter, or quote
|
||||
([\000-\377]*) # the rest
|
||||
/x; # extended layout
|
||||
return () unless ( $quote || length($unquoted) || length($delim));
|
||||
|
||||
$line = $+;
|
||||
|
||||
$quoted = "$quote$quoted$quote";
|
||||
$word .= defined $quote ? $quoted : $unquoted;
|
||||
|
||||
if (length($delim)) {
|
||||
push(@pieces, $word);
|
||||
undef $word;
|
||||
}
|
||||
if (!length($line)) {
|
||||
push(@pieces, $word);
|
||||
}
|
||||
}
|
||||
return (@pieces);
|
||||
}
|
||||
|
||||
sub linewrap {
|
||||
# --------------------------------------------------------------------
|
||||
# GT::Text::Tools->linewrap( $string, $number, {
|
||||
# nowrap => $regexs,
|
||||
# eol => "\n",
|
||||
# max_line_length => 50000
|
||||
# });
|
||||
# ----------------------------------------------
|
||||
# linewrap takes a string, a number of characters per line and a
|
||||
# hash ref of options. String will be wrapped to the number of
|
||||
# characters specified on spaces.
|
||||
# The following options apply:
|
||||
# nowrap => array ref of regexes that if matched, will
|
||||
# not be wrapped.
|
||||
# eol => What to wrap the lines with, defaults to
|
||||
# \n.
|
||||
# eol_match => What to use to match eol characters; defaults to
|
||||
# \r?\n
|
||||
# max_line_length => The maximum length a line can be that will
|
||||
# be wrapped on a space. Any line reaching
|
||||
# this length will be wrapped without
|
||||
# looking for spaces. Defaults to 50_000, set
|
||||
# to non-true value to avoid this affect.
|
||||
#
|
||||
my ($class, $string, $i, $opts) = @_;
|
||||
my $max_len = exists($opts->{max_line_length}) ? $opts->{max_line_length} : 50_000;
|
||||
my $regexs = $opts->{nowrap} || [];
|
||||
my $nl = $opts->{eol} || "\n";
|
||||
my $eolre = $opts->{eol_match} || "\r?\n";
|
||||
$regexs = (ref($regexs) eq 'ARRAY') ? $regexs : [$regexs || ()];
|
||||
my @t = split /$eolre/, $string;
|
||||
my $r = "";
|
||||
while (@t) {
|
||||
my $match = 0;
|
||||
if (length $t[0] <= $i) {
|
||||
$r .= shift(@t) . $nl;
|
||||
$match = 1;
|
||||
}
|
||||
elsif ($t[0] =~ /^\s*$/) {
|
||||
my $spaces = shift @t;
|
||||
# Keep the string of spaces unless it's too long (don't bother wrapping them)
|
||||
$r .= (length $spaces <= $i ? $spaces : '') . $nl;
|
||||
$match = 1;
|
||||
}
|
||||
elsif ($max_len and length $t[0] > $max_len) { # Line is too long.
|
||||
my $line = shift @t;
|
||||
while ($line) {
|
||||
$r .= substr($line, 0, $i) . $nl;
|
||||
substr($line, 0, $i) = '';
|
||||
}
|
||||
$match = 1;
|
||||
}
|
||||
elsif (@{$regexs}) {
|
||||
my $regex = join('|', @{$regexs});
|
||||
if ($t[0] =~ m/$regex/) {
|
||||
my $eos = ''; # Store any incomplete lines
|
||||
while ($t[0] =~ s/^(.*?)(\s?)((?:$regex)\s?)//) {
|
||||
my $pre = _wrap($i, $nl, $eos . $1);
|
||||
$eos = '';
|
||||
my $s = $2 || '';
|
||||
my $mat = $3;
|
||||
|
||||
if (!length($pre) or $pre =~ /$nl$/) {
|
||||
$r .= $pre;
|
||||
if (length $mat > $i) {
|
||||
$r .= $mat . $nl;
|
||||
}
|
||||
else {
|
||||
$eos = $mat;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$pre =~ s/($nl|^)(.*?)$//;
|
||||
$r .= $pre . $1;
|
||||
my $leftover = $2;
|
||||
|
||||
if (length($leftover . $s . $mat) <= $i) {
|
||||
$eos = $leftover . $s . $mat;
|
||||
}
|
||||
else {
|
||||
$r .= $leftover . $nl;
|
||||
if (length $mat > $i) {
|
||||
$r .= $mat . $nl;
|
||||
}
|
||||
else {
|
||||
$eos = $mat;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
$eos .= $t[0] if length $t[0];
|
||||
if (length $eos) {
|
||||
$r .= _wrap($i, $nl, $eos) . $nl;
|
||||
}
|
||||
shift(@t);
|
||||
$match = 1;
|
||||
}
|
||||
}
|
||||
next if $match;
|
||||
$r .= _wrap($i, $nl, shift(@t) || '') . $nl;
|
||||
}
|
||||
return $r;
|
||||
}
|
||||
|
||||
sub _wrap {
|
||||
# --------------------------------------------------------------------
|
||||
# _wrap($length, $newline, $string);
|
||||
# ----------------------------
|
||||
# Internal method called by linewrap() to wrap a line.
|
||||
#
|
||||
my ($i, $e);
|
||||
$i = $e = shift;
|
||||
my $nl = shift;
|
||||
my $r;
|
||||
defined $_[0] or return '';
|
||||
if (length $_[0] < $i) { return $_[0]; }
|
||||
while (@_) {
|
||||
defined($_[0]) or last;
|
||||
if ($_[0] =~ /^(.{$i})\s(.+)$/) {
|
||||
shift() and $r .= $1 . $nl;
|
||||
$i = $e;
|
||||
if (defined($2) and length($2) <= $e) {
|
||||
$r .= $2;
|
||||
$r .= $nl if length($2) == $e;
|
||||
}
|
||||
else {
|
||||
unshift(@_, $2);
|
||||
}
|
||||
}
|
||||
elsif ($i-- == 0) {
|
||||
$i = $e;
|
||||
shift() =~ /^(.{$i})(.+)$/ and $r .= $1 . $nl;
|
||||
if (defined($2) and length($2) <= $e) {
|
||||
$r .= $2;
|
||||
$r .= $nl if length($2) == $e;
|
||||
}
|
||||
else {
|
||||
unshift(@_, $2)
|
||||
}
|
||||
}
|
||||
}
|
||||
return defined($r) ? $r : '';
|
||||
}
|
||||
|
||||
1;
|
||||
1116
site/glist/lib/GT/WWW.pm
Normal file
1116
site/glist/lib/GT/WWW.pm
Normal file
File diff suppressed because it is too large
Load Diff
1430
site/glist/lib/GT/WWW/http.pm
Normal file
1430
site/glist/lib/GT/WWW/http.pm
Normal file
File diff suppressed because it is too large
Load Diff
649
site/glist/lib/GT/WWW/http/Header.pm
Normal file
649
site/glist/lib/GT/WWW/http/Header.pm
Normal file
@@ -0,0 +1,649 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::WWW::http::Header
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Header.pm,v 1.8 2004/02/17 01:33:08 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Header object for GT::WWW::http request/response headers.
|
||||
#
|
||||
|
||||
package GT::WWW::http::Header;
|
||||
use strict;
|
||||
|
||||
use Carp;
|
||||
use GT::Socket::Client qw/CRLF/;
|
||||
use overload
|
||||
'""' => \&format_headers,
|
||||
bool => \&boolean;
|
||||
|
||||
my $ctls = '\x00-\x1f\x7f'; # Control characters (CTL in HTTP 1.1 RFC 2616)
|
||||
my $ctls_without_tab = '\x00-\x08\x0a-\x1f\x7f';
|
||||
my $separators = '()<>@,;:\\\\"/\[\]?={} \t'; # Separators
|
||||
my $token = "[^$ctls$separators]"; # HTTP "token" (RFC 2616)
|
||||
my $quoted_string = qq{"((?:\\\\.|[^$ctls_without_tab"])*)"}; # HTTP 1.1 quoted-string.
|
||||
|
||||
my %Private;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class if ref $class;
|
||||
my $self = [];
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
sub boolean { 1 } # So you can you do things like: $header or die
|
||||
|
||||
# Adds one or more headers. Takes a list of headers => value pairs.
|
||||
# Without arguments, returns a list of all header names.
|
||||
# With just one argument, returns all value(s) for that header (case-
|
||||
# insensitive).
|
||||
# When setting headers, you can pass in an array reference for the header
|
||||
# value. The array will be passed as a list to join_words, and the return used
|
||||
# as the header value.
|
||||
|
||||
# Sets a _join_words separator to something other than , - typically ;
|
||||
sub _separator {
|
||||
my ($self, $sep) = @_;
|
||||
$Private{$self}->{separator} = $sep if $sep;
|
||||
}
|
||||
# Forces _join_words to put "quotes" around values. You should call this, add
|
||||
# the header that needs the quotes, then call ->_unforce_quotes;.
|
||||
sub _force_quotes {
|
||||
my $self = shift;
|
||||
$Private{$self}->{force_quotes} = 1;
|
||||
}
|
||||
sub _unforce_quotes {
|
||||
my $self = shift;
|
||||
$Private{$self}->{force_quotes} = 0;
|
||||
}
|
||||
|
||||
sub header {
|
||||
my $self = shift;
|
||||
if (@_ == 1) {
|
||||
# Requesting a header, ie. $obj->header("Content-Type")
|
||||
my $header = lc shift;
|
||||
my @return;
|
||||
for (my $i = 0; $i < @$self; $i += 2) {
|
||||
if (lc $self->[$i] eq $header) {
|
||||
push @return, $self->[$i + 1];
|
||||
last unless wantarray;
|
||||
}
|
||||
}
|
||||
return wantarray ? @return : $return[0];
|
||||
}
|
||||
elsif (@_) {
|
||||
@_ % 2 and croak "Invalid parameters to header: Odd number of elements passed to header()";
|
||||
|
||||
while (@_) {
|
||||
my ($k, $v) = splice @_, 0, 2;
|
||||
if (ref $v eq 'ARRAY') {
|
||||
$v = $self->join_words(@$v);
|
||||
}
|
||||
push @$self, $k, $v;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
my @return;
|
||||
for (my $i = 0; $i < @$self; $i++) {
|
||||
push @return, $self->[$i];
|
||||
}
|
||||
return @return;
|
||||
}
|
||||
}
|
||||
|
||||
sub header_words {
|
||||
my ($self, $header) = @_;
|
||||
$header or croak "Usage: \$header->header_words(HEADER_NAME)";
|
||||
|
||||
my @result;
|
||||
for (my $i = 0; $i < @$self; $i += 2) {
|
||||
if (lc $self->[$i] eq lc $header) {
|
||||
push @result, $self->split_words($self->[$i + 1]);
|
||||
}
|
||||
}
|
||||
|
||||
return @result;
|
||||
}
|
||||
|
||||
sub split_words {
|
||||
shift if $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my $str = shift or return ();
|
||||
my @result;
|
||||
# Pretend $str is: video/x-mng,image/png, foo=bar, image/gif;q=0.3,asdf/zxcv="y,uc;k";q="0.2";blah="a;b,c",*/*;q=0.1
|
||||
while (length $str) {
|
||||
if ($str =~ s/^\s*([^$ctls\s=,;]+)\s*//) { # parameter 'token' or 'attribute'
|
||||
push @result, $1;
|
||||
|
||||
my @val;
|
||||
# The goal here is to get this array containing (given the above example) undef for
|
||||
# "video/x-mng", "bar" for "foo", [undef, "q", "0.3"] for "image/gif",
|
||||
# ["y,uc;k", "q", "0.2", "blah", "a;b,c"] for "asdf/zxcv".
|
||||
|
||||
# First, handle an = clause, such as '=bar', or '="y,uc;k"'
|
||||
if ($str =~ s/^=\s*$quoted_string//) { # quoted string (e.g. "y,uc;k")
|
||||
(my $val = $1) =~ s/\\(.)/$1/g;
|
||||
push @val, $val;
|
||||
}
|
||||
elsif ($str =~ s/^=\s*([^$ctls\s;,]*)//) { # some unquoted value (e.g. bar)
|
||||
push @val, $1;
|
||||
}
|
||||
else {
|
||||
push @val, undef;
|
||||
}
|
||||
|
||||
# Now look for continuing values (e.g. ;q="0.2";blah="a;b,c")
|
||||
while ($str =~ s/^;([^$ctls\s=,;]+)\s*//) {
|
||||
push @val, $1;
|
||||
# Look for an = clause, such as ="a;b,c"
|
||||
if ($str =~ s/^=\s*$quoted_string//) { # quoted string (e.g. "a;b,c")
|
||||
(my $val = $1) =~ s/\\(.)/$1/g;
|
||||
push @val, $val;
|
||||
}
|
||||
elsif ($str =~ s/^=\s*([^$ctls\s;,]*)//) { # some unquoted value (e.g. bar)
|
||||
push @val, $1;
|
||||
}
|
||||
else {
|
||||
push @val, undef;
|
||||
}
|
||||
}
|
||||
|
||||
push @result, @val == 1 ? $val[0] : \@val;
|
||||
}
|
||||
elsif ($str !~ s/^\s*[,;\s]//) {
|
||||
local $" = "|";
|
||||
die "Invalid header encountered: '$str' (Found \@result=(@result))";
|
||||
}
|
||||
}
|
||||
|
||||
@result;
|
||||
}
|
||||
|
||||
# Takes a header and header word, and returns true if the header word is
|
||||
# present in the header. For example,
|
||||
# $header->contains(Expect => '100-continue')
|
||||
# will return true for the header:
|
||||
# Expect: foo=bar, 100-continue, bar=foo
|
||||
sub contains {
|
||||
my ($self, $header, $word) = @_;
|
||||
$header and $word or croak 'Usage: $header->contains(Header => Header_Word)';
|
||||
|
||||
my @words = $self->header_words($header);
|
||||
for (my $i = 0; $i < @words; $i += 2) {
|
||||
if ($words[$i] eq $word) {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub join_words {
|
||||
my $self;
|
||||
$self = shift if $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my @words = @_;
|
||||
my @encoded;
|
||||
for (my $i = 0; $i < @words; $i += 2) {
|
||||
my ($k, $v) = @words[$i, $i + 1];
|
||||
my @pairs = ($k, ref $v eq 'ARRAY' ? @$v : $v);
|
||||
|
||||
@pairs % 2 and croak "Invalid composite value passed in for word '$k': Even number of elements in array ref";
|
||||
|
||||
my @str;
|
||||
while (@pairs) {
|
||||
my ($word, $value) = splice @pairs, 0, 2;
|
||||
$word =~ /^[^$ctls\s=;,]+$/
|
||||
or croak "Unable to join: word contains invalid characters: '$word'";
|
||||
my $str = $word;
|
||||
if (defined $value) {
|
||||
$value =~ /[$ctls_without_tab]/
|
||||
and croak "Unable to join: word value for word '$word' contains control characters: '$value'";
|
||||
$str .= '=';
|
||||
if ((not $self or not $Private{$self}->{force_quotes}) and $value =~ /^$token+$/) {
|
||||
# If it only contains "token" characters, we don't need to quote it
|
||||
$str .= $value;
|
||||
}
|
||||
else {
|
||||
$value =~ s/([\\"])/\\$1/g;
|
||||
$str .= qq'"$value"';
|
||||
}
|
||||
}
|
||||
|
||||
push @str, $str;
|
||||
}
|
||||
|
||||
push @encoded, join ';', @str;
|
||||
|
||||
}
|
||||
|
||||
return join "$Private{$self}->{separator} ", @encoded
|
||||
if $self and $Private{$self}->{separator};
|
||||
|
||||
return join ', ', @encoded;
|
||||
}
|
||||
|
||||
# Deletes a word from a header's value. If the word is present more than once,
|
||||
# all forms are removed. Returned is, in scalar context, an integer indicating
|
||||
# how many headers were removed (0 for no words (or no header) found). In list
|
||||
# context, you get a list of all the values removed, or undef for valueless
|
||||
# words.
|
||||
sub delete_header_word {
|
||||
my ($self, $header, $word) = @_;
|
||||
my @ret;
|
||||
$header and $word or croak 'Usage: $header->delete_header_word(HEADER, WORD)';
|
||||
for (my $i = 0; $i < @$self; $i += 2) {
|
||||
if (lc $self->[$i] eq lc $header) {
|
||||
my @words = $self->split_words($self->[$i + 1]);
|
||||
my $found;
|
||||
for (my $j = 0; $j < @words; $j += 2) {
|
||||
if ($words[$j] eq $word) {
|
||||
$found++;
|
||||
push @ret, $words[$j + 1];
|
||||
splice @words, $j, 2;
|
||||
$j -= 2;
|
||||
}
|
||||
}
|
||||
if ($found and @words) {
|
||||
$self->[$i + 1] = $self->join_words(@words);
|
||||
}
|
||||
elsif ($found) { # This header contains only the header word
|
||||
splice @$self, $i, 2;
|
||||
$i -= 2;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ret; # If the sub is called in scalar context, so is this
|
||||
}
|
||||
|
||||
# Just like header(), but first deletes the headers to be added. Hence,
|
||||
# $obj->replace_header($obj->header) should be a no-op.
|
||||
sub replace_header {
|
||||
my $self = shift;
|
||||
croak "Invalid parameters to replace_header: \$obj->replace_header(KEY => VALUE[, KEY => VALUE, ...]);"
|
||||
if !@_ or @_ % 2;
|
||||
my %headers;
|
||||
for (my $i = 0; $i < @_; $i += 2) {
|
||||
$headers{$_[$i]}++;
|
||||
}
|
||||
$self->delete_header(keys %headers);
|
||||
|
||||
$self->header(@_);
|
||||
}
|
||||
|
||||
sub format_headers {
|
||||
my $self = shift;
|
||||
return '' if !@$self;
|
||||
my $return = '';
|
||||
for (my $i = 0; $i < @$self; $i += 2) {
|
||||
my ($key, $value) = @$self[$i, $i + 1];
|
||||
# Valid characters from HTTP/1.1 RFC, section 4.2 (page 32)
|
||||
$key =~ s|([$ctls$separators()<>@,;:\\"/\[\]?={} \t])|sprintf "%%%02X", ord $1|eg;
|
||||
$value =~ s|([$ctls])|sprintf "%%%02X", ord $1|eg;
|
||||
$return .= "$key: $value" . CRLF;
|
||||
}
|
||||
$return .= CRLF;
|
||||
return $return;
|
||||
}
|
||||
|
||||
# Clears all headers set for the current object.
|
||||
sub clear_headers {
|
||||
my $self = shift;
|
||||
$#$self = -1;
|
||||
return;
|
||||
}
|
||||
|
||||
# Deletes one or more headers. Takes a list of headers to remove.
|
||||
sub delete_header {
|
||||
my ($self, @headers) = @_;
|
||||
return 0 unless @$self;
|
||||
my $headers = join "|", map quotemeta, @headers;
|
||||
my $found;
|
||||
for (my $i = 0; $i < @$self; $i += 2) {
|
||||
if ($self->[$i] =~ /^(?:$headers)$/i) {
|
||||
splice @$self, $i, 2;
|
||||
$i -= 2;
|
||||
$found++;
|
||||
}
|
||||
}
|
||||
return $found;
|
||||
}
|
||||
|
||||
DESTROY {
|
||||
my $self = shift;
|
||||
delete $Private{$self};
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::WWW::http::Header - Module for GT::WWW::http request/response headers.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Typically:
|
||||
|
||||
# Assuming $www is a GT::WWW::http object
|
||||
my $request_header = $www->header;
|
||||
|
||||
# Set a header:
|
||||
$request_header->header('Some-Http-Header' => 'Header value');
|
||||
|
||||
# After making a request:
|
||||
my $response_header = $www->response->header;
|
||||
# -- or --
|
||||
my $response_header = $response->header; # $response is the return of, e.g. $www->get
|
||||
|
||||
Much more advanced headers can be set and determined, using the various methods
|
||||
available as described below.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides an easy to use yet powerful header retrieval/manipulation
|
||||
object suitable for most HTTP headers.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
First, a note about the methods described which add/change/delete headers: such
|
||||
methods should only be called on a request header, and only before making a
|
||||
request. Although nothing prevents you from making changes to the request
|
||||
header after having made the request, or from changing the headers of a
|
||||
response header object, such behaviour should be considered very bad practise
|
||||
and is B<strongly> discouraged.
|
||||
|
||||
=head2 header
|
||||
|
||||
This is the most commonly used method as it is used both to add and retrieve
|
||||
headers, depending on its usage. The examples below assume the following
|
||||
header:
|
||||
|
||||
Date: Sun, 12 Jan 2003 08:21:21 GMT
|
||||
Server: Apache
|
||||
Keep-Alive: timeout=15, max=100
|
||||
Connection: Keep-Alive
|
||||
Content-Type: text/html
|
||||
Content-Encoding: gzip
|
||||
Content-Length: 3215
|
||||
X-Foo: bar1
|
||||
X-Foo: bar2, bar3
|
||||
|
||||
With no arguments, a list of all the header names is returned. Given the
|
||||
example, the following list would be returned:
|
||||
|
||||
('Date', 'Server', 'Keep-Alive', 'Connection', 'Content-Type', 'Content-Encoding', 'Content-Length', 'X-Foo', 'X-Foo')
|
||||
|
||||
With a single argument, a list of value(s) for headers of that name are
|
||||
returned. In scalar context, only the first value is returned. In list
|
||||
context, a list of all values is returned. Note that the header named passed
|
||||
in is case-insensitive.
|
||||
|
||||
my $server = $header->header('server'); # returns 'Apache'
|
||||
my $foo = $header->header('X-Foo'); # returns 'bar1'
|
||||
my @foo = $header->header('x-Foo'); # returns ('bar1', 'bar2, bar3')
|
||||
|
||||
Finally, when more than one argument is provided, header values are set. At
|
||||
its simplest level, it takes a list of key => value pairs (NOT a hash, since
|
||||
duplicate keys are possible) of headers to set. So, to set the headers
|
||||
'Server' and 'Content-Length' above at once, you could call:
|
||||
|
||||
$header->header(Server => 'Apache', 'Content-Length' => 3215);
|
||||
|
||||
Or, if you prefer:
|
||||
|
||||
$header->header(Server => 'Apache');
|
||||
$header->header('Content-Length' => 3215);
|
||||
|
||||
Note that the order in which headers are added is preserved, for times when the
|
||||
order of headers is important.
|
||||
|
||||
|
||||
B<WARNING>: Before reading the below information, you should first know that it
|
||||
describes advanced usage of the header() method and requires have a grasp of
|
||||
the intricacies of HTTP headers; the following is _not_ required knowledge for
|
||||
typical GT::WWW use.
|
||||
|
||||
Consider the above Keep-Alive header an example. Instead of specifying:
|
||||
|
||||
$header->header('Keep-Alive' => 'timeout=15, max=100');
|
||||
|
||||
you could alternately write it as:
|
||||
|
||||
$header->header('Keep-Alive' => [timeout => 15, max => 100]);
|
||||
|
||||
This allows you a more pragmatic approach when you already have some sort of
|
||||
data structure of the header options. You can go a step further with this, by
|
||||
specifying C<undef> as the value:
|
||||
|
||||
# Set the second X-Foo header in the example:
|
||||
$header->header('X-Foo' => [bar2 => undef, bar3 => undef]);
|
||||
|
||||
header() also allows you to set values such as:
|
||||
|
||||
image/gif;q=0.2
|
||||
|
||||
As can be seen in this example:
|
||||
|
||||
Accept: image/png,image/jpeg,image/gif;q=0.2,*/*;q=0.1
|
||||
|
||||
To do so, specify the suboption value as another array reference. The first
|
||||
element of the array reference is usually undef, while the remaining are the
|
||||
k=v pairs in the segment. So, in the above header, the 'image/gif;q=0.2' section
|
||||
would be specified as:
|
||||
|
||||
'image/gif' => [undef, q => 0.2]
|
||||
|
||||
(If a segment such as "foo=bar;bar=foo" is ever needed, the C<undef> would be
|
||||
changed to C<"bar">.)
|
||||
|
||||
So, piecing it all together, the Accept header shown above could be specified
|
||||
like this:
|
||||
|
||||
$header->header(
|
||||
Accept => [
|
||||
'image/png' => undef,
|
||||
'image/jpeg' => undef,
|
||||
'image/gif' => [undef, q => 0.2],
|
||||
'*/*' => [undef, q => 0.1]
|
||||
]
|
||||
);
|
||||
|
||||
|
||||
=head2 header_words
|
||||
|
||||
When you need to see it a header value contains a particular "word", this
|
||||
method is the one to use. As an example, consider this header:
|
||||
|
||||
X-Foo: bar, bar2, bar3
|
||||
|
||||
In order to determine whether or not "bar2" has been specified as an X-Foo
|
||||
value, you could attempt some sort of regex - or you could just call this
|
||||
method. The return value splits up the header in such a way as to be useful to
|
||||
determine the exact information contained within the header.
|
||||
|
||||
The method takes a case-insensitive header name, just like the single-argument
|
||||
form of header().
|
||||
|
||||
A even-numbered hash-I<like> list is always returned - though each element of
|
||||
that list depends on the content of the header. First of all, if the header
|
||||
specified does not exist, you'll get an empty list back.
|
||||
|
||||
Assuming that the header does exist, it will first be broken up by C<,>.
|
||||
|
||||
The even-indexed (0, 2, 4, ...) elements of the list are the keys, while the
|
||||
odd numbered elements are the values associated with those keys - or undef if
|
||||
there is no value (as above; an example with values is shown below).
|
||||
|
||||
So, using the above X-Foo header example, calling this method with C<'X-Foo'>
|
||||
as an argument would give you back the list:
|
||||
|
||||
(bar => undef, bar2 => undef, bar3 => undef)
|
||||
|
||||
Getting a little more complicated, consider the following header:
|
||||
|
||||
X-Foo: bar, bar2=foo, bar3
|
||||
|
||||
Because of the "=foo" part, the list returned would now be:
|
||||
|
||||
(bar => undef, bar2 => "foo", bar3 => undef)
|
||||
|
||||
Quoting of values is also permitted, so the following would be parsed correctly
|
||||
with C<'1;2,3=4"5\6'> being the value of bar2:
|
||||
|
||||
X-Foo: bar, bar2="1;2,3=4\"5\\6", bar3
|
||||
|
||||
Getting more complicated, this method also handles complex values containing
|
||||
more than one piece of information. A good example of this is in content type
|
||||
weighting used by most browsers. As a real life example (generated by
|
||||
the Phoenix web browser):
|
||||
|
||||
Accept: video/x-mng,image/png,image/jpeg,image/gif;q=0.2,*/*;q=0.1
|
||||
|
||||
Working that into the X-Foo example, consider this header:
|
||||
|
||||
X-Foo: bar, bar2=foo, bar3;foo1=24;foo2=10
|
||||
|
||||
In this case, the value for bar3 will become an array reference to handle the
|
||||
multiple pieces of information in the third part:
|
||||
|
||||
(bar => undef, bar2 => "foo", bar3 => [undef, foo1 => 24, foo2 => 10])
|
||||
|
||||
(If you've read the advanced section of the L<C<header()>|/header>
|
||||
documentation, and this looks familiar, you're right - the return value of this
|
||||
function, if put in an array reference, is completely compatible with a
|
||||
header() value.)
|
||||
|
||||
The C<undef> value at the beginning of the array reference is rarely anything other
|
||||
than C<undef>, but it I<could> be, if a header such as this were encountered:
|
||||
|
||||
X-Foo: bar=foo,foo1=10
|
||||
|
||||
That would return:
|
||||
|
||||
(bar => ["foo", foo1 => 10])
|
||||
|
||||
One additional thing to note is that header_words() returns the header words
|
||||
for B<all> matching headers. Thus if the following two headers were set:
|
||||
|
||||
X-Foo: bar, bar2=foo
|
||||
X-Foo: bar3
|
||||
|
||||
You would get the same return as if this header was set (shown above):
|
||||
|
||||
X-Foo: bar, bar2=foo, bar3
|
||||
|
||||
|
||||
A good example usage of this is for a file download. To get the filename, you
|
||||
would do something like:
|
||||
|
||||
my %cd = $header->header_words('Content-Disposition');
|
||||
my $filename;
|
||||
if ($cd{filename}) { $filename = $cd{filename} }
|
||||
else { $filename = "unknown" }
|
||||
|
||||
=head2 split_words
|
||||
|
||||
This can be called as object method, class method, or function - it takes a
|
||||
single argument, a string, which it proceeds to split up as described for the
|
||||
above header_words() method. Note that this knows nothing about header names -
|
||||
it simply knows how to break a header value into the above format.
|
||||
|
||||
This method is used internally by header_words(), but can be used separately if
|
||||
desired.
|
||||
|
||||
=head2 contains
|
||||
|
||||
This method takes two arguments: a header, and a header word. It returns true
|
||||
if the header word passed is found in the header specified. For example, the
|
||||
following would return true:
|
||||
|
||||
$header->contains('X-Foo' => 'bar2')
|
||||
|
||||
for any of these headers:
|
||||
|
||||
X-Foo: bar2
|
||||
X-Foo: bar, bar2, bar3
|
||||
X-Foo: bar, bar2=10, bar3
|
||||
X-Foo: bar, bar2=10;q=0.3, bar3
|
||||
|
||||
but not for either of these:
|
||||
|
||||
X-Foo: bar, bar3=bar2
|
||||
X-Foo: bar, bar3;bar2=10
|
||||
|
||||
=head2 join_words
|
||||
|
||||
join_words() does the opposite of split_words(). That is, it takes a value such
|
||||
as might be returned by split_words(), and joins it up properly, quoting if
|
||||
necessary. This is called internally when creating the actual header, and can
|
||||
be called separately at a method or function if desired.
|
||||
|
||||
=head2 delete_header_word
|
||||
|
||||
This takes a header and header word, and proceeds to remove any occurances of
|
||||
the header word from the header specified.
|
||||
|
||||
After calling:
|
||||
|
||||
$header->delete_header_word('X-Foo', 'bar2');
|
||||
|
||||
this header:
|
||||
|
||||
X-Foo: bar, bar2;foo=bar, bar3
|
||||
|
||||
would become:
|
||||
|
||||
X-Foo: bar, bar3
|
||||
|
||||
=head2 delete_header
|
||||
|
||||
This takes a list of header names. The headers specified are completely
|
||||
removed.
|
||||
|
||||
=head2 replace_header
|
||||
|
||||
This 2 or more arguments in exactly the same way as header(), however all the
|
||||
specified headers are deleted (assuming they exist) before being readded.
|
||||
|
||||
=head2 format_headers
|
||||
|
||||
This returns a properly formatted (lines are CRLF delimited) header. If you
|
||||
use the header as a string (i.e. C<"$header">), this method will be internally
|
||||
called, and so generally does not need to be called directly.
|
||||
|
||||
The returned string has the final blank line that identifies the end of the
|
||||
header.
|
||||
|
||||
=head2 clear_headers
|
||||
|
||||
This deletes all headers.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::WWW::http>
|
||||
L<GT::WWW>
|
||||
RFC 2616: L<http://www.ietf.org/rfc/rfc2616.txt>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Header.pm,v 1.8 2004/02/17 01:33:08 jagerman Exp $
|
||||
|
||||
=cut
|
||||
263
site/glist/lib/GT/WWW/http/Response.pm
Normal file
263
site/glist/lib/GT/WWW/http/Response.pm
Normal file
@@ -0,0 +1,263 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::WWW::http::Response
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Response.pm,v 1.8 2004/08/04 19:23:07 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Response object for GT::WWW HTTP/HTTPS requests.
|
||||
#
|
||||
|
||||
package GT::WWW::http::Response;
|
||||
use strict;
|
||||
|
||||
use vars qw/$AUTOLOAD/;
|
||||
use overload
|
||||
'""' => \&content,
|
||||
bool => \&boolean,
|
||||
cmp => \&strcmp;
|
||||
use Carp;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class if ref $class;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
AUTOLOAD {
|
||||
my ($self, @args) = @_;
|
||||
my ($attr) = $AUTOLOAD =~ /([^:]+)$/;
|
||||
if (@args) {
|
||||
$self->{$attr} = shift @args;
|
||||
}
|
||||
$self->{$attr};
|
||||
}
|
||||
|
||||
sub content { $_[0]->{content} }
|
||||
|
||||
sub boolean { 1 } # So you can you do things like: $www->get() or die
|
||||
|
||||
sub status {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my ($num, $str) = @_;
|
||||
$self->{status} = GT::WWW::http::Response::Status->new($num, $str);
|
||||
}
|
||||
$self->{status};
|
||||
}
|
||||
|
||||
sub header {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{header}->header(@_);
|
||||
}
|
||||
else {
|
||||
$self->{header};
|
||||
}
|
||||
}
|
||||
|
||||
sub strcmp { $_[2] ? $_[1] cmp $_[0]->{content} : $_[0]->{content} cmp $_[1] }
|
||||
|
||||
package GT::WWW::http::Response::Status;
|
||||
|
||||
use overload
|
||||
'""' => \&string,
|
||||
bool => \&boolean,
|
||||
'0+' => \&numeric,
|
||||
'+' => \&addition,
|
||||
'<=>' => \&numcmp,
|
||||
'cmp' => \&strcmp;
|
||||
|
||||
sub new {
|
||||
my ($class, $numeric, $string) = @_;
|
||||
my $self = [$numeric, $string];
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
sub numeric { $_[0]->[0] }
|
||||
sub string { "$_[0]->[0] $_[0]->[1]" }
|
||||
sub boolean { substr($_[0]->[0], 0, 1) eq '2' }
|
||||
sub addition { int($_[0]) + int($_[1]) }
|
||||
sub numcmp { $_[2] ? $_[1] <=> $_[0]->[0] : $_[0]->[0] <=> $_[1] }
|
||||
sub strcmp { $_[2] ? $_[1] cmp $_[0]->[1] : $_[0]->[1] cmp $_[1] }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::WWW::http::Response and GT::WWW::http::Response::Status - Overloaded
|
||||
response objects for HTTP request data.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# ($www is continued from GT::WWW::http SYNOPSIS)
|
||||
|
||||
my $response = $www->get(); # or post(), or head()
|
||||
# -- or, after having called get(), post() or head(): --
|
||||
my $response = $www->response();
|
||||
|
||||
my $status = $response->status();
|
||||
|
||||
my $content = "$response";
|
||||
my $response_code = int($status); # i.e. 200, 404, 500
|
||||
my $response_str = "$status"; # i.e. 'OK', 'Not Found', 'Internal Server Error'
|
||||
if ($status) { # True for 2xx requests, false otherwise (e.g. 404, 500, etc.)
|
||||
...
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::WWW::http::Response objects are returned by the L<C<get()>|GT::WWW/get>,
|
||||
L<C<post()>|GT::WWW/post>, and L<C<head()>|GT::WWW/head> methods of GT::WWW
|
||||
HTTP requests (and derivatives - i.e. HTTPS), or by calling
|
||||
L<C<response()>|GT::WWW::http/response> after having made such a request. The
|
||||
objects are overloaded in order to provide a simple interface to the response,
|
||||
while still having all the information available.
|
||||
|
||||
A response object always returns true in boolean context, allowing you to do
|
||||
things like C<$www-E<gt>get($url) or die;> - even when a page is empty, or
|
||||
contains just '0'.
|
||||
|
||||
=head1 CONTENT
|
||||
|
||||
In addition to the methods described below, the way to simply access the data
|
||||
returned by the server is to simply use it like a string - for example,
|
||||
printing it, concatenating it with another string, or quoting it.
|
||||
|
||||
You should, however, take note that when using the L<C<chunk()>|GT::WWW/chunk>
|
||||
option for an HTTP request, the content will not be available.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
For simple requests, often the content alone is enough. The following methods
|
||||
are used to determine any other information available about the response.
|
||||
|
||||
=head2 content
|
||||
|
||||
Returns the content of the HTTP response. Note that this returns the exact
|
||||
same value as using the object in double quotes.
|
||||
|
||||
=head2 status
|
||||
|
||||
Returns the response status object for the request. This object provides three
|
||||
pieces of information, and has no public methods. Instead, the data is
|
||||
retrieved based on the context of the object.
|
||||
|
||||
my $status = $response->status;
|
||||
|
||||
(N.B. Though the examples below use a C<$status> variable, there is no reason
|
||||
they couldn't be written to use C<$response-E<gt>status> instead.)
|
||||
|
||||
=over 4
|
||||
|
||||
=item numeric status
|
||||
|
||||
The numeric status of an HTTP request (e.g. 200, 404, 500) is available simply
|
||||
by using the status object as a number.
|
||||
|
||||
my $numeric_status = int $status;
|
||||
|
||||
=item string status
|
||||
|
||||
The string status of an HTTP request (e.g. "OK", "Not Found", "Internal Server
|
||||
Error") is available by using the status object as a string (e.g. printing it,
|
||||
or concatenating it with another string).
|
||||
|
||||
# Assign the status string to a variable:
|
||||
my $status_string = "$status";
|
||||
|
||||
# Print out the status string:
|
||||
print $status;
|
||||
|
||||
# To get a string such as "500 Internal Server Error":
|
||||
my $string = int($status) . " " . $status;
|
||||
|
||||
=item boolean status
|
||||
|
||||
In order to quickly determine whether or not a request was successful, you can
|
||||
use the status object in a boolean context.
|
||||
|
||||
Success is determined by the numeric status of the response. Any 2xx status
|
||||
(usually 200 OK, but there are others) counts as a successful response, while
|
||||
any other status counts as a failure.
|
||||
|
||||
if ($status) { print "Request successful!" }
|
||||
else { print "Request failed!" }
|
||||
|
||||
=back
|
||||
|
||||
=head2 header
|
||||
|
||||
This method, called without arguments, returns the
|
||||
L<header|GT::WWW::http::Header> object for the response.
|
||||
|
||||
my $header = $response->header;
|
||||
|
||||
If this method is called with arguments, those arguments are passed to the
|
||||
L<C<header()>|GT::WWW::http::Header/header> method of the header object. This
|
||||
allows this useful shortcut:
|
||||
|
||||
my $some_header_value = $response->header("Some-Header");
|
||||
|
||||
instead of the alternative (which also works):
|
||||
|
||||
my $some_header_value = $response->header->header("Some-Header");
|
||||
|
||||
Information on header object usage is contained in L<GT::WWW::http::Header>.
|
||||
|
||||
Note that although a header object allows for header manipulation, changing the
|
||||
headers of a response object should be considered bad practise, and is strongly
|
||||
discouraged.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Although the response object _works_ like a string, keep in mind that it is
|
||||
still an object, and thus a reference. If you intend to pass the data to
|
||||
another subroutine expecting a string, it is recommended that you force the
|
||||
content into string form, either by quoting the variable (C<"$var">) or by
|
||||
calling the content() method (C<$var-E<gt>content>). Not doing so can lead to
|
||||
unexpected results, particularly in cases where another subroutine may
|
||||
differentiate between a string and a reference, and not just use the value as a
|
||||
string.
|
||||
|
||||
Also, in terms of speed, obtaining the content (not the object) into another
|
||||
variable (either via C<"$var"> or C<$var-E<gt>content>) can make quite a
|
||||
substantial difference when several string comparison operations are performed.
|
||||
The reason is simply that every time the object is used is a string, the
|
||||
content method is called, which can amount to a significant slowdown.
|
||||
|
||||
Although string operations that change the string (i.e. s///) appear to work,
|
||||
they in fact clobber the reference and turn your variable into an ordinary
|
||||
string. This should not be done - if the string needs to be modified, take a
|
||||
copy of it first, and modify the copy.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::WWW>
|
||||
L<GT::WWW::http>
|
||||
L<GT::WWW::http::Header>
|
||||
RFC 2616: L<http://www.ietf.org/rfc/rfc2616.txt>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Response.pm,v 1.8 2004/08/04 19:23:07 jagerman Exp $
|
||||
|
||||
=cut
|
||||
63
site/glist/lib/GT/WWW/https.pm
Normal file
63
site/glist/lib/GT/WWW/https.pm
Normal file
@@ -0,0 +1,63 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::WWW::http
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: https.pm,v 1.3 2004/01/13 01:35:20 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# GT::WWW::http subclass to handle HTTPS connections
|
||||
#
|
||||
# This class has only one methods of its own - the default port. Everything
|
||||
# else is inherited directly from GT::WWW::http. It does, however, have the
|
||||
# SSLHandle use, which will err fatally if Net::SSLeay is not installed.
|
||||
|
||||
package GT::WWW::https;
|
||||
use GT::WWW::http;
|
||||
use GT::Socket::Client::SSLHandle;
|
||||
|
||||
@GT::WWW::https::ISA = 'GT::WWW::http';
|
||||
|
||||
sub default_port { 443 }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::WWW::https - HTTPS handling for GT::WWW
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is a simple subclass of GT::WWW::http used by GT::WWW to enable
|
||||
HTTPS access as opposed to HTTP access. Thus GT::WWW::http should be consulted
|
||||
instead of this documentation.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
GT::WWW HTTPS support requires GT::Socket::Client::SSLHandle, which in turn
|
||||
requires the Net::SSLeay library.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::WWW::http>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: https.pm,v 1.3 2004/01/13 01:35:20 jagerman Exp $
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user