First pass at adding key files
This commit is contained in:
dsainty
101
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Action.pm
Normal file
101
site/slowtwitch.com/cgi-bin/articles/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 : 087,071,086,086,085
|
||||
# $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/slowtwitch.com/cgi-bin/articles/GT/CGI/Action/Common.pm
Normal file
286
site/slowtwitch.com/cgi-bin/articles/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 : 087,071,086,086,085
|
||||
# $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/slowtwitch.com/cgi-bin/articles/GT/CGI/Action/Plugin.pm
Normal file
106
site/slowtwitch.com/cgi-bin/articles/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 : 087,071,086,086,085
|
||||
# $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__
|
||||
|
||||
|
||||
103
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Cookie.pm
Normal file
103
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Cookie.pm
Normal file
@ -0,0 +1,103 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Cookie
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Cookie.pm,v 1.7 2008/06/09 23:39:47 brewt 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 => '',
|
||||
-httponly => '',
|
||||
};
|
||||
@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});
|
||||
if (my $path = $self->{-path}) { $path =~ s/[\x00-\x1f].*//s; $header .= "; path=$path"; }
|
||||
if (my $domain = $self->{-domain}) { $domain =~ s/[\x00-\x1f].*//s; $header .= "; domain=$domain"; }
|
||||
$self->{-secure} and $header .= "; secure";
|
||||
$self->{-httponly} and $header .= "; httponly";
|
||||
|
||||
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/slowtwitch.com/cgi-bin/articles/GT/CGI/EventLoop.pm
Normal file
502
site/slowtwitch.com/cgi-bin/articles/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 : 087,071,086,086,085
|
||||
# $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/slowtwitch.com/cgi-bin/articles/GT/CGI/Fh.pm
Normal file
70
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Fh.pm
Normal file
@ -0,0 +1,70 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Fh
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
270
site/slowtwitch.com/cgi-bin/articles/GT/CGI/MultiPart.pm
Normal file
270
site/slowtwitch.com/cgi-bin/articles/GT/CGI/MultiPart.pm
Normal file
@ -0,0 +1,270 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::MultiPart
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: MultiPart.pm,v 1.12 2008/07/14 23:40:31 brewt 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, $callback) = @_;
|
||||
|
||||
# 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";
|
||||
if ($header->{'Content-Disposition'} =~ m/ name=(?:"([^"]*)"|((?!")[^;]*))/) {
|
||||
$name = length $1 ? $1 : $2;
|
||||
}
|
||||
|
||||
$filename = '';
|
||||
if ($header->{'Content-Disposition'} =~ m/ filename=(?:"([^"]*)"|((?!")[^;]*))/) {
|
||||
$filename = length $1 ? $1 : $2;
|
||||
|
||||
# Strip off any paths from the filename (IE sends the full path to the file).
|
||||
$filename =~ s|^.*[/\\]|| if $filename;
|
||||
}
|
||||
|
||||
$name .= $GT::CGI::TAINTED;
|
||||
$filename .= $GT::CGI::TAINTED;
|
||||
|
||||
# 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;
|
||||
my $bytes_read = 0;
|
||||
while (defined($data = $parser->read)) {
|
||||
if (defined $callback and (ref $callback eq 'CODE')) {
|
||||
$bytes_read += length $data;
|
||||
$callback->($filename, \$data, $bytes_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 . $GT::CGI::TAINTED;
|
||||
}
|
||||
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 . $GT::CGI::TAINTED, $2 . $GT::CGI::TAINTED);
|
||||
$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;
|
||||
Reference in New Issue
Block a user