CGI-Portable
view release on metacpan or search on metacpan
lib/CGI/Portable.pm view on Meta::CPAN
######################################################################
package CGI::Portable;
require 5.004;
# Copyright (c) 1999-2004, Darren R. Duncan. All rights reserved. This module
# is free software; you can redistribute it and/or modify it under the same terms
# as Perl itself. However, I do request that this copyright information and
# credits remain attached to the file. If you modify this module and
# redistribute a changed version then please attach a note listing the
# modifications. This module is available "as-is" and the author can not be held
# accountable for any problems resulting from its use.
use strict;
use warnings;
use vars qw($VERSION);
$VERSION = '0.51';
######################################################################
=head1 DEPENDENCIES
=head2 Perl Version
5.004
=head2 Standard Modules
I<none>
=head2 Nonstandard Modules
File::VirtualPath 1.011
CGI::MultiValuedHash 1.09
HTML::EasyTags 1.071 -- only required in page_as_string()
=cut
######################################################################
use File::VirtualPath 1.011;
use CGI::MultiValuedHash 1.09;
######################################################################
=head1 SYNOPSIS
=head2 Content of thin shell "startup_cgi.pl" for CGI or Apache::Registry env:
#!/usr/bin/perl
use strict;
use warnings;
require CGI::Portable;
my $globals = CGI::Portable->new();
use Cwd;
$globals->file_path_root( cwd() ); # let us default to current working directory
$globals->file_path_delimiter( $^O=~/Mac/i ? ":" : $^O=~/Win/i ? "\\" : "/" );
$globals->set_prefs( 'config.pl' );
$globals->current_user_path_level( 1 );
require CGI::Portable::AdapterCGI;
my $io = CGI::Portable::AdapterCGI->new();
$io->fetch_user_input( $globals );
$globals->call_component( 'DemoAardvark' );
$io->send_user_output( $globals );
1;
=head2 Content of thin shell "startup_socket.pl" for IO::Socket::INET:
#!/usr/bin/perl
use strict;
use warnings;
print "[Server $0 starting up]\n";
require CGI::Portable;
my $globals = CGI::Portable->new();
use Cwd;
$globals->file_path_root( cwd() ); # let us default to current working directory
$globals->file_path_delimiter( $^O=~/Mac/i ? ":" : $^O=~/Win/i ? "\\" : "/" );
$globals->set_prefs( 'config.pl' );
$globals->current_user_path_level( 1 );
require CGI::Portable::AdapterSocket;
my $io = CGI::Portable::AdapterSocket->new();
use IO::Socket;
my $server = IO::Socket::INET->new(
Listen => SOMAXCONN,
LocalAddr => '127.0.0.1',
LocalPort => 1984,
Proto => 'tcp'
);
die "[Error: can't setup server $0]" unless $server;
print "[Server $0 accepting clients]\n";
while( my $client = $server->accept() ) {
printf "%s: [Connect from %s]\n", scalar localtime, $client->peerhost;
my $content = $globals->make_new_context();
$io->fetch_user_input( $content, $client );
$content->call_component( 'DemoAardvark' );
$io->send_user_output( $content, $client );
close $client;
printf "%s http://%s:%s%s %s\n", $content->request_method,
$content->server_domain, $content->server_port,
$content->user_path_string, $content->http_status_code;
}
1;
=head2 Content of settings file "config.pl"
my $rh_prefs = {
title => 'Welcome to DemoAardvark',
credits => '<p>This program copyright 2001 Darren Duncan.</p>',
screens => {
one => {
'link' => 'Fill Out A Form',
mod_name => 'DemoTiger',
mod_prefs => {
field_defs => [
{
visible_title => "What's your name?",
type => 'textfield',
name => 'name',
}, {
visible_title => "What's the combination?",
type => 'checkbox_group',
name => 'words',
'values' => ['eenie', 'meenie', 'minie', 'moe'],
default => ['eenie', 'minie'],
rows => 2,
}, {
visible_title => "What's your favorite colour?",
type => 'popup_menu',
name => 'color',
'values' => ['red', 'green', 'blue', 'chartreuse'],
}, {
type => 'submit',
},
],
},
},
two => {
'link' => 'Fly Away',
mod_name => 'DemoOwl',
mod_prefs => {
fly_to => 'http://www.perl.com',
},
},
three => {
'link' => 'Don\'t Go Here',
mod_name => 'DemoCamel',
mod_subdir => 'files',
mod_prefs => {
priv => 'private.txt',
prot => 'protected.txt',
publ => 'public.txt',
},
},
four => {
'link' => 'Look At Some Files',
mod_name => 'DemoPanda',
mod_prefs => {
food => 'plants',
color => 'black and white',
size => 'medium',
files => [qw( priv prot publ )],
file_reader => '/three',
},
},
},
};
=head2 Content of fat main program component "DemoAardvark.pm"
I<This module acts sort of like CGI::Portable::AppMultiScreen.>
package DemoAardvark;
use strict;
use warnings;
use CGI::Portable;
sub main {
my ($class, $globals) = @_;
my $users_choice = $globals->current_user_path_element();
my $rh_screens = $globals->pref( 'screens' );
if( my $rh_screen = $rh_screens->{$users_choice} ) {
my $inner = $globals->make_new_context();
$inner->inc_user_path_level();
$inner->navigate_url_path( $users_choice );
$inner->navigate_file_path( $rh_screen->{mod_subdir} );
$inner->set_prefs( $rh_screen->{mod_prefs} );
$inner->call_component( $rh_screen->{mod_name} );
$globals->take_context_output( $inner );
} else {
$globals->set_page_body( "<p>Please choose a screen to view.</p>" );
foreach my $key (keys %{$rh_screens}) {
my $label = $rh_screens->{$key}->{link};
my $url = $globals->url_as_string( $key );
$globals->append_page_body( "<br /><a href=\"$url\">$label</a>" );
}
}
$globals->page_title( $globals->pref( 'title' ) );
$globals->prepend_page_body( "<h1>".$globals->page_title()."</h1>\n" );
$globals->append_page_body( $globals->pref( 'credits' ) );
}
1;
=head2 Content of component module "DemoTiger.pm"
I<This module acts sort of like DemoMailForm without the emailing.>
package DemoTiger;
use strict;
use warnings;
use CGI::Portable;
use HTML::FormTemplate;
sub main {
my ($class, $globals) = @_;
my $ra_field_defs = $globals->resolve_prefs_node_to_array(
$globals->pref( 'field_defs' ) );
if( $globals->get_error() ) {
$globals->set_page_body(
"Sorry I can not do that form thing now because we are missing ",
"critical settings that say what the questions are.",
"Reason: ", $globals->get_error(),
);
$globals->add_no_error();
return( 0 );
}
my $form = HTML::FormTemplate->new();
$form->form_submit_url( $globals->recall_url() );
$form->field_definitions( $ra_field_defs );
$form->user_input( $globals->user_post() );
$globals->set_page_body(
'<h1>Here Are Some Questions</h1>',
$form->make_html_input_form( 1 ),
'<hr />',
'<h1>Answers From Last Time If Any</h1>',
$form->new_form() ? '' : $form->make_html_input_echo( 1 ),
);
}
1;
=head2 Content of component module "DemoOwl.pm"
I<This module acts sort of like DemoRedirect.>
package DemoOwl;
use strict;
use warnings;
use CGI::Portable;
sub main {
my ($class, $globals) = @_;
my $url = $globals->pref( 'fly_to' );
$globals->http_status_code( '301 Moved' );
$globals->http_redirect_url( $url );
}
1;
=head2 Content of component module "DemoCamel.pm"
I<This module acts sort of like DemoTextFile.>
package DemoCamel;
use strict;
use warnings;
use CGI::Portable;
sub main {
my ($class, $globals) = @_;
my $users_choice = $globals->current_user_path_element();
my $filename = $globals->pref( $users_choice );
my $filepath = $globals->physical_filename( $filename );
SWITCH: {
$globals->add_no_error();
open( FH, $filepath ) or do {
lib/CGI/Portable.pm view on Meta::CPAN
Because your program core uses this class to communicate with its "superior", it
can be written the same way regardless of what platform it is running on. The
interface that it needs to written to is consistent across platforms. An
analogy to this is that the core always plays in the same sandbox and that
environment is all it knows; you can move the sandbox anywhere you want and its
occupant doesn't have to be any the wiser to how the outside world had changed.
From there, it is a small step to breaking your program core into reusable
components and using CGI::Portable as an interface between them. Each
component exists in its own sandbox and acts like it is its own core program,
with its own task to produce an html page or other http response, and with its
own set of user input and program settings to tell it how to do its job.
Depending on your needs, each "component" instance could very well be its own
complete application, or it would in fact be a subcontractee of another one.
In the latter case, the "subcontractor" component may have other components do
a part of its own task, and then assemble a derivative work as its own output.
When one component wants another to do work for it, the first one instantiates
a new CGI::Portable object which it can pass on any user input or settings
data that it wishes, and then provides this to the second component; the second
one never has to know where its CGI::Portable object it has came from, but
that everything it needs to know for its work is right there. This class
provides convenience methods like make_new_context() to simplify this task by
making a partial clone that replicates input but not output data.
Due to the way CGI::Portable stores program settings and other input/output
data, it lends itself well to supporting data-driven applications. That is,
your application components can be greatly customizable as to their function by
simply providing instances of them with different setup data. If any component
is so designed, its own config instructions can detail which other components it
subcontracts, as well as what operating contexts it sets up for them. This
results in a large variety of functionality from just a small set of components.
Another function that CGI::Portable provides for component management is that
there is limited protection for components that are not properly designed to be
kept from harming other ones. You see, any components designed a certain way can
be invoked by CGI::Portable itself at the request of another component.
This internal call is wrapped in an eval block such that if a component fails to
compile or has a run-time exception, this class will log an error to the effect
and the component that called it continues to run. Also, called components get
a different CGI::Portable object than the parent, so that if they mess around
with the stored input/output then the parent component's own data isn't lost.
It is the parent's own choice as to which output of its child that it decides to
copy back into its own output, with or without further processing.
Note that the term "components" above suggests that each one is structured as
a Perl 5 module and is called like one; the module should have a method called
main() that takes an CGI::Portable object as its argument and has the
dispatch code for that component. Of course, it is up to you.
=cut
######################################################################
# Names of 'Errors' properties for objects of this class are declared here:
my $KEY_ERRORS = 'errors'; # array - a list of short error messages
# Names of 'Files' properties for objects of this class are declared here:
my $KEY_FILE_PATH = 'file_path'; # FVP - tracks filesystem loc of our files
my $KEY_PREFS = 'prefs'; # hash - tracks our current file-based preferences
# These 'Request' properties describe the TCP/IP connection details for server+client
my $KEY_TCP_SEIP = 'tcp_seip'; # string - tcp ip address of server
my $KEY_TCP_SEDO = 'tcp_sedo'; # string - tcp domain of server
my $KEY_TCP_SEPO = 'tcp_sepo'; # number - tcp server port
my $KEY_TCP_CLIP = 'tcp_clip'; # string - tcp remote IP address of web user
my $KEY_TCP_CLDO = 'tcp_cldo'; # string - tcp remote host domain of web user
my $KEY_TCP_CLPO = 'tcp_clpo'; # number - tcp client port
# These 'Request' properties are raw values from the HTTP request headers and body
my $KEY_REQ_METH = 'req_meth'; # string - request method (GET/POST/HEAD)
my $KEY_REQ_URIX = 'req_urix'; # string - request uri (path + query string)
my $KEY_REQ_PROT = 'req_prot'; # string - request protocol (eg: HTTP/1.0)
my $KEY_REQ_HEAD = 'req_head'; # hash - stores all raw req headers not above
my $KEY_REQ_BODY = 'req_body'; # string - stores the raw request body
# These 'Request' properties represent user input and are parsed from raw HTTP request
my $KEY_UI_PATH = 'ui_path'; # FVP - parsed path info from uri (usually)
my $KEY_UI_QUER = 'ui_quer'; # CMVH - parsed user input query from uri
my $KEY_UI_POST = 'ui_post'; # CMVH - parsed user input post (http body)
my $KEY_UI_COOK = 'ui_cook'; # CMVH - parsed user input cookies
# These 'Request' properties are used when making new self-referencing urls in output
my $KEY_URL_BASE = 'url_base'; # string - stores joined host, script_name, etc
my $KEY_URL_PATH = 'url_path'; # FVP - virtual path used in s-r urls
my $KEY_URL_QUER = 'url_quer'; # CMVH - holds query params to put in all urls
# These 'Response' properties would go in output HTTP headers and body
my $KEY_HTTP_STAT = 'http_stat'; # string - HTTP status code; first to output
my $KEY_HTTP_WITA = 'http_wita'; # string - stores Window-Target of output
my $KEY_HTTP_COTY = 'http_coty'; # string - stores Content-Type of outp
my $KEY_HTTP_REDI = 'http_redi'; # string - stores URL to redirect to
my $KEY_HTTP_COOK = 'http_cook'; # array - stores outgoing encoded cookies
my $KEY_HTTP_HEAD = 'http_head'; # hash - stores misc HTTP headers keys/values
my $KEY_HTTP_BODY = 'http_body'; # string - stores raw HTTP body if wanted
my $KEY_HTTP_BINA = 'http_bina'; # boolean - true if HTTP body is binary
# These 'Response' properties will be combined into the output page if it is text/html
my $KEY_PAGE_PROL = 'page_prol'; # string - prologue tag or "doctype" at top
my $KEY_PAGE_TITL = 'page_titl'; # string - new HTML title
my $KEY_PAGE_AUTH = 'page_auth'; # string - new HTML author
my $KEY_PAGE_META = 'page_meta'; # hash - new HTML meta keys/values
my $KEY_PAGE_CSSR = 'page_cssr'; # array - new HTML css file urls
my $KEY_PAGE_CSSC = 'page_cssc'; # array - new HTML css embedded code
my $KEY_PAGE_HEAD = 'page_head'; # array - raw misc content for HTML head
my $KEY_PAGE_FATR = 'page_fatr'; # hash - attribs for optional HTML frameset tag
my $KEY_PAGE_FRAM = 'page_fram'; # array of hashes - list of frame attributes
my $KEY_PAGE_BATR = 'page_batr'; # hash - attribs for HTML body tag
my $KEY_PAGE_BODY = 'page_body'; # array - raw content for HTML body
# Names of 'Misc' properties for objects of this class are declared here:
my $KEY_IS_DEBUG = 'is_debug'; # boolean - a flag to say we are debugging
# These 'Misc' properties are special prefs to be set once and global avail (copied)
my $KEY_PREF_APIT = 'pref_apit'; # string - application instance title
my $KEY_PREF_MNAM = 'pref_mnam'; # string - maintainer name
my $KEY_PREF_MEAD = 'pref_mead'; # string - maintainer email address
my $KEY_PREF_MESP = 'pref_mesp'; # string - maintainer email screen url path
my $KEY_PREF_SMTP = 'pref_smtp'; # string - smtp host domain/ip to use
my $KEY_PREF_TIME = 'pref_time'; # number - timeout in seconds for smtp connect
# This 'Misc' property is generally static across all derived objects for misc sharing
my $KEY_MISC_OBJECTS = 'misc_objects'; # hash - holds misc objects we may need
######################################################################
=head1 SYNTAX
This class does not export any functions or methods, so you need to call them
using object notation. This means using B<Class-E<gt>function()> for functions
and B<$object-E<gt>method()> for methods. If you are inheriting this class for
your own modules, then that often means something like B<$self-E<gt>method()>.
=head1 CONSTRUCTOR FUNCTIONS AND METHODS
These functions and methods are involved in making new CGI::Portable objects.
=head2 new([ FILE_ROOT[, FILE_DELIM[, PREFS]] ])
This function creates a new CGI::Portable (or subclass) object and
returns it. All of the method arguments are passed to initialize() as is; please
see the POD for that method for an explanation of them.
=head2 initialize([ FILE_ROOT[, FILE_DELIM[, PREFS]] ])
This method is used by B<new()> to set the initial properties of objects that it
creates. The optional 3 arguments are used in turn to set the properties
accessed by these methods: file_path_root(), file_path_delimiter(), set_prefs().
=head2 clone([ CLONE ])
This method initializes a new object to have all of the same properties of the
current object and returns it. This new object can be provided in the optional
argument CLONE (if CLONE is an object of the same class as the current object);
otherwise, a brand new object of the current class is used. Only object
properties recognized by CGI::Portable are set in the clone; other
properties are not changed.
=cut
######################################################################
sub new {
my $class = shift( @_ );
my $self = bless( {}, ref($class) || $class );
$self->initialize( @_ );
return( $self );
}
sub initialize {
my ($self, $file_root, $file_delim, $prefs) = @_;
$self->{$KEY_ERRORS} = [];
$self->{$KEY_FILE_PATH} = File::VirtualPath->new();
$self->{$KEY_PREFS} = {};
$self->{$KEY_TCP_SEIP} = '127.0.0.1';
$self->{$KEY_TCP_SEDO} = 'localhost';
$self->{$KEY_TCP_SEPO} = 80;
$self->{$KEY_TCP_CLIP} = '127.0.0.1';
$self->{$KEY_TCP_CLDO} = 'localhost';
$self->{$KEY_TCP_CLPO} = undef;
$self->{$KEY_REQ_METH} = 'GET';
$self->{$KEY_REQ_URIX} = '/';
$self->{$KEY_REQ_PROT} = 'HTTP/1.0';
$self->{$KEY_REQ_HEAD} = {};
$self->{$KEY_REQ_BODY} = undef;
$self->{$KEY_UI_PATH} = File::VirtualPath->new();
$self->{$KEY_UI_QUER} = CGI::MultiValuedHash->new();
$self->{$KEY_UI_POST} = CGI::MultiValuedHash->new();
$self->{$KEY_UI_COOK} = CGI::MultiValuedHash->new();
$self->{$KEY_URL_BASE} = 'http://localhost/';
$self->{$KEY_URL_PATH} = File::VirtualPath->new();
$self->{$KEY_URL_QUER} = CGI::MultiValuedHash->new();
$self->{$KEY_HTTP_STAT} = '200 OK';
$self->{$KEY_HTTP_WITA} = undef;
$self->{$KEY_HTTP_COTY} = 'text/html';
$self->{$KEY_HTTP_REDI} = undef;
$self->{$KEY_HTTP_COOK} = [];
$self->{$KEY_HTTP_HEAD} = {};
$self->{$KEY_HTTP_BODY} = undef;
$self->{$KEY_HTTP_BINA} = undef;
$self->{$KEY_PAGE_PROL} = undef;
$self->{$KEY_PAGE_TITL} = undef;
$self->{$KEY_PAGE_AUTH} = undef;
$self->{$KEY_PAGE_META} = {};
$self->{$KEY_PAGE_CSSR} = [];
$self->{$KEY_PAGE_CSSC} = [];
$self->{$KEY_PAGE_HEAD} = [];
$self->{$KEY_PAGE_FATR} = {};
$self->{$KEY_PAGE_FRAM} = [];
$self->{$KEY_PAGE_BATR} = {};
$self->{$KEY_PAGE_BODY} = [];
$self->{$KEY_IS_DEBUG} = undef;
$self->{$KEY_PREF_APIT} = 'Untitled Application';
$self->{$KEY_PREF_MNAM} = 'Webmaster';
$self->{$KEY_PREF_MEAD} = 'webmaster@localhost';
$self->{$KEY_PREF_MESP} = undef;
$self->{$KEY_PREF_SMTP} = 'localhost';
$self->{$KEY_PREF_TIME} = '30';
$self->{$KEY_MISC_OBJECTS} = {};
$self->file_path_root( $file_root );
$self->file_path_delimiter( $file_delim );
$self->set_prefs( $prefs );
}
sub clone {
my ($self, $clone) = @_;
ref($clone) eq ref($self) or $clone = bless( {}, ref($self) );
$clone->{$KEY_ERRORS} = [@{$self->{$KEY_ERRORS}}];
$clone->{$KEY_FILE_PATH} = $self->{$KEY_FILE_PATH}->clone();
$clone->{$KEY_PREFS} = {%{$self->{$KEY_PREFS}}};
$clone->{$KEY_TCP_SEIP} = $self->{$KEY_TCP_SEIP};
$clone->{$KEY_TCP_SEDO} = $self->{$KEY_TCP_SEDO};
$clone->{$KEY_TCP_SEPO} = $self->{$KEY_TCP_SEPO};
$clone->{$KEY_TCP_CLIP} = $self->{$KEY_TCP_CLIP};
$clone->{$KEY_TCP_CLDO} = $self->{$KEY_TCP_CLDO};
$clone->{$KEY_TCP_CLPO} = $self->{$KEY_TCP_CLPO};
$clone->{$KEY_REQ_METH} = $self->{$KEY_REQ_METH};
$clone->{$KEY_REQ_URIX} = $self->{$KEY_REQ_URIX};
$clone->{$KEY_REQ_PROT} = $self->{$KEY_REQ_PROT};
$clone->{$KEY_REQ_HEAD} = {%{$self->{$KEY_REQ_HEAD}}};
$clone->{$KEY_REQ_BODY} = $self->{$KEY_REQ_BODY};
$clone->{$KEY_UI_PATH} = $self->{$KEY_UI_PATH}->clone();
$clone->{$KEY_UI_QUER} = $self->{$KEY_UI_QUER}->clone();
$clone->{$KEY_UI_POST} = $self->{$KEY_UI_POST}->clone();
$clone->{$KEY_UI_COOK} = $self->{$KEY_UI_COOK}->clone();
$clone->{$KEY_URL_BASE} = $self->{$KEY_URL_BASE};
$clone->{$KEY_URL_PATH} = $self->{$KEY_URL_PATH}->clone();
$clone->{$KEY_URL_QUER} = $self->{$KEY_URL_QUER}->clone();
$clone->{$KEY_HTTP_STAT} = $self->{$KEY_HTTP_STAT};
$clone->{$KEY_HTTP_WITA} = $self->{$KEY_HTTP_WITA};
$clone->{$KEY_HTTP_COTY} = $self->{$KEY_HTTP_COTY};
$clone->{$KEY_HTTP_REDI} = $self->{$KEY_HTTP_REDI};
$clone->{$KEY_HTTP_COOK} = [@{$self->{$KEY_HTTP_COOK}}];
$clone->{$KEY_HTTP_HEAD} = {%{$self->{$KEY_HTTP_HEAD}}};
$clone->{$KEY_HTTP_BODY} = $self->{$KEY_HTTP_BODY};
$clone->{$KEY_HTTP_BINA} = $self->{$KEY_HTTP_BINA};
$clone->{$KEY_PAGE_PROL} = $self->{$KEY_PAGE_PROL};
$clone->{$KEY_PAGE_TITL} = $self->{$KEY_PAGE_TITL};
$clone->{$KEY_PAGE_AUTH} = $self->{$KEY_PAGE_AUTH};
$clone->{$KEY_PAGE_META} = {%{$self->{$KEY_PAGE_META}}};
$clone->{$KEY_PAGE_CSSR} = [@{$self->{$KEY_PAGE_CSSR}}];
$clone->{$KEY_PAGE_CSSC} = [@{$self->{$KEY_PAGE_CSSC}}];
$clone->{$KEY_PAGE_HEAD} = [@{$self->{$KEY_PAGE_HEAD}}];
$clone->{$KEY_PAGE_FATR} = {%{$self->{$KEY_PAGE_FATR}}};
$clone->{$KEY_PAGE_FRAM} = [map { {%{$_}} } @{$self->{$KEY_PAGE_FRAM}}];
$clone->{$KEY_PAGE_BATR} = {%{$self->{$KEY_PAGE_BATR}}};
$clone->{$KEY_PAGE_BODY} = [@{$self->{$KEY_PAGE_BODY}}];
$clone->{$KEY_IS_DEBUG} = $self->{$KEY_IS_DEBUG};
$clone->{$KEY_PREF_APIT} = $self->{$KEY_PREF_APIT};
$clone->{$KEY_PREF_MNAM} = $self->{$KEY_PREF_MNAM};
$clone->{$KEY_PREF_MEAD} = $self->{$KEY_PREF_MEAD};
$clone->{$KEY_PREF_MESP} = $self->{$KEY_PREF_MESP};
lib/CGI/Portable.pm view on Meta::CPAN
@{$context->{$KEY_PAGE_CSSR}} and
$self->{$KEY_PAGE_CSSR} = [@{$context->{$KEY_PAGE_CSSR}}];
@{$context->{$KEY_PAGE_CSSC}} and
$self->{$KEY_PAGE_CSSC} = [@{$context->{$KEY_PAGE_CSSC}}];
@{$context->{$KEY_PAGE_HEAD}} and
$self->{$KEY_PAGE_HEAD} = [@{$context->{$KEY_PAGE_HEAD}}];
@{$context->{$KEY_PAGE_FRAM}} and $self->{$KEY_PAGE_FRAM} =
[map { {%{$_}} } @{$context->{$KEY_PAGE_FRAM}}];
@{$context->{$KEY_PAGE_BODY}} and
$self->{$KEY_PAGE_BODY} = [@{$context->{$KEY_PAGE_BODY}}];
%{$context->{$KEY_HTTP_HEAD}} and
$self->{$KEY_HTTP_HEAD} = {%{$context->{$KEY_HTTP_HEAD}}};
%{$context->{$KEY_PAGE_META}} and
$self->{$KEY_PAGE_META} = {%{$context->{$KEY_PAGE_META}}};
%{$context->{$KEY_PAGE_FATR}} and
$self->{$KEY_PAGE_FATR} = {%{$context->{$KEY_PAGE_FATR}}};
%{$context->{$KEY_PAGE_BATR}} and
$self->{$KEY_PAGE_BATR} = {%{$context->{$KEY_PAGE_BATR}}};
} else {
push( @{$self->{$KEY_HTTP_COOK}}, @{$context->{$KEY_HTTP_COOK}} );
push( @{$self->{$KEY_PAGE_CSSR}}, @{$context->{$KEY_PAGE_CSSR}} );
push( @{$self->{$KEY_PAGE_CSSC}}, @{$context->{$KEY_PAGE_CSSC}} );
push( @{$self->{$KEY_PAGE_HEAD}}, @{$context->{$KEY_PAGE_HEAD}} );
push( @{$self->{$KEY_PAGE_FRAM}},
map { {%{$_}} } @{$context->{$KEY_PAGE_FRAM}} );
push( @{$self->{$KEY_PAGE_BODY}}, @{$context->{$KEY_PAGE_BODY}} );
@{$self->{$KEY_HTTP_HEAD}}{keys %{$context->{$KEY_HTTP_HEAD}}} =
values %{$context->{$KEY_HTTP_HEAD}};
@{$self->{$KEY_PAGE_META}}{keys %{$context->{$KEY_PAGE_META}}} =
values %{$context->{$KEY_PAGE_META}};
@{$self->{$KEY_PAGE_FATR}}{keys %{$context->{$KEY_PAGE_FATR}}} =
values %{$context->{$KEY_PAGE_FATR}};
@{$self->{$KEY_PAGE_BATR}}{keys %{$context->{$KEY_PAGE_BATR}}} =
values %{$context->{$KEY_PAGE_BATR}};
}
}
######################################################################
=head2 call_component( COMP_NAME )
This method can be used by one component to invoke another. For this to work,
the called component needs to be a Perl 5 module with a method called main(). The
argument COMP_NAME is a string containing the name of the module to be invoked.
This method will first "require [COMP_NAME]" and then invoke its dispatch method
with a "[COMP_NAME]->main()". These statements are wrapped in an "eval" block
and if there was a compile or runtime failure then this method will log an error
message like "can't use module '[COMP_NAME]': $@" and also set the output page
to be an error screen using that. So regardless of whether the component worked
or not, you can simply print the output page the same way. The call_component()
method will pass a reference to the CGI::Portable object it is invoked from as an
argument to the main() method of the called module. If you want the called
component to get a different CGI::Portable object then you will need to
create it in your caller using make_new_context() or new() or clone().
Anticipating that your component would fail because of it, this method will
abort with an error screen prior to any "require" if there are errors already
logged and unresolved. Any errors existing now were probably set by
set_prefs(), meaning that the component would be missing its config data were it
started up. This method will return 0 upon making an error screen; otherwise,
it will return 1 if everything worked. Since this method calls add_no_error()
upon making the error screen, you should pay attention to its return value if
you want to make a custom screen instead (so you know when to).
=cut
######################################################################
sub call_component {
my ($self, $comp_name) = @_;
if( $self->get_error() ) {
$self->_make_call_component_error_page( $comp_name );
return( 0 );
}
eval {
# "require $comp_name;" yields can't find module in @INC error in 5.004
eval "require $comp_name;"; $@ and die;
$comp_name->main( $self );
};
if( $@ ) {
$self->add_error( "can't use module '$comp_name': $@" );
$self->_make_call_component_error_page( $comp_name );
return( 0 );
}
return( 1 );
}
# _make_call_component_error_page( COMP_NAME )
# This private method is used by call_component() to make error screens in
# situations where there is a failure calling an application component.
# The main situation in question involves the component module failing to
# compile or it having a run-time death. It can also be used when there is
# nothing wrong with the component itself, but there was a failure in getting
# preferences for it ahead of time. This method assumes that the details of
# the particular error will be returned by get_error() when it is called.
# The scalar argument COMP_NAME is the name of the module that call_component
# was trying to or would have been using. The intent of this method is to
# save the parent component or thin program config shell from having to compose
# an error screen for the user by itself, which is often repedative. The parent
# module can simply take back the context result page as it always does, which
# either contains successful output of the component or result of this method.
sub _make_call_component_error_page {
my ($self, $comp_name) = @_;
$self->page_title( 'Error Getting Screen' );
$self->set_page_body( <<__endquote );
<h1>@{[$self->page_title()]}</h1>
<p>I'm sorry, but an error occurred while getting the requested screen.
We were unable to use the application component that was in charge of
producing the screen content, named '$comp_name'.</p>
<p>This should be temporary, the result of a transient server problem or an
update being performed at the moment. Click @{[$self->recall_html('here')]}
to automatically try again. If the problem persists, please try again later,
or send an @{[$self->maintainer_email_html('e-mail')]} message about the
problem, so it can be fixed.</p>
lib/CGI/Portable.pm view on Meta::CPAN
}
sub file_path_root {
my ($self, $new_value) = @_;
return( $self->{$KEY_FILE_PATH}->physical_root( $new_value ) );
}
sub file_path_delimiter {
my ($self, $new_value) = @_;
return( $self->{$KEY_FILE_PATH}->physical_delimiter( $new_value ) );
}
sub file_path {
my ($self, $new_value) = @_;
return( $self->{$KEY_FILE_PATH}->path( $new_value ) );
}
sub file_path_string {
my ($self, $trailer) = @_;
return( $self->{$KEY_FILE_PATH}->path_string( $trailer ) );
}
sub navigate_file_path {
my ($self, $chg_vec) = @_;
return( $self->{$KEY_FILE_PATH}->chdir( $chg_vec ) );
}
sub virtual_filename {
my ($self, $chg_vec, $trailer) = @_;
return( $self->{$KEY_FILE_PATH}->child_path_string( $chg_vec, $trailer ) );
}
sub physical_filename {
my ($self, $chg_vec, $trailer) = @_;
return( $self->{$KEY_FILE_PATH}->physical_child_path_string(
$chg_vec, $trailer ) );
}
sub add_virtual_filename_error {
my ($self, $unique_part, $filename, $reason) = @_;
my $filepath = $self->virtual_filename( $filename );
defined( $reason ) or $reason = $!;
$self->add_error( "can't $unique_part file '$filepath': $reason" );
}
sub add_physical_filename_error {
my ($self, $unique_part, $filename, $reason) = @_;
my $filepath = $self->physical_filename( $filename );
defined( $reason ) or $reason = $!;
$self->add_error( "can't $unique_part file '$filepath': $reason" );
}
######################################################################
=head1 METHODS FOR INSTANCE PREFERENCES
These methods are accessors for the "preferences" property of this object, which
is designed to facilitate easy access to your application instance settings.
See the DESCRIPTION for more details.
=head2 resolve_prefs_node_to_hash( RAW_NODE )
This method takes a raw preferences node, RAW_NODE, and resolves it into a hash
ref, which it returns. If RAW_NODE is a hash ref then this method performs a
single-level copy of it and returns a new hash ref. Otherwise, this method
takes the argument as a filename and tries to execute it. If the file fails to
execute for some reason or it doesn't return a hash ref, then this method adds
a file error message and returns an empty hash ref. The file is executed with
"do [FILEPATH]" where FILEPATH is defined as the return value of
"physical_filename( FILENAME )". The error message uses a virtual path.
=head2 resolve_prefs_node_to_array( RAW_NODE )
This method takes a raw preferences node, RAW_NODE, and resolves it into an array
ref, which it returns. If RAW_NODE is a hash ref then this method performs a
single-level copy of it and returns a new array ref. Otherwise, this method
takes the argument as a filename and tries to execute it. If the file fails to
execute for some reason or it doesn't return an array ref, then this method adds
a file error message and returns an empty array ref. The file is executed with
"do [FILEPATH]" where FILEPATH is defined as the return value of
"physical_filename( FILENAME )". The error message uses a virtual path.
=head2 get_prefs_ref()
This method returns a reference to the internally stored "preferences" hash.
=head2 set_prefs( VALUE )
This method sets this object's preferences property with the return value of
"resolve_prefs_node_to_hash( VALUE )", even if VALUE is not defined.
=head2 pref( KEY[, VALUE] )
This method is an accessor to individual settings in this object's preferences
property, and returns the setting value whose name is defined in the scalar
argument KEY. If the optional scalar argument VALUE is defined then it becomes
the value for this setting. All values are set or fetched with a scalar copy.
=cut
######################################################################
sub resolve_prefs_node_to_hash {
my ($self, $raw_node) = @_;
if( ref( $raw_node ) eq 'HASH' ) {
return( {%{$raw_node}} );
} else {
$self->add_no_error();
my $filepath = $self->physical_filename( $raw_node );
my $result = do $filepath;
if( ref( $result ) eq 'HASH' ) {
return( $result );
} else {
$self->add_virtual_filename_error(
'obtain required preferences hash from', $raw_node,
defined( $result ) ? "result not a hash ref, but '$result'" :
$@ ? "compilation or runtime error of '$@'" : undef );
return( {} );
}
}
}
sub resolve_prefs_node_to_array {
my ($self, $raw_node) = @_;
if( ref( $raw_node ) eq 'ARRAY' ) {
return( [@{$raw_node}] );
} else {
$self->add_no_error();
my $filepath = $self->physical_filename( $raw_node );
my $result = do $filepath;
if( ref( $result ) eq 'ARRAY' ) {
return( $result );
} else {
$self->add_virtual_filename_error(
'obtain required preferences array from', $raw_node,
defined( $result ) ? "result not an array ref, but '$result'" :
$@ ? "compilation or runtime error of '$@'" : undef );
return( [] );
}
}
}
sub get_prefs_ref {
return( $_[0]->{$KEY_PREFS} ); # returns ref for further use
}
sub set_prefs {
my ($self, $new_value) = @_;
if( defined( $new_value ) ) {
$self->{$KEY_PREFS} = $self->resolve_prefs_node_to_hash( $new_value );
}
}
sub pref {
my ($self, $key, $new_value) = @_;
if( defined( $new_value ) ) {
$self->{$KEY_PREFS}->{$key} = $new_value;
}
return( $self->{$KEY_PREFS}->{$key} );
}
######################################################################
=head1 METHODS FOR TCP/IP CONNECTION
These methods are accessors for the "TCP Connection" properties of this object.
Under a CGI environment these would correspond to some of the %ENV keys.
=head2 server_ip([ VALUE ])
This method is an accessor for the "server ip" scalar property of this object,
which it returns. If VALUE is defined, this property is set to it.
During a valid TCP/IP connection, this property refers to the IP address of the
host machine, which this program is running on.
=head2 server_domain([ VALUE ])
This method is an accessor for the "server domain" scalar property of this object,
which it returns. If VALUE is defined, this property is set to it.
This property refers to the tcp host domain, if any, that was resolved to the
server IP. It would be provided in the TCP request header named "Host".
Often, multiple domains will resolve to the same IP address, in which case this
"Host" header is needed to tell what website the client really wanted.
=head2 server_port([ VALUE ])
This method is an accessor for the "server port" scalar property of this object,
which it returns. If VALUE is defined, this property is set to it.
During a valid TCP/IP connection, this property refers to the tcp port on the
host machine that this program or its parent service is listening on.
Port 80 is the standard one used for HTTP services.
=head2 client_ip([ VALUE ])
This method is an accessor for the "client ip" scalar property of this object,
which it returns. If VALUE is defined, this property is set to it.
During a valid TCP/IP connection, this property refers to the IP address of the
client machine, which is normally what the web-browsing user is sitting at,
though it could be a proxy or a robot instead.
=head2 client_domain([ VALUE ])
This method is an accessor for the "client domain" scalar property of this object,
which it returns. If VALUE is defined, this property is set to it.
This property often is not set, but if it is then it refers to internet domain
for the ISP that the web-browsing user is employing, or it is the domain for the
machine that the web robot is on.
=head2 client_port([ VALUE ])
( run in 0.553 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )