CGI-Portable
view release on metacpan or search on metacpan
* Added module CGI::Portable::AppMultiScreen, an "application component"
that lets you easily define a group of screens that are related, delegate
the construction of each screen to separate "components", and simplify the
creation of links between the screens. The module is subclassed from
AppStatic. This module has complete POD so you can get a good description
by reading that documentation. This module is meant as a non-proprietary
replacement for DemoMultiPage; the latter module was deleted. The
preferences handled by DemoMultiPage were renamed as follows: "vrp_handlers"
to "delegate_list", "def_handler" to "default_delegate", "wpm_module" to
"module_name", "wpm_prefs" to "preferences", "wpm_subdir" to "file_subdir".
The new module does not have any replacement for the older "menu_items" and
related preferences for generating html menus of hyperlinks between the
various screens, and it will not get any due to the proprietary nature of
such a task. If you used "menu_items" before then you will need to make the
hyperlinks yourself and attach them to the pages. It really isn't that
difficult; see the "website" demo for an example of how to do it now.
* Added module CGI::Portable::AppSplitScreen, an "application component"
that lets you easily divide a response screen into multiple regions and
then delegate the construction of each region to separate "components".
* All of the CGI::WPM::* modules except CountFile had their POD updated,
most notably with their Synopsis section. The new Synopsis should each be
complete working programs now, although some of the other data files they
call on may not exist unless you make them.
* All modules in this distribution are at version 0.41 whether or not there
was any functionality change.
* Updated these methods of CGI::Portable to permit more descriptive error
messages: resolve_prefs_node_to_array(), resolve_prefs_node_to_hash().
Previously these methods always reported a nonexistant file or directory
(whatever is in $!) even if the file did exist but had a different problem.
The new versions will distinguish a successful runtime that returns something
other than a hash/array ref, and will distinguish an existing file that just
doesn't compile or has a runtime error.
* Updated methods add_virtual_filename_error(), add_physical_filename_error()
to support custom reason strings for file-related errors as an extra method
argument. Previously the "reason" was always the content of $!.
* Modified method call_component() so that it now makes error screens itself
upon error conditions that it discovers, including failure of the component
to compile or run, or previously unhandled errors, probably related to prefs.
As a result, the calling structure of this method is simplified; you simply
take_context_output() and/or send the output as you usually do, without
needing extra code to report error conditions. (You can still make a custom
error screen if you want.) The second argument to call_component() was also
removed, and the method will now always make an error screen and return if
there is an unresolved error message. Likewise to the simplified calling
code, the called component doesn't need code to make an error screen for
problems occuring prior to its invocation, and is thereby simplified.
* Added method search_and_replace_url_path_tokens() to CGI::Portable that
send_user_output_from_cgi_portable() will likewise take a CGI::Portable
object and send its output to the user all at once.
* CGI::WPM::Base has been reduced to half its size as all but these 3 methods
were removed: main(), main_dispatch(), _get_amendment_message(). The code
to check for pre-existing logged error conditions was also removed.
* Updated CGI::WPM::GuestBook in the following ways: 1. The private method
get_question_field_defs() had a lot of redundant code removed, reducing the
method to half its previous size; for one thing, it makes use of
CGI::Portable's resolve_prefs_node_to_array() method now instead of doing a
poorer job of it manually. 2. Added preference "sign_by_default" which
allows you to choose whether the signing or reading mode is the default
when one isn't specified. 3. Added self-referencing links in the signing
mode that takes one to the reading mode; the reverse had already existed; so
now the module has built-in links between all of its modes. 4. Added
preference "msg_list_show_email" which if true will display the email
addresses of book signers in the reading mode; the default of not showing
the emails is what always happened before, even though they were stored in
the message file. 5. Minor update to the screen showing a successful
message was just posted where the recipient's email is now shown.
demos/segtext/splitup.pl
demos/smarthouse/config.pl
demos/smarthouse/DemoLM465.pm
demos/smarthouse/DemoX10.pm
demos/smarthouse/smarthouse_cgi.pl
demos/smarthouse/smarthouse_socket.pl
demos/statics/showhtml.pl
demos/statics/showself.pl
demos/statics/static.html
demos/survey.pl
demos/website/content/content_prefs.pl
demos/website/content/frontdoor.html
demos/website/content/guestbook_questions.txt
demos/website/content/links.html
demos/website/content/menu_prefs.pl
demos/website/content/mysites.html
demos/website/content/resume.html
demos/website/start.pl
demos/website/usage_prefs.pl
lib/CGI/Portable.pm
lib/CGI/Portable/AdapterCGI.pm
lib/CGI/Portable/AdapterSocket.pm
lib/CGI/Portable/AppMultiScreen.pm
lib/CGI/Portable/AppSplitScreen.pm
lib/CGI/Portable/AppStatic.pm
lib/DemoGuestBook.pm
lib/DemoMailForm.pm
lib/DemoRedirect.pm
lib/DemoTextFile.pm
demos/animals/DemoAardvark.pm view on Meta::CPAN
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>" );
}
demos/animals/DemoTiger.pm view on Meta::CPAN
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 );
}
demos/animals/config.pl view on Meta::CPAN
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'],
demos/animals/config.pl view on Meta::CPAN
'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',
},
},
},
};
demos/animals/startup_cgi.pl view on Meta::CPAN
use warnings;
use lib '/home/darren/perl_lib';
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;
demos/animals/startup_socket.pl view on Meta::CPAN
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,
demos/bounce.pl view on Meta::CPAN
require CGI::Portable;
my $globals = CGI::Portable->new();
require CGI::Portable::AdapterCGI;
my $io = CGI::Portable::AdapterCGI->new();
$io->fetch_user_input( $globals );
my %CONFIG = ();
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'DemoRedirect' );
$io->send_user_output( $globals );
1;
demos/guestbook.pl view on Meta::CPAN
__endquote
msg_list_title => 'Previous Reflections', # custom title when reading
msg_list_head => <<__endquote, # custom heading for reading
<H1>Wise Words That You Never Wrote</H1>
<P>Here are the messages that previous visitors wrote. Please stay awhile
and soak in the goodness. You never know what you don't read.</P>
__endquote
);
$globals->current_user_path_level( 1 );
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'DemoGuestBook' );
$io->send_user_output( $globals );
1;
demos/segtext/splitup.pl view on Meta::CPAN
title => 'Index of the World',
author => 'Jules Verne',
created => 'Version 1.0, first created 1993 June 24',
updated => 'Version 3.1, last modified 2000 November 18',
filename => 'jv_world.txt',
segments => 5,
is_text => 1,
);
$globals->current_user_path_level( 1 );
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'DemoTextFile' );
$io->send_user_output( $globals );
1;
demos/smarthouse/DemoX10.pm view on Meta::CPAN
the list of devices that we know about. If you entered that url manually then
please choose from the menu instead. If you did choose from the menu then there
is something wrong with your configuration file.</P>
__endquote
last SWITCH;
}
my $device_context = $globals->make_new_context();
$device_context->inc_user_path_level();
$device_context->navigate_url_path( $current_device );
$device_context->set_prefs( $rh_handler->{'mod_prefs'} );
$device_context->call_component( $rh_handler->{'mod_name'} );
$globals->take_context_output( $device_context );
$globals->prepend_page_body( "<H1>Device Control</H1>\n",
"<P><STRONG>", $rh_handler->{'menu_name'}, "</STRONG></P>\n" );
}
}
1;
demos/smarthouse/config.pl view on Meta::CPAN
# This demo is based on a college lab assignment. It doesn't actually
# control any hardware, but is a simple web interface for such a program
# should one want to extend it in that manner. This is meant to show how
# CGI::Portable can be used in a wide variety of environments, not just
# ordinary database or web sites. If you wanted to extend it then you
# should use modules like ControlX10::CM17, ControlX10::CM11, or
# Device::SerialPort. On the other hand, if you want a very complete
# (and complicated) Perl solution then you can download Bruce Winter's
# free open-source MisterHouse instead at "http://www.misterhouse.net".
my $rh_prefs = {
handlers => {
bed_lamp => {
menu_name => 'Bed Room Lamp',
mod_name => 'DemoLM465',
mod_prefs => { address => 'A2', },
},
shop_lamp => {
menu_name => 'Workshop Light',
mod_name => 'DemoLM465',
mod_prefs => { address => 'A5', },
},
living_lamp => {
menu_name => 'Living Room Lamp',
mod_name => 'DemoLM465',
mod_prefs => { address => 'A6', },
},
},
};
demos/smarthouse/smarthouse_cgi.pl view on Meta::CPAN
# (and complicated) Perl solution then you can download Bruce Winter's
# free open-source MisterHouse instead at "http://www.misterhouse.net".
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( 'DemoX10' );
$io->send_user_output( $globals );
1;
demos/smarthouse/smarthouse_socket.pl view on Meta::CPAN
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,
demos/statics/showhtml.pl view on Meta::CPAN
require CGI::Portable;
my $globals = CGI::Portable->new();
use Cwd;
$globals->file_path_root( cwd() ); # let us default to current working dir
$globals->file_path_delimiter( $^O=~/Mac/i ? ":" : $^O=~/Win/i ? "\\" : "/" );
my %CONFIG = ( filename => 'static.html' );
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'DemoTextFile' );
require CGI::Portable::AdapterCGI;
my $io = CGI::Portable::AdapterCGI->new();
$io->send_user_output( $globals );
1;
demos/statics/showself.pl view on Meta::CPAN
require CGI::Portable;
my $globals = CGI::Portable->new();
use Cwd;
$globals->file_path_root( cwd() ); # let us default to current working dir
$globals->file_path_delimiter( $^O=~/Mac/i ? ":" : $^O=~/Win/i ? "\\" : "/" );
my %CONFIG = ( filename => 'showself.pl', is_text => 1 );
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'DemoTextFile' );
require CGI::Portable::AdapterCGI;
my $io = CGI::Portable::AdapterCGI->new();
$io->send_user_output( $globals );
1;
demos/survey.pl view on Meta::CPAN
email_subj => 'Another Survey Response',
msg_new_title => 'Try Our Survey', # custom title for new messages
msg_new_head => <<__endquote, # custom heading for new messages
<H1>Leave A Message</H1>
<P>Please leave a message after the beep. Answer the questions as faithfully
and truthfully as you can, as we have a lie detector set up and any false
answers will be met with spam.</P>
__endquote
);
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'DemoMailForm' );
$io->send_user_output( $globals );
1;
demos/website/content/content_prefs.pl view on Meta::CPAN
my $rh_preferences = {
add_page_style_code => [
'body {background-color: white; background-image: none}',
'h1, h2 {text-align: center}',
'td {text-align: left; vertical-align: top}',
],
delegate_list => [
{
module_name => 'CGI::Portable::AppStatic',
preferences => 'menu_prefs.pl',
leave_scalars => 1,
},
{
module_name => 'CGI::Portable::AppMultiScreen',
preferences => {
prepend_page_body => "\n<hr />\n",
delegate_list => {
external => {
module_name => 'DemoRedirect',
preferences => { low_http_window_target => 'external_link_window' },
demos/website/content/content_prefs.pl view on Meta::CPAN
module_name => 'DemoTextFile',
preferences => { filename => 'links.html' },
},
},
default_delegate => 'frontdoor',
append_page_body => "\n<hr />\n",
},
},
{
module_name => 'CGI::Portable::AppStatic',
preferences => 'menu_prefs.pl',
leave_scalars => 1,
},
],
append_page_body => <<__endquote,
<p><em>This site is a simple example of what can be done with CGI::Portable and
the Dynamic Website Generator collection of Perl 5 modules, copyright (c)
1999-2001, Darren R. Duncan.</em></p>
__endquote
page_search_and_replace => {
__mailme_url__ => "__url_path__=/mailme",
demos/website/start.pl view on Meta::CPAN
}
$globals->default_application_title( 'Demo Web Site' );
$globals->default_maintainer_name( 'Darren Duncan' );
$globals->default_maintainer_email_address( 'demo@DarrenDuncan.net' );
$globals->default_maintainer_email_screen_url_path( '/mailme' );
my $content = $globals->make_new_context();
$content->current_user_path_level( 1 );
$content->navigate_file_path( 'content' );
$content->set_prefs( 'content_prefs.pl' );
$content->call_component( 'CGI::Portable::AppSplitScreen' );
$globals->take_context_output( $content );
my $usage = $globals->make_new_context();
$usage->http_redirect_url( $globals->http_redirect_url() );
$usage->navigate_file_path( $globals->is_debug() ? 'usage_debug' : 'usage' );
$usage->set_prefs( '../usage_prefs.pl' );
$usage->call_component( 'DemoUsage' );
$globals->take_context_output( $usage, 1 );
if( $globals->is_debug() ) {
$globals->append_page_body( <<__endquote );
<p>Debugging is currently turned on.</p>
__endquote
}
$globals->search_and_replace_url_path_tokens( '__url_path__' );
lib/CGI/Portable.pm view on Meta::CPAN
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;
lib/CGI/Portable.pm view on Meta::CPAN
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,
lib/CGI/Portable.pm view on Meta::CPAN
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'],
lib/CGI/Portable.pm view on Meta::CPAN
'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',
},
},
},
};
lib/CGI/Portable.pm view on Meta::CPAN
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>" );
}
lib/CGI/Portable.pm view on Meta::CPAN
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 );
}
lib/CGI/Portable.pm view on Meta::CPAN
=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
lib/CGI/Portable.pm view on Meta::CPAN
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
lib/CGI/Portable.pm view on Meta::CPAN
=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.
lib/CGI/Portable.pm view on Meta::CPAN
######################################################################
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';
lib/CGI/Portable.pm view on Meta::CPAN
$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}}};
lib/CGI/Portable.pm view on Meta::CPAN
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 {
lib/CGI/Portable.pm view on Meta::CPAN
}
######################################################################
=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} );
}
lib/CGI/Portable/AdapterCGI.pm view on Meta::CPAN
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;
lib/CGI/Portable/AdapterSocket.pm view on Meta::CPAN
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,
lib/CGI/Portable/AppMultiScreen.pm view on Meta::CPAN
require CGI::Portable::AdapterCGI;
my $io = CGI::Portable::AdapterCGI->new();
$io->fetch_user_input( $globals );
$globals->default_application_title( 'Demo Application' );
$globals->default_maintainer_name( 'Tony Simons' );
$globals->default_maintainer_email_address( 'tony@aardvark.net' );
$globals->current_user_path_level( 1 );
$globals->set_prefs( 'myconfig.pl' );
$globals->call_component( 'CGI::Portable::AppMultiScreen' );
$io->send_user_output( $globals );
1;
=head2 Content of file 'myconfig.pl' telling program what to do:
I<This is not a whole example, but you can get an idea what to substitute.
This example shows 5 screens handled by 5 module instances, most of
lib/CGI/Portable/AppMultiScreen.pm view on Meta::CPAN
should look for its files (or config file) if any; if this value is not set then
the current file directory is used instead.
Delegated modules operate within a new "context" created by the current
CGI::Portable object's make_new_context() method. Within that context,
AppMultiScreen does the following: 1. call inc_user_path_level() so that the
delegated module sees a different "current user path element" than this one does;
2. call navigate_url_path() with the "current user path element" as its argument
so that any self-referencing urls generated by the delegated module are correct
for the current screen; 3. call navigate_file_path() with the "file_subdir" value
as its argument; 4. call set_prefs() with the "preferences" value as its
argument; 5. call call_component() with the "module_name" value as its argument.
Finally, the output held by the inner context is saved using the current
CGI::Portable object's take_context_output() method.
=head2 default_delegate
This optional scalar preference is a default value for the "current user path
element" that will be used when processing "delegate_list" in situations where
the existing "current user path element" is not defined or false. The
functionality of this is similar to how web browsers look for specific filenames
lib/CGI/Portable/AppMultiScreen.pm view on Meta::CPAN
the delegate module, including any context-related matters. Otherwise, this
method calls the set_multi_screen_no_delegate_message() method which produces a
default error screen instead.
=cut
######################################################################
sub set_multi_screen_navigate_delegate_list {
my ($self, $globals) = @_;
my $rh_prefs = $globals->get_prefs_ref();
my $user_path_element = $globals->current_user_path_element();
$user_path_element ||= $rh_prefs->{$PKEY_DEFAULT_DELEGATE};
my $delegate = $rh_prefs->{$PKEY_DELEGATE_LIST}->{$user_path_element};
unless( ref( $delegate ) eq 'HASH' ) {
$delegate = $rh_prefs->{$PKEY_UNKNOWN_DELEGATE};
}
if( ref( $delegate ) eq 'HASH' ) {
$self->set_multi_screen_dispatch_one_delegate(
$globals, $delegate, $user_path_element );
} else {
$self->set_multi_screen_no_delegate_message( $globals );
}
}
lib/CGI/Portable/AppMultiScreen.pm view on Meta::CPAN
######################################################################
sub set_multi_screen_dispatch_one_delegate {
my ($self, $globals, $delegate, $user_path_element) = @_;
ref( $delegate ) eq 'HASH' or return( 0 );
my $inner_context = $globals->make_new_context();
$inner_context->inc_user_path_level();
$inner_context->navigate_url_path( $user_path_element );
$inner_context->navigate_file_path( $delegate->{$DKEY_FILE_SUBDIR} );
$inner_context->set_prefs( $delegate->{$DKEY_PREFERENCES} );
$inner_context->call_component( $delegate->{$DKEY_MODULE_NAME} );
$globals->take_context_output( $inner_context );
}
######################################################################
=head2 set_multi_screen_no_delegate_message( GLOBALS )
This method produces a default error screen to use if the user requested a
screen not defined in the "delegate_list" preference, and the "unknown_delegate"
lib/CGI/Portable/AppSplitScreen.pm view on Meta::CPAN
require CGI::Portable::AdapterCGI;
my $io = CGI::Portable::AdapterCGI->new();
$io->fetch_user_input( $globals );
$globals->default_application_title( 'Demo Application' );
$globals->default_maintainer_name( 'Tony Simons' );
$globals->default_maintainer_email_address( 'tony@aardvark.net' );
$globals->current_user_path_level( 1 );
$globals->set_prefs( 'myconfig.pl' );
$globals->call_component( 'CGI::Portable::AppSplitScreen' );
$io->send_user_output( $globals );
1;
=head2 Content of file 'myconfig.pl' telling program what to do:
I<This is not a whole example, but you can get an idea what to substitute.
This example shows 3 screen regions handled by 3 module instances, each of
lib/CGI/Portable/AppSplitScreen.pm view on Meta::CPAN
preferences. The value for "file_subdir" is a relative file system path within
which the invoked module should look for its files (or config file) if any; if
this value is not set then the current file directory is used instead. The
values for "leave_scalars" and "replace_lists" are used when stitching the
delegates' output together, in order to better control when conflicting outputs
have priority over each other (eg: there can be only one document title).
Delegated modules operate within a new "context" created by the current
CGI::Portable object's make_new_context() method. Within that context,
AppSplitScreen does the following: 1. call navigate_file_path() with the
"file_subdir" value as its argument; 2. call set_prefs() with the "preferences"
value as its argument; 3. call call_component() with the "module_name" value as
its argument. Finally, the output held by the inner context is saved using the
current CGI::Portable object's take_context_output() method, which takes the
"leave_scalars" and "replace_lists" values as its last two optional arguments.
=head1 PRIVATE METHODS FOR USE BY SUBCLASSES
=head2 set_split_screen_attach_delegate_list( GLOBALS )
This method will iterate through all the elements of the "delegate_list" array
lib/CGI/Portable/AppSplitScreen.pm view on Meta::CPAN
=cut
######################################################################
sub set_split_screen_attach_one_delegate {
my ($self, $globals, $delegate) = @_;
ref( $delegate ) eq 'HASH' or return( 0 );
my $inner_context = $globals->make_new_context();
$inner_context->navigate_file_path( $delegate->{$DKEY_FILE_SUBDIR} );
$inner_context->set_prefs( $delegate->{$DKEY_PREFERENCES} );
$inner_context->call_component( $delegate->{$DKEY_MODULE_NAME} );
$globals->take_context_output( $inner_context,
$delegate->{$DKEY_LEAVE_SCALARS}, $delegate->{$DKEY_REPLACE_LISTS} );
}
######################################################################
1;
__END__
lib/CGI/Portable/AppStatic.pm view on Meta::CPAN
<td>Question:</td><td>Answer!</td>
</tr><tr>
<td>Another Question:</td>
<td>This is a really really long answer. It just keeps going on and on and
on and on and on and on and on and on and on. However, the short question
should stay top aligned with the long answer due to the stylesheet.</td>
</tr></table>
__endquote
);
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'CGI::Portable::AppStatic' );
require CGI::Portable::AdapterCGI;
my $io = CGI::Portable::AdapterCGI->new();
$io->send_user_output( $globals );
1;
=head2 Simple program that returns an HTTP redirection header:
lib/CGI/Portable/AppStatic.pm view on Meta::CPAN
This method will apply all of the "low" priority preferences, which replace
any respective properties.
=cut
######################################################################
sub set_static_low_replace {
my ($self, $globals) = @_;
my $rh_prefs = $globals->get_prefs_ref();
foreach my $base (@SCALAR_PREFS) {
if( defined( $rh_prefs->{"low_$base"} ) ) {
eval "\$globals->$base( \$rh_prefs->{low_$base} );";
$@ and die;
}
}
foreach my $base (@PREFS_TO_SET) {
if( defined( $rh_prefs->{"low_$base"} ) ) {
eval "\$globals->set_$base( \$rh_prefs->{low_$base} );";
$@ and die;
}
}
}
######################################################################
=head2 set_static_high_replace( GLOBALS )
This method will apply all of the "high" priority preferences, which replace
any respective properties.
=cut
######################################################################
sub set_static_high_replace {
my ($self, $globals) = @_;
my $rh_prefs = $globals->get_prefs_ref();
foreach my $base (@SCALAR_PREFS) {
if( defined( $rh_prefs->{"high_$base"} ) ) {
eval "\$globals->$base( \$rh_prefs->{high_$base} );";
$@ and die;
}
}
foreach my $base (@PREFS_TO_SET) {
if( defined( $rh_prefs->{"high_$base"} ) ) {
eval "\$globals->set_$base( \$rh_prefs->{high_$base} );";
$@ and die;
}
}
}
######################################################################
=head2 set_static_attach_unordered( GLOBALS )
This method will apply all of the "add" preferences, which try to add values to
any respective properties without deleting previous values. Previous values
are only deleted where the properties are hashes and new hash keys are the same
as existing ones; different keys do not conflict.
=cut
######################################################################
sub set_static_attach_unordered {
my ($self, $globals) = @_;
my $rh_prefs = $globals->get_prefs_ref();
foreach my $base (@PREFS_TO_ADD) {
if( defined( $rh_prefs->{"add_$base"} ) ) {
eval "\$globals->add_$base( \$rh_prefs->{add_$base} );";
$@ and die;
}
}
}
######################################################################
=head2 set_static_attach_ordered( GLOBALS )
This method will apply all of the "append" and "prepend" preferences, which will
always add to their respective properties without deleting previous values.
=cut
######################################################################
sub set_static_attach_ordered {
my ($self, $globals) = @_;
my $rh_prefs = $globals->get_prefs_ref();
foreach my $base (@PREFS_TO_PEND) {
if( defined( $rh_prefs->{"append_$base"} ) ) {
eval "\$globals->append_$base( \$rh_prefs->{append_$base} );";
$@ and die;
}
}
foreach my $base (@PREFS_TO_PEND) {
if( defined( $rh_prefs->{"prepend_$base"} ) ) {
eval "\$globals->prepend_$base( \$rh_prefs->{prepend_$base} );";
$@ and die;
}
}
}
######################################################################
=head2 set_static_search_and_replace( GLOBALS )
This method will apply the page_search_and_replace preference, and should be
lib/DemoGuestBook.pm view on Meta::CPAN
$globals->default_application_title( 'Demo Guest Book' );
$globals->default_maintainer_name( 'Tony Simons' );
$globals->default_maintainer_email_address( 'tony@aardvark.net' );
my %CONFIG = (
fn_messages => 'guestbook_messages.txt', # file in simple Boulder format
);
$globals->current_user_path_level( 1 );
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'DemoGuestBook' );
$io->send_user_output( $globals );
1;
=head2 Use Custom Questions Defined Here
my %CONFIG = (
fn_messages => 'guestbook_messages.txt', # file in simple Boulder format
lib/DemoGuestBook.pm view on Meta::CPAN
);
return( \@field_definitions );
}
######################################################################
sub get_question_field_defs {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
# check if we are using default or custom questions
unless( $rh_prefs->{$PKEY_CUSTOM_FD} ) {
return( \@DEF_FORM_QUESTIONS ); # using default
}
my $field_defn = $rh_prefs->{$PKEY_FIELD_DEFN};
# check if we have actual custom questions or filename to them
# check if question file is executable Perl or not
unless( $rh_prefs->{$PKEY_FD_IN_SEQF} ) { # it is Perl file
return( $globals->resolve_prefs_node_to_array( $field_defn ) );
}
# we will now get questions from a simple Boulder formatted file
return( $self->fetch_all_records( $field_defn ) || [] );
}
######################################################################
sub no_questions_error {
my $self = shift( @_ );
lib/DemoMailForm.pm view on Meta::CPAN
require CGI::Portable::AdapterCGI;
my $io = CGI::Portable::AdapterCGI->new();
$io->fetch_user_input( $globals );
$globals->default_application_title( 'Demo Email Form' );
$globals->default_maintainer_name( 'Tony Simons' );
$globals->default_maintainer_email_address( 'tony@aardvark.net' );
my %CONFIG = ();
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'DemoMailForm' );
$io->send_user_output( $globals );
1;
=head2 Use Custom Questions Defined Here
my %CONFIG = (
custom_fd => 1,
lib/DemoMailForm.pm view on Meta::CPAN
);
return( \@field_definitions );
}
######################################################################
sub get_question_field_defs {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
# check if we are using default or custom questions
unless( $rh_prefs->{$PKEY_CUSTOM_FD} ) {
return( \@DEF_FORM_QUESTIONS ); # using default
}
my $field_defn = $rh_prefs->{$PKEY_FIELD_DEFN};
# check if we have actual custom questions or filename to them
# check if question file is executable Perl or not
unless( $rh_prefs->{$PKEY_FD_IN_SEQF} ) { # it is Perl file
return( $globals->resolve_prefs_node_to_array( $field_defn ) );
}
# we will now get questions from a simple Boulder formatted file
return( $self->fetch_all_records( $field_defn ) || [] );
}
######################################################################
sub no_questions_error {
my $self = shift( @_ );
lib/DemoRedirect.pm view on Meta::CPAN
require CGI::Portable;
my $globals = CGI::Portable->new();
require CGI::Portable::AdapterCGI;
my $io = CGI::Portable::AdapterCGI->new();
$io->fetch_user_input( $globals );
my %CONFIG = ();
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'DemoRedirect' );
$io->send_user_output( $globals );
1;
=head1 DESCRIPTION
This Perl 5 object class is part of a demonstration of CGI::Portable in use.
It is one of a set of "application components" that takes its settings and user
lib/DemoTextFile.pm view on Meta::CPAN
require CGI::Portable;
my $globals = CGI::Portable->new();
use Cwd;
$globals->file_path_root( cwd() ); # let us default to current working dir
$globals->file_path_delimiter( $^O=~/Mac/i ? ":" : $^O=~/Win/i ? "\\" : "/" );
my %CONFIG = ( filename => 'intro.html' );
$globals->set_prefs( \%CONFIG );
$globals->call_component( 'DemoTextFile' );
require CGI::Portable::AdapterCGI;
my $io = CGI::Portable::AdapterCGI->new();
$io->send_user_output( $globals );
1;
=head2 Display A Plain Text File By Itself -- HTML Escaped
lib/DemoTextFile.pm view on Meta::CPAN
$self->set_static_attach_unordered( $globals );
$self->set_static_attach_ordered( $globals );
$self->set_static_search_and_replace( $globals );
}
######################################################################
sub main_dispatch {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
my $segments = $rh_prefs->{$PKEY_SEGMENTS};
$segments >= 1 or $rh_prefs->{$PKEY_SEGMENTS} = $segments = 1;
my $curr_seg_num = $globals->current_user_path_element();
$curr_seg_num >= 1 or $curr_seg_num = 1;
$curr_seg_num <= $segments or $curr_seg_num = $segments;
$globals->current_user_path_element( $curr_seg_num );
$self->get_curr_seg_content();
if( $segments > 1 ) {
$self->attach_document_navbar();
}
if( $rh_prefs->{$PKEY_TITLE} ) {
$self->attach_document_header();
}
}
######################################################################
sub get_curr_seg_content {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
my $is_multi_segmented = $rh_prefs->{$PKEY_SEGMENTS} > 1;
my ($base, $ext) = ($rh_prefs->{$PKEY_FILENAME} =~ m/^([^\.]*)(.*)$/);
my $seg_num_str = $is_multi_segmented ?
'_'.sprintf( "%3.3d", $globals->current_user_path_element() ) : '';
my $filename = "$base$seg_num_str$ext";
my $physical_path = $globals->physical_filename(
$is_multi_segmented ? [$base, $filename] : $filename );
SWITCH: {
$globals->add_no_error();
lib/DemoTextFile.pm view on Meta::CPAN
local $/ = undef;
defined( my $file_content = <STATIC> ) or do {
$globals->add_virtual_filename_error( "read from", $filename );
last SWITCH;
};
close( STATIC ) or do {
$globals->add_virtual_filename_error( "close", $filename );
last SWITCH;
};
if( $rh_prefs->{$PKEY_IS_TEXT} ) {
$file_content =~ s/&/&/g; # do some html escaping
$file_content =~ s/\"/"/g;
$file_content =~ s/>/>/g;
$file_content =~ s/</</g;
$globals->set_page_body(
[ "\n<pre>\n", $file_content, "\n</pre>\n" ] );
} elsif( $file_content =~ m|<body[^>]*>(.*)</body>|si ) {
$globals->set_page_body( $1 );
lib/DemoTextFile.pm view on Meta::CPAN
$globals->add_no_error();
}
}
######################################################################
sub attach_document_navbar {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $segments = $globals->get_prefs_ref()->{$PKEY_SEGMENTS};
my $curr_seg_num = $globals->current_user_path_element();
my $seg_token = '__std_seg_token__';
my $common_url = $globals->url_as_string( $seg_token );
my @seg_list_html = ();
foreach my $seg_num (1..$segments) {
if( $seg_num == $curr_seg_num ) {
push( @seg_list_html, "$seg_num\n" );
} else {
my $curr_seg_html = "<a href=\"$common_url\">$seg_num</a>\n";
lib/DemoTextFile.pm view on Meta::CPAN
$globals->prepend_page_body( [$document_navbar] );
$globals->append_page_body( [$document_navbar] );
}
######################################################################
sub attach_document_header {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
my $title = $rh_prefs->{$PKEY_TITLE};
my $author = $rh_prefs->{$PKEY_AUTHOR};
my $created = $rh_prefs->{$PKEY_CREATED};
my $updated = $rh_prefs->{$PKEY_UPDATED};
my $segments = $rh_prefs->{$PKEY_SEGMENTS};
my $curr_seg_num = $globals->current_user_path_element();
$title .= $segments > 1 ? ": $curr_seg_num / $segments" : '';
$globals->page_title( $title );
$globals->prepend_page_body( <<__endquote );
<h1>@{[$globals->page_title()]}</h1>
<p>Author: $author<br />
lib/DemoUsage.pm view on Meta::CPAN
}
$globals->default_application_title( 'Demo Web Site' );
$globals->default_maintainer_name( 'Tony Simons' );
$globals->default_maintainer_email_address( 'tony@aardvark.net' );
$globals->default_maintainer_email_screen_url_path( '/mailme' );
my $content = $globals->make_new_context();
$content->current_user_path_level( 1 );
$content->navigate_file_path( 'content' );
$content->set_prefs( 'content_prefs.pl' );
$content->call_component( 'CGI::Portable::AppSplitScreen' );
$globals->take_context_output( $content );
my $usage = $globals->make_new_context();
$usage->http_redirect_url( $globals->http_redirect_url() );
$usage->navigate_file_path( $globals->is_debug() ? 'usage_debug' : 'usage' );
$usage->set_prefs( '../usage_prefs.pl' );
$usage->call_component( 'DemoUsage' );
$globals->take_context_output( $usage, 1 );
if( $globals->is_debug() ) {
$globals->append_page_body( <<__endquote );
<p>Debugging is currently turned on.</p>
__endquote
}
$globals->search_and_replace_url_path_tokens( '__url_path__' );
$io->send_user_output( $globals );
1;
=head2 Content of settings file "content_prefs.pl"
I<Please see the included demo called "website" for this file.>
=head2 Content of settings file "usage_prefs.pl", tracking as much as possible
my $rh_preferences = {
email_logs => 1, # do we want to be sent daily reports?
fn_dcm => 'date_counts_mailed.txt', # our lock file to track mailings
mailing => [ # keep different types of reports in own emails
{
filenames => 'env.txt',
subject_unique => ' -- usage (env) to ',
}, {
filenames => 'site_vrp.txt',
lib/DemoUsage.pm view on Meta::CPAN
$self->{$KEY_SITE_GLOBALS} = $globals;
$self->main_dispatch();
}
######################################################################
sub main_dispatch {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
$rh_prefs->{$PKEY_TOKEN_TOTAL} ||= '__total__';
$rh_prefs->{$PKEY_TOKEN_NIL} ||= '__nil__';
$self->email_and_reset_counts_if_new_day();
$self->update_env_counts();
$self->update_site_vrp_counts();
$self->update_redirect_counts();
$self->update_referrer_counts();
# Note that we don't presently print hit counts to the webpage.
# But that'll likely be added later, along with web usage reports.
}
######################################################################
sub email_and_reset_counts_if_new_day {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
$rh_prefs->{$PKEY_EMAIL_LOGS} or return( 1 );
my $dcm_file =
DemoUsage::CountFile->new( $globals, $rh_prefs->{$PKEY_FN_DCM} );
$dcm_file->open_and_lock( 1 ) or return( undef );
$dcm_file->read_all_records();
if( $dcm_file->key_was_incremented_today(
$rh_prefs->{$PKEY_TOKEN_TOTAL} ) ) {
$dcm_file->unlock_and_close();
return( 1 );
}
$dcm_file->key_increment( $rh_prefs->{$PKEY_TOKEN_TOTAL} );
$dcm_file->write_all_records();
$dcm_file->unlock_and_close();
my $ra_mail_prefs = $rh_prefs->{$PKEY_MAILING};
ref( $ra_mail_prefs ) eq 'ARRAY' or $ra_mail_prefs = [$ra_mail_prefs];
foreach my $rh_mail_pref (@{$ra_mail_prefs}) {
ref( $rh_mail_pref ) eq 'HASH' or next;
my $ra_filenames = $rh_mail_pref->{$MKEY_FILENAMES} || [];
ref( $ra_filenames ) eq 'ARRAY' or $ra_filenames = [$ra_filenames];
my $erase_files = $rh_mail_pref->{$MKEY_ERASE_FILES};
my @mail_body = ();
foreach my $filename (@{$ra_filenames}) {
$filename or next;
lib/DemoUsage.pm view on Meta::CPAN
$globals->add_error( "can't e-mail usage counts: $err_msg" );
}
}
}
######################################################################
sub update_env_counts {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
my $rh_log_prefs = $rh_prefs->{$PKEY_LOG_ENV};
ref( $rh_log_prefs ) eq 'HASH' or return( 0 );
my $filename = $rh_log_prefs->{$LKEY_FILENAME} or return( 0 );
my $ra_var_list = $rh_log_prefs->{$EKEY_VAR_LIST};
ref( $ra_var_list ) eq 'ARRAY' or $ra_var_list = [$ra_var_list];
# save miscellaneous low-distribution environment vars
$self->update_one_count_file( $filename,
(map { "\$ENV{$_} = \"$ENV{$_}\"" } @{$ra_var_list}) );
}
######################################################################
sub update_site_vrp_counts {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
my $rh_log_prefs = $rh_prefs->{$PKEY_LOG_SITE};
ref( $rh_log_prefs ) eq 'HASH' or return( 0 );
my $filename = $rh_log_prefs->{$LKEY_FILENAME} or return( 0 );
my $t_rd = $rh_log_prefs->{$SKEY_TOKEN_REDIRECT} || '__external_url__';
# save which page within this site was hit
$self->update_one_count_file( $filename,
$globals->user_path_string(),
$globals->http_redirect_url() ? $t_rd : () );
}
######################################################################
sub update_redirect_counts {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
my $rh_log_prefs = $rh_prefs->{$PKEY_LOG_REDIRECT};
ref( $rh_log_prefs ) eq 'HASH' or return( 0 );
my $filename = $rh_log_prefs->{$LKEY_FILENAME} or return( 0 );
# save which url this site referred the visitor to, if any
$self->update_one_count_file( $filename, $globals->http_redirect_url() );
}
######################################################################
sub update_referrer_counts {
my $self = shift( @_ );
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
my $rh_log_prefs = $rh_prefs->{$PKEY_LOG_REFERRER};
ref( $rh_log_prefs ) eq 'HASH' or return( 0 );
my $fn_normal = $rh_log_prefs->{$LKEY_FILENAME};
my $fn_search = $rh_log_prefs->{$RKEY_FN_SEARCH};
my $fn_keywords = $rh_log_prefs->{$RKEY_FN_KEYWORDS};
my $fn_discards = $rh_log_prefs->{$RKEY_FN_DISCARDS};
my $t_rfs = $rh_log_prefs->{$RKEY_TOKEN_REF_SELF} || '__self_reference__';
my $t_rfo = $rh_log_prefs->{$RKEY_TOKEN_REF_OTHER} || '__other_reference__';
my $ra_discards = $rh_log_prefs->{$RKEY_DISCARDS} || [];
ref( $ra_discards ) eq 'ARRAY' or $ra_discards = [$ra_discards];
my $rh_engines = $rh_log_prefs->{$RKEY_SEARCH_ENGINES};
ref( $rh_engines ) eq 'HASH' or $rh_engines = {};
# save which url had referred visitors to this site
my (@ref_norm, @ref_sear, @ref_keyw, @ref_disc);
SWITCH: {
my $referer = $globals->referer();
my ($ref_filename, $query) = split( /\?/, $referer, 2 );
$ref_filename =~ s|/$||; # lose trailing "/"s
$referer = ($query =~ /[a-zA-Z0-9]/) ?
lib/DemoUsage.pm view on Meta::CPAN
$fn_search and $self->update_one_count_file( $fn_search, @ref_sear );
$fn_keywords and $self->update_one_count_file( $fn_keywords, @ref_keyw );
$fn_discards and $self->update_one_count_file( $fn_discards, @ref_disc );
}
######################################################################
sub update_one_count_file {
my ($self, $filename, @keys_to_inc) = @_;
my $globals = $self->{$KEY_SITE_GLOBALS};
my $rh_prefs = $globals->get_prefs_ref();
push( @keys_to_inc, $rh_prefs->{$PKEY_TOKEN_TOTAL} );
my $count_file =
DemoUsage::CountFile->new( $globals, $filename );
$count_file->open_and_lock( 1 ) or return( undef );
$count_file->read_all_records();
foreach my $key (@keys_to_inc) {
$key eq '' and $key = $rh_prefs->{$PKEY_TOKEN_NIL};
$count_file->key_increment( $key );
}
$count_file->write_all_records();
$count_file->unlock_and_close();
}
######################################################################
sub send_email_message {
( run in 2.339 seconds using v1.01-cache-2.11-cpan-0bb4e1dffa6 )