ASP4
view release on metacpan or search on metacpan
- Documentation overhaul.
2011-03-23 v1.042
- Fixed sporadic error in master pages that looks like this:
Can't call method "Write" on an undefined value at /tmp/PAGE_CACHE/BStat/_masters_global_asp.pm line 1.
- Apparently $s->init_asp_objects($context) was not getting called before the
master page's run() method was called, resulting in a call to $Response->Write(...)
before $Response had been initialized.
2010-11-11 v1.041
- ASP4::UserAgent calls all cleanup handlers registered via $Server->RegisterCleanup(sub { }, @args)
at the end of each request, not when the ASP4::Mock::Pool object's DESTROY method is called.
This fixes a condition which caused conflict when a Class::DBI::Lite ORM is
used and the ASP4 application is executed via the `asp4` helper script.
2010-10-25 v1.040
- 1.039 introduced a bug that could cause session-id conflicts in the asp_sessions table.
- This release fixes that bug.
2010-10-25 v1.039
- Session expiration now happens exclusively on the server, not as the
README.markdown view on Meta::CPAN
<body>
<p>This is an html email.</p>
<p>You can see that <b>this text is bold</b>.</p>
</body>
</html>
HTML
);
Please see [Mail::Sendmail](http://search.cpan.org/perldoc?Mail::Sendmail) for further details and examples.
### $Server->RegisterCleanup( sub { ... }, \@args )
After the final response has been sent to the client, the server will execute
your subref and provide it the `\@args` passed in.
This is useful for long-running or asynchronous processes that don't require the
client to wait for a response.
## $Request
An instance of [ASP4::Request](http://search.cpan.org/perldoc?ASP4::Request), the `$Request` object contains specialized methods
README.markdown view on Meta::CPAN
__PACKAGE__->has_many(
messages_out =>
'App::db::message' =>
'from_user_id'
);
# Hash the password before storing it in the database:
__PACKAGE__->add_trigger( before_create => sub {
my ($self) = @_;
# Sign the password instead of storing it as plaintext:
unless( $self->{password} =~ m{^([a-f0-9]{32})$}i ) {
$self->{password} = $self->hash_password( $self->password );
}
});
# Hash the new password before storing it in the database:
__PACKAGE__->add_trigger( before_update_password => sub {
my ($self, $old, $new) = @_;
unless( $new =~ m{^([a-f0-9]{32})$}i ) {
$self->{password} = $self->hash_password( $new );
}
});
# Verify an email/password combination and return the user if a match is found:
sub check_credentials {
my ($self, %args) = @_;
my ($result) = $self->search(
email => $args{email},
password => $self->hash_password( $args{password} ),
);
$result ? return $result : return;
}
# Convert a password string into its hashed value:
sub hash_password {
my ($self, $str) = @_;
my $key = ASP4::ConfigLoader->load->system->settings->signing_key;
return md5_hex( $str . $key );
}
1;# return true:
README.markdown view on Meta::CPAN
<asp:Content PlaceHolderID="main_content">
<%
# Sticky forms work like this:
if( my $args = $Session->{__lastArgs} ) {
map { $Form->{$_} = $args->{$_} } keys %$args;
}
# Our validation errors:
my $errors = $Session->{validation_errors} || { };
$::err = sub {
my $field = shift;
my $error = $errors->{$field} or return;
%><span class="field_error"><%= $Server->HTMLEncode( $error ) %></span><%
};
%>
<form id="register_form" method="post" action="/handlers/myapp.register">
<p>
<label>Email:</label>
<input type="text" name="email" value="<%= $Server->HTMLEncode( $Form->{email} ) %>" />
<% $::err->("email"); %>
README.markdown view on Meta::CPAN
package app::register;
use strict;
use warnings 'all';
use base 'ASP4::FormHandler';
use vars __PACKAGE__->VARS; # Import $Response, $Form, $Session, etc
use App::db::user;
sub run {
my ($self, $context) = @_;
# If there is an error, return the user to the registration page:
if( my $errors = $self->validate() ) {
$Session->{validation_errors} = $errors;
$Session->{__lastArgs} = $Form;
$Session->save;
return $Response->Redirect( $ENV{HTTP_REFERER} );
}
# Create the user:
my $user = eval {
App::db::user->do_transaction(sub {
return App::db::user->create(
email => $Form->{email},
password => $Form->{password},
);
});
};
if( $@ ) {
# There was an error:
README.markdown view on Meta::CPAN
$Session->{msg} = "Thank you for registering!";
$Session->save;
# Redirect to /profile.asp:
return $Response->Redirect("/profile.asp");
}# end if()
}
sub validate {
my ($self) = @_;
$self->trim_form;
my $errors = { };
no warnings 'uninitialized';
README.markdown view on Meta::CPAN
use strict;
use warnings 'all';
use base 'ASP4::FormHandler';
use vars __PACKAGE__->VARS;
use App::db::user;
use App::db::message;
sub run {
my ($self, $context) = @_;
# Create the message:
my $msg = eval {
App::db::message->do_transaction(sub {
my $msg = App::db::message->create(
from_user_id => $Session->{user_id},
to_user_id => $Form->{to_user_id},
subject => $Form->{subject},
body => $Form->{body},
);
# Send an email to the recipient:
$Server->Mail(
inc/Module/Install.pm view on Meta::CPAN
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
unless ( uc($1) eq $1 ) {
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
}
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
$self->{admin}->init;
@_ = ($class, _self => $self);
inc/Module/Install.pm view on Meta::CPAN
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{"$self->{file}"};
delete $INC{"$self->{path}.pm"};
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
my $admin = $self->{admin};
inc/Module/Install.pm view on Meta::CPAN
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
next unless $obj->can($method);
next if $method =~ /^_/;
next if $method eq uc($method);
$seen{$method}++;
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
inc/Module/Install.pm view on Meta::CPAN
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
foreach my $obj (@{$self->{extensions}}) {
return $obj if $obj->can($method);
}
inc/Module/Install.pm view on Meta::CPAN
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my $obj = $admin->load($method, 1);
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
inc/Module/Install.pm view on Meta::CPAN
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} = delete $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
inc/Module/Install.pm view on Meta::CPAN
@found;
}
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open FH, "< $_[0]" or die "open($_[0]): $!";
my $str = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $str;
}
sub _write {
local *FH;
open FH, "> $_[0]" or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
) ? $_[0] : undef;
}
1;
inc/Module/Install/Base.pm view on Meta::CPAN
#line 1
package Module::Install::Base;
$VERSION = '0.79';
# Suspend handler for "redefined" warnings
BEGIN {
my $w = $SIG{__WARN__};
$SIG{__WARN__} = sub { $w };
}
### This is the ONLY module that shouldn't have strict on
# use strict;
#line 41
sub new {
my ($class, %args) = @_;
foreach my $method ( qw(call load) ) {
*{"$class\::$method"} = sub {
shift()->_top->$method(@_);
} unless defined &{"$class\::$method"};
}
bless( \%args, $class );
}
#line 61
sub AUTOLOAD {
my $self = shift;
local $@;
my $autoload = eval { $self->_top->autoload } or return;
goto &$autoload;
}
#line 76
sub _top { $_[0]->{_top} }
#line 89
sub admin {
$_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
}
#line 101
sub is_admin {
$_[0]->admin->VERSION;
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
my $Fake;
sub new { $Fake ||= bless(\@_, $_[0]) }
sub AUTOLOAD {}
sub DESTROY {}
# Restore warning handler
BEGIN {
$SIG{__WARN__} = $SIG{__WARN__}->();
}
1;
#line 146
inc/Module/Install/Can.pm view on Meta::CPAN
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.79';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
# check if we can load some module
### Upgrade this to not have to load the module if possible
sub can_use {
my ($self, $mod, $ver) = @_;
$mod =~ s{::|\\}{/}g;
$mod .= '.pm' unless $mod =~ /\.pm$/i;
my $pkg = $mod;
$pkg =~ s{/}{::}g;
$pkg =~ s{\.pm$}{}i;
local $@;
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
# check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
my $_cmd = $cmd;
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
my $abs = File::Spec->catfile($dir, $_[1]);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
# can we locate a (the) C compiler
sub can_cc {
my $self = shift;
my @chunks = split(/ /, $Config::Config{cc}) or return;
# $Config{cc} may contain args; try to find out the program part
while (@chunks) {
return $self->can_run("@chunks") || (pop(@chunks), next);
}
return;
}
# Fix Cygwin bug on maybe_command();
if ( $^O eq 'cygwin' ) {
require ExtUtils::MM_Cygwin;
require ExtUtils::MM_Win32;
if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
*ExtUtils::MM_Cygwin::maybe_command = sub {
my ($self, $file) = @_;
if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
ExtUtils::MM_Win32->maybe_command($file);
} else {
ExtUtils::MM_Unix->maybe_command($file);
}
}
}
}
inc/Module/Install/Fetch.pm view on Meta::CPAN
use strict;
use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.79';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
inc/Module/Install/Makefile.pm view on Meta::CPAN
use Module::Install::Base;
use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.79';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
sub Makefile { $_[0] }
my %seen = ();
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing, always use defaults
if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
sub makemaker_args {
my $self = shift;
my $args = ( $self->{makemaker_args} ||= {} );
%$args = ( %$args, @_ );
return $args;
}
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
my $self = sShift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{name} = defined $args->{$name}
? join( ' ', $args->{name}, @_ )
: join( ' ', @_ );
}
sub build_subdirs {
my $self = shift;
my $subdirs = $self->makemaker_args->{DIR} ||= [];
for my $subdir (@_) {
push @$subdirs, $subdir;
}
}
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
sub libs {
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
my %test_dir = ();
sub _wanted_t {
/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}
sub tests_recursive {
my $self = shift;
if ( $self->tests ) {
die "tests_recursive will not work if tests are already defined";
}
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
%test_dir = ();
require File::Find;
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Make sure we have a new enough
require ExtUtils::MakeMaker;
# MakeMaker can complain about module versions that include
# an underscore, even though its own version may contain one!
# Hence the funny regexp to get rid of it. See RT #35800
# for details.
inc/Module/Install/Makefile.pm view on Meta::CPAN
if (my $preop = $self->admin->preop($user_preop)) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
my $self = shift;
my $makefile_name = shift;
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
inc/Module/Install/Makefile.pm view on Meta::CPAN
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
sub postamble {
my ($self, $text) = @_;
$self->{postamble} ||= $self->admin->postamble;
$self->{postamble} .= $text if defined $text;
$self->{postamble}
}
1;
__END__
inc/Module/Install/Metadata.pm view on Meta::CPAN
bundles
resources
};
my @resource_keys = qw{
homepage
bugtracker
repository
};
sub Meta { shift }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}{$key} if defined wantarray and !@_;
$self->{values}{$key} = shift;
return $self;
};
}
foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
return () unless $self->{values}{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
@{ $self->{values}{resources} };
}
return $self->{values}{resources}{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
$self->resources( $key => $uri );
return 1;
};
}
sub requires {
my $self = shift;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @{ $self->{values}{requires} }, [ $module, $version ];
}
$self->{values}{requires};
}
sub build_requires {
my $self = shift;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @{ $self->{values}{build_requires} }, [ $module, $version ];
}
$self->{values}{build_requires};
}
sub configure_requires {
my $self = shift;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @{ $self->{values}{configure_requires} }, [ $module, $version ];
}
$self->{values}{configure_requires};
}
sub recommends {
my $self = shift;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @{ $self->{values}{recommends} }, [ $module, $version ];
}
$self->{values}{recommends};
}
sub bundles {
my $self = shift;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @{ $self->{values}{bundles} }, [ $module, $version ];
}
$self->{values}{bundles};
}
# Resource handling
my %lc_resource = map { $_ => 1 } qw{
homepage
license
bugtracker
repository
};
sub resources {
my $self = shift;
while ( @_ ) {
my $name = shift or last;
my $value = shift or next;
if ( $name eq lc $name and ! $lc_resource{$name} ) {
die("Unsupported reserved lowercase resource '$name'");
}
$self->{values}{resources} ||= [];
push @{ $self->{values}{resources} }, [ $name, $value ];
}
$self->{values}{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub sign {
my $self = shift;
return $self->{values}{sign} if defined wantarray and ! @_;
$self->{values}{sign} = ( @_ ? $_[0] : 1 );
return $self;
}
sub dynamic_config {
my $self = shift;
unless ( @_ ) {
warn "You MUST provide an explicit true/false value to dynamic_config\n";
return $self;
}
$self->{values}{dynamic_config} = $_[0] ? 1 : 0;
return 1;
}
sub perl_version {
my $self = shift;
return $self->{values}{perl_version} unless @_;
my $version = shift or die(
"Did not provide a value to perl_version()"
);
# Normalize the version
$version = $self->_perl_version($version);
# We don't support the reall old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
$self->{values}{perl_version} = $version;
}
sub license {
my $self = shift;
return $self->{values}{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
$self->{values}{license} = $license;
# Automatically fill in license URLs
if ( $license eq 'perl' ) {
$self->resources( license => 'http://dev.perl.org/licenses/' );
}
return 1;
}
sub all_from {
my ( $self, $file ) = @_;
unless ( defined($file) ) {
my $name = $self->name or die(
"all_from called with no args without setting name() first"
);
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
$file =~ s{.*/}{} unless -e $file;
unless ( -e $file ) {
die("all_from cannot find $file from $name");
inc/Module/Install/Metadata.pm view on Meta::CPAN
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
$self->author_from($pod) unless $self->author;
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
return 1;
}
sub provides {
my $self = shift;
my $provides = ( $self->{values}{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
sub auto_provides {
my $self = shift;
return $self unless $self->is_admin;
unless (-e 'MANIFEST') {
warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
return $self;
}
# Avoid spurious warnings as we are not checking manifest here.
local $SIG{__WARN__} = sub {1};
require ExtUtils::Manifest;
local *ExtUtils::Manifest::manicheck = sub { return };
require Module::Build;
my $build = Module::Build->new(
dist_name => $self->name,
dist_version => $self->version,
license => $self->license,
);
$self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
my $self = shift;
my $name = shift;
my $features = ( $self->{values}{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
inc/Module/Install/Metadata.pm view on Meta::CPAN
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
} @$mods
]
);
return @$features;
}
sub features {
my $self = shift;
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
return $self->{values}{features}
? @{ $self->{values}{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{values}{no_index}{$type} }, @_ if $type;
return $self->{values}{no_index};
}
sub read {
my $self = shift;
$self->include_deps( 'YAML::Tiny', 0 );
require YAML::Tiny;
my $data = YAML::Tiny::LoadFile('META.yml');
# Call methods explicitly in case user has already set some values.
while ( my ( $key, $value ) = each %$data ) {
next unless $self->can($key);
if ( ref $value eq 'HASH' ) {
while ( my ( $module, $version ) = each %$value ) {
$self->can($key)->($self, $module => $version );
}
} else {
$self->can($key)->($self, $value);
}
}
return $self;
}
sub write {
my $self = shift;
return $self unless $self->is_admin;
$self->admin->write_meta;
return $self;
}
sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->abstract(
bless(
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
);
}
# Add both distribution and module name
sub name_from {
my ($self, $file) = @_;
if (
Module::Install::_read($file) =~ m/
^ \s*
package \s*
([\w:]+)
\s* ;
/ixms
) {
my ($name, $module_name) = ($1, $1);
$name =~ s{::}{-}g;
$self->name($name);
unless ( $self->module_name ) {
$self->module_name($module_name);
}
} else {
die("Cannot determine name from $file\n");
}
}
sub perl_version_from {
my $self = shift;
if (
Module::Install::_read($_[0]) =~ m/
^
(?:use|require) \s*
v?
([\d_\.]+)
\s* ;
/ixms
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
return;
}
}
sub author_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
if ($content =~ m/
=head \d \s+ (?:authors?)\b \s*
([^\n]*)
|
=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
([^\n]*)
/ixms) {
my $author = $1 || $2;
$author =~ s{E<lt>}{<}g;
$author =~ s{E<gt>}{>}g;
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
sub license_from {
my $self = shift;
if (
Module::Install::_read($_[0]) =~ m/
(
=head \d \s+
(?:licen[cs]e|licensing|copyright|legal)\b
.*?
)
(=head\\d.*|=cut.*|)
\z
inc/Module/Install/Metadata.pm view on Meta::CPAN
$self->license($license);
return 1;
}
}
}
warn "Cannot determine license info from $_[0]\n";
return 'unknown';
}
sub bugtracker_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
unless ( @links ) {
warn "Cannot determine bugtracker info from $_[0]\n";
return 0;
}
if ( @links > 1 ) {
warn "Found more than on rt.cpan.org link in $_[0]\n";
return 0;
}
# Set the bugtracker
bugtracker( $links[0] );
return 1;
}
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
$v = $v + 0; # Numify
}
return $v;
}
######################################################################
# MYMETA.yml Support
sub WriteMyMeta {
$_[0]->write_mymeta;
}
sub write_mymeta {
my $self = shift;
# If there's no existing META.yml there is nothing we can do
return unless -f 'META.yml';
# Merge the perl version into the dependencies
my $val = $self->Meta->{values};
my $perl = delete $val->{perl_version};
if ( $perl ) {
$val->{requires} ||= [];
inc/Module/Install/Scripts.pm view on Meta::CPAN
use strict 'vars';
use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.80';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
sub install_script {
my $self = shift;
my $args = $self->makemaker_args;
my $exe = $args->{EXE_FILES} ||= [];
foreach ( @_ ) {
if ( -f $_ ) {
push @$exe, $_;
} elsif ( -d 'script' and -f "script/$_" ) {
push @$exe, "script/$_";
} else {
die("Cannot find script '$_'");
inc/Module/Install/Win32.pm view on Meta::CPAN
use Module::Install::Base;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.79';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
require Config;
return unless (
$^O eq 'MSWin32' and
$Config::Config{make} and
$Config::Config{make} =~ /^nmake\b/i and
! $self->can_run('nmake')
inc/Module/Install/WriteAll.pm view on Meta::CPAN
use strict;
use Module::Install::Base;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.79';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
sub WriteAll {
my $self = shift;
my %args = (
meta => 1,
sign => 0,
inline => 0,
check_nmake => 1,
@_,
);
$self->sign(1) if $args{sign};
lib/ASP4.pm view on Meta::CPAN
<body>
<p>This is an html email.</p>
<p>You can see that <b>this text is bold</b>.</p>
</body>
</html>
HTML
);
Please see L<Mail::Sendmail> for further details and examples.
=head3 $Server->RegisterCleanup( sub { ... }, \@args )
After the final response has been sent to the client, the server will execute
your subref and provide it the C<\@args> passed in.
This is useful for long-running or asynchronous processes that don't require the
client to wait for a response.
=head2 $Request
An instance of L<ASP4::Request>, the C<$Request> object contains specialized methods
lib/ASP4.pm view on Meta::CPAN
'to_user_id'
);
__PACKAGE__->has_many(
messages_out =>
'App::db::message' =>
'from_user_id'
);
# Hash the password before storing it in the database:
__PACKAGE__->add_trigger( before_create => sub {
my ($self) = @_;
# Sign the password instead of storing it as plaintext:
unless( $self->{password} =~ m{^([a-f0-9]{32})$}i ) {
$self->{password} = $self->hash_password( $self->password );
}
});
# Hash the new password before storing it in the database:
__PACKAGE__->add_trigger( before_update_password => sub {
my ($self, $old, $new) = @_;
unless( $new =~ m{^([a-f0-9]{32})$}i ) {
$self->{password} = $self->hash_password( $new );
}
});
# Verify an email/password combination and return the user if a match is found:
sub check_credentials {
my ($self, %args) = @_;
my ($result) = $self->search(
email => $args{email},
password => $self->hash_password( $args{password} ),
);
$result ? return $result : return;
}
# Convert a password string into its hashed value:
sub hash_password {
my ($self, $str) = @_;
my $key = ASP4::ConfigLoader->load->system->settings->signing_key;
return md5_hex( $str . $key );
}
1;# return true:
C<lib/App/db/message.pm>
lib/ASP4.pm view on Meta::CPAN
<asp:Content PlaceHolderID="main_content">
<%
# Sticky forms work like this:
if( my $args = $Session->{__lastArgs} ) {
map { $Form->{$_} = $args->{$_} } keys %$args;
}
# Our validation errors:
my $errors = $Session->{validation_errors} || { };
$::err = sub {
my $field = shift;
my $error = $errors->{$field} or return;
%><span class="field_error"><%= $Server->HTMLEncode( $error ) %></span><%
};
%>
<form id="register_form" method="post" action="/handlers/myapp.register">
<p>
<label>Email:</label>
<input type="text" name="email" value="<%= $Server->HTMLEncode( $Form->{email} ) %>" />
<% $::err->("email"); %>
lib/ASP4.pm view on Meta::CPAN
File: C<handlers/app/register.pm>
package app::register;
use strict;
use warnings 'all';
use base 'ASP4::FormHandler';
use vars __PACKAGE__->VARS; # Import $Response, $Form, $Session, etc
use App::db::user;
sub run {
my ($self, $context) = @_;
# If there is an error, return the user to the registration page:
if( my $errors = $self->validate() ) {
$Session->{validation_errors} = $errors;
$Session->{__lastArgs} = $Form;
$Session->save;
return $Response->Redirect( $ENV{HTTP_REFERER} );
}
# Create the user:
my $user = eval {
App::db::user->do_transaction(sub {
return App::db::user->create(
email => $Form->{email},
password => $Form->{password},
);
});
};
if( $@ ) {
# There was an error:
$Session->{validation_errors} = {email => "Server error. Sorry!"};
lib/ASP4.pm view on Meta::CPAN
# No error - Sign them in:
$Session->{user_id} = $user->id;
$Session->{msg} = "Thank you for registering!";
$Session->save;
# Redirect to /profile.asp:
return $Response->Redirect("/profile.asp");
}# end if()
}
sub validate {
my ($self) = @_;
$self->trim_form;
my $errors = { };
no warnings 'uninitialized';
# email:
if( length($Form->{email}) ) {
# Basic email validation:
lib/ASP4.pm view on Meta::CPAN
package app::send;
use strict;
use warnings 'all';
use base 'ASP4::FormHandler';
use vars __PACKAGE__->VARS;
use App::db::user;
use App::db::message;
sub run {
my ($self, $context) = @_;
# Create the message:
my $msg = eval {
App::db::message->do_transaction(sub {
my $msg = App::db::message->create(
from_user_id => $Session->{user_id},
to_user_id => $Form->{to_user_id},
subject => $Form->{subject},
body => $Form->{body},
);
# Send an email to the recipient:
$Server->Mail(
from => 'root@localhost',
lib/ASP4/API.pm view on Meta::CPAN
package ASP4::API;
use strict;
use warnings 'all';
use ASP4::ConfigLoader;
use ASP4::HTTPContext;
use ASP4::UserAgent;
use ASP4::Test::Fixtures;
BEGIN { ASP4::ConfigLoader->load }
sub new
{
my ($class) = @_;;
my $config = ASP4::ConfigLoader->load;
# Our test fixtures:
my $test_data;
if( -f $config->web->application_root . '/etc/test_fixtures.json' )
{
eval { require Data::Properties::JSON };
lib/ASP4/API.pm view on Meta::CPAN
return bless {
test_fixtures => $test_data,
properties => $properties,
ua => ASP4::UserAgent->new(),
config => $config,
}, $class;
}# end new()
*init = \&new;
sub test_fixtures { shift->{test_fixtures} }
sub properties { shift->{properties} }
sub ua { shift->{ua} }
sub context { ASP4::HTTPContext->current }
sub config { shift->{config} }
sub data { shift->test_fixtures } # XXX: Deprecated! - for Apache2::ASP compat only.
sub test_data { shift->test_fixtures } # XXX: Deprecated!
sub DESTROY
{
my $s = shift;
undef(%$s);
}# end DESTROY()
1;# return true:
=pod
=head1 NAME
lib/ASP4/Config.pm view on Meta::CPAN
package ASP4::Config;
use strict;
use warnings 'all';
use Carp 'confess';
use base 'ASP4::ConfigNode';
sub new
{
my ($class, $ref, $root) = @_;
my $s = $class->SUPER::new( $ref );
$s->init_server_root( $root );
$s->_init_inc();
my $vars = $s->system->env_vars;
lib/ASP4/Config.pm view on Meta::CPAN
{
$ENV{$var} = $vars->{$var};
}# end foreach()
map { $s->load_class( $_ ) } $s->system->load_modules;
return $s;
}# end new()
sub _init_inc
{
my $s = shift;
my %saw = map { $_ => 1 } @INC;
my $web = $s->web;
push @INC, grep { ! $saw{$_}++ } ( $s->system->libs, $web->handler_root, $web->page_cache_root );
}# end _init_inc()
sub init_server_root
{
my ($s, $root) = @_;
my $project_root = (sub{
my @parts = split /\//, $root;
pop(@parts);
join '/', @parts;
})->();
$s->{web}->{project_root} = $project_root;
no warnings 'uninitialized';
lib/ASP4/Config.pm view on Meta::CPAN
}# end unless()
confess "Folder '$folder' does not exist and cannot be created"
unless -d $folder;
}# end foreach()
confess "Folder '$folder' exists but cannot be written to"
unless -w $folder;
}# end init_server_root()
sub load_class
{
my ($s, $class) = @_;
(my $file = "$class.pm") =~ s/::/\//g;
eval { require $file; }
or confess "Cannot load $class: $@";
}# end load_class()
sub DESTROY
{
my $s = shift;
undef(%$s);
}
1;# return true:
=pod
lib/ASP4/ConfigFinder.pm view on Meta::CPAN
package
ASP4::ConfigFinder;
use strict;
use warnings 'all';
use Cwd 'fastcwd';
our $CONFIGFILE = 'asp4-config.json';
sub config_path
{
my $path = $CONFIGFILE;
my $root = do { ($ENV{REMOTE_ADDR} || '') eq '' ? fastcwd() : $ENV{DOCUMENT_ROOT} || fastcwd() };
# Try test dir:
if( -f "$root/t/conf/$CONFIGFILE" )
{
return "$root/t/conf/$CONFIGFILE";
}# end if()
lib/ASP4/ConfigLoader.pm view on Meta::CPAN
use warnings 'all';
use Carp 'confess';
use ASP4::ConfigFinder;
use ASP4::ConfigParser;
use JSON::XS;
our $Configs = { };
#==============================================================================
sub load
{
my ($s) = @_;
my $path = ASP4::ConfigFinder->config_path;
my $file_time = (stat($path))[7];
if( exists($Configs->{$path}) && ( $file_time <= $Configs->{$path}->{timestamp} ) )
{
return $Configs->{$path}->{data};
}# end if()
lib/ASP4/ConfigNode.pm view on Meta::CPAN
package
ASP4::ConfigNode;
use strict;
use warnings 'all';
use Carp 'confess';
sub new
{
my ($class, $ref) = @_;
local $SIG{__DIE__} = \&Carp::confess;
my $s = bless $ref, $class;
$s->init_keys();
$s;
}# end new()
sub init_keys
{
my $s = shift;
foreach my $key ( grep { ref($s->{$_}) eq 'HASH' } keys(%$s) )
{
if( $key eq 'web' )
{
require ASP4::ConfigNode::Web;
$s->{$key} = ASP4::ConfigNode::Web->new( $s->{$key} );
}
lib/ASP4/ConfigNode.pm view on Meta::CPAN
$s->{$key} = ASP4::ConfigNode::System->new( $s->{$key} );
}
else
{
$s->{$key} = __PACKAGE__->new( $s->{$key} );
}# end if()
}# end foreach()
}# end init_keys()
sub AUTOLOAD
{
my $s = shift;
our $AUTOLOAD;
my ($name) = $AUTOLOAD =~ m/([^:]+)$/;
confess "Unknown method or property '$name'" unless exists($s->{$name});
# Read-only:
$s->{$name};
}# end AUTOLOAD()
sub DESTROY
{
my $s = shift;
undef(%$s);
}# end DESTROY()
1;# return true:
lib/ASP4/ConfigNode/System.pm view on Meta::CPAN
package ASP4::ConfigNode::System;
use strict;
use warnings 'all';
use base 'ASP4::ConfigNode';
sub new
{
my $class = shift;
my $s = $class->SUPER::new( @_ );
return $s;
}# end new()
sub libs
{
my $s = shift;
@{ $s->{libs} || [ ] };
}# end libs()
sub load_modules
{
my $s = shift;
@{ $s->{load_modules} || [ ] };
}# end load_modules()
sub env_vars
{
my $s = shift;
$s->{env_vars} || { };
}# end env_vars()
sub post_processors
{
my $s = shift;
@{ $s->{post_processors} || [ ] };
}# end post_processors()
sub settings
{
my $s = shift;
return $s->{settings} || { };
}# end settings()
1;# return true:
=pod
lib/ASP4/ConfigNode/Web.pm view on Meta::CPAN
package ASP4::ConfigNode::Web;
use strict;
use warnings 'all';
use base 'ASP4::ConfigNode';
use Carp 'confess';
use JSON::XS;
sub new
{
my $class = shift;
my $s = $class->SUPER::new( @_ );
$s->{handler_resolver} ||= 'ASP4::HTTPContext::HandlerResolver';
$s->{handler_runner} ||= 'ASP4::HTTPContext::HandlerRunner';
$s->{filter_resolver} ||= 'ASP4::HTTPContext::FilterResolver';
map {
$_->{uri_match} = undef unless defined($_->{uri_match});
lib/ASP4/ConfigNode/Web.pm view on Meta::CPAN
} $s->disable_persistence;
# Do we have "routes"?:
eval { require Router::Generic };
$s->{__has_router} = ! $@;
return $s;
}# end new()
sub request_filters
{
my $s = shift;
@{ $s->{request_filters} };
}# end request_filters()
sub disable_persistence
{
my $s = shift;
@{ $s->{disable_persistence} };
}# end disable_persistence()
sub router
{
my $s = shift;
$s->_parse_routes() unless $s->{__parsed_routes}++;
$s->{router};
}
sub routes
{
my $s = shift;
return unless $s->{__has_router};
$s->_parse_routes() unless $s->{__parsed_routes}++;
$s->{routes};
}# end routes()
sub _parse_routes
{
my $s = shift;
my @original = @{ $s->{routes} };
my $app_root = $s->application_root;
@{ $s->{routes} } = map {
$_->{include_routes} ? do {
my $item = $_;
$item->{include_routes} =~ s/\@ServerRoot\@/$app_root/sg;
$item->{include_routes} =~ s{\\\\}{\\}g;
lib/ASP4/ConfigParser.pm view on Meta::CPAN
package
ASP4::ConfigParser;
use strict;
use warnings 'all';
use ASP4::Config;
sub new
{
my ($class) = @_;
return bless { }, $class;
}# end new()
sub parse
{
my ($s, $doc, $root) = @_;
my $config = ASP4::Config->new( $doc, $root );
# Now do any post-processing:
foreach my $class ( $config->system->post_processors )
{
(my $file = "$class.pm") =~ s/::/\//;
require $file unless $INC{$file};
lib/ASP4/ConfigPostProcessor.pm view on Meta::CPAN
package
ASP4::ConfigPostProcessor;
use strict;
use warnings 'all';
sub new
{
my ($class, %args) = @_;
return bless \%args, $class;
}# end new()
sub post_process($$);
1;# return true:
lib/ASP4/Error.pm view on Meta::CPAN
package ASP4::Error;
use strict;
use warnings 'all';
use ASP4::HTTPContext;
use JSON::XS;
sub new
{
my $class = shift;
my ($err_str, %args);
if( @_ )
{
if( @_ == 1 )
{
$err_str = shift;
}
else
lib/ASP4/Error.pm view on Meta::CPAN
http_code => ($Response->Status =~ m{^(\d+)})[0],
remote_addr => $ENV{REMOTE_ADDR} || '127.0.0.1',
# Allow overrides:
%args
);
return bless \%info, $class;
}# end new()
sub domain { $_[0]->{domain} }
sub request_uri { $_[0]->{request_uri} }
sub file { $_[0]->{file} }
sub line { $_[0]->{line} }
sub message { $_[0]->{message} }
sub stacktrace { $_[0]->{stacktrace} }
sub code { $_[0]->{code} }
sub form_data { $_[0]->{form_data} }
sub session_data { $_[0]->{session_data} }
sub http_referer { $_[0]->{http_referer} }
sub user_agent { $_[0]->{user_agent} }
sub http_code { $_[0]->{http_code} }
sub remote_addr { $_[0]->{remote_addr} }
# Find the numbers within a given range, but not less than 1 and not greater than max.
sub _number_range
{
my ($s, $number, $max, $padding) = @_;
my $low = $number - $padding > 0 ? $number - $padding : 1;
my $high = $number + $padding <= $max ? $number + $padding : $max;
return ($low, $high);
}# end _number_range()
1;# return true:
lib/ASP4/ErrorHandler.pm view on Meta::CPAN
package ASP4::ErrorHandler;
use strict;
use warnings 'all';
use base 'ASP4::HTTPHandler';
use vars __PACKAGE__->VARS;
use MIME::Base64;
use Data::Dumper;
sub run
{
my ($s, $context) = @_;
my $error = $Stash->{error};
$s->print_error( $error );
$s->send_error( $error );
}# end run()
sub print_error
{
my ($s, $error) = @_;
$Response->ContentType('text/html');
if( $ENV{HTTP_HOST} eq 'localhost' )
{
$Response->Write( Dumper(\%$error) );
}
else
{
$Response->Write( $s->error_html( $error ) );
}# end if()
$Response->Flush;
}# end print_error()
sub send_error
{
my ($s, $error) = @_;
$Server->Mail(
To => $Config->errors->mail_errors_to,
From => $Config->errors->mail_errors_from,
Subject => "ASP4: Error in @{[ $ENV{HTTP_HOST} ]}@{[ $ENV{REQUEST_URI} ]}",
'content-type' => 'text/html',
'content-transfer-encoding' => 'base64',
Message => encode_base64( $s->error_html($error) ),
smtp => $Config->errors->smtp_server,
);
}# end send_error()
sub error_html
{
my ($s, $error) = @_;
my $msg = <<"ERROR";
<!DOCTYPE html>
<html>
<head><title>500 Server Error</title>
<meta charset="utf-8" />
<style type="text/css">
HTML,BODY {
lib/ASP4/ErrorHandler.pm view on Meta::CPAN
To subclass C<ASP4::ErrorHandler> you must do the following:
package My::ErrorHandler;
use strict;
use warnings 'all';
use base 'ASP4::ErrorHandler';
use vars __PACKAGE__->VARS;
sub run {
my ($s, $context) = @_;
my $error = $Stash->{error};
# $error is an ASP4::Error object.
# Do something here about the error.
$s->print_error( $error );
$s->send_error( $error );
}
lib/ASP4/ErrorHandler/Remote.pm view on Meta::CPAN
use vars __PACKAGE__->VARS;
use LWP::UserAgent;
use HTTP::Request::Common;
use HTTP::Date 'time2iso';
use JSON::XS;
use Data::Dumper;
require ASP4;
our $ua;
sub run
{
my ($s, $context) = @_;
my $error = $Stash->{error};
$s->print_error( $error );
$s->send_error($error);
}# end run()
sub send_error
{
my ($s, $error) = @_;
$ua ||= LWP::UserAgent->new();
$ua->agent( ref($s) . " $ASP4::VERSION" );
my %clone = %$error;
my $req = POST $Config->errors->post_errors_to, \%clone;
$ua->request( $req );
}# end send_error()
lib/ASP4/FileUpload.pm view on Meta::CPAN
package ASP4::FileUpload;
use strict;
use warnings 'all';
use Carp 'confess';
sub new
{
my ($class, %args) = @_;
foreach(qw( ContentType FileHandle FileName ))
{
confess "Required param '$_' was not provided"
unless $args{$_};
}# end foreach()
$args{UploadedFileName} = $args{FileName};
($args{FileName}) = $args{FileName} =~ m{[/\\]?([^/\\]+)$};
($args{FileExtension}) = $args{FileName} =~ m/([^\.]+)$/;
$args{FileSize} = (stat($args{FileHandle}))[7];
return bless \%args, $class;
}# end new()
# Public readonly properties:
sub ContentType { shift->{ContentType} }
sub FileName { shift->{FileName} }
sub UploadedFileName { shift->{UploadedFileName} }
sub FileExtension { shift->{FileExtension} }
sub FileSize { shift->{FileSize} }
sub FileContents
{
my $s = shift;
local $/;
my $ifh = $s->FileHandle;
return scalar(<$ifh>);
}# end FileContents()
sub FileHandle
{
my $s = shift;
my $ifh = $s->{FileHandle};
seek($ifh,0,0)
or confess "Cannot seek to the beginning of filehandle '$ifh': $!";
return $ifh;
}# end FileHandle()
# Public methods:
sub SaveAs
{
my ($s, $path) = @_;
# Create the file path if it doesn't yet exist:
my $folder = "";
my @parts = grep { $_ } split /\//, $path;
pop(@parts);
for( @parts )
{
$folder .= "/$_";
lib/ASP4/FileUpload.pm view on Meta::CPAN
while( my $line = <$ifh> )
{
print $ofh $line;
}# end while()
close($ofh);
return 1;
}# end SaveAs()
sub DESTROY
{
my $s = shift;
my $ifh = $s->FileHandle;
close($ifh);
undef(%$s);
}# end DESTROY()
1;# return true:
=pod
=head1 NAME
ASP4::FileUpload - Simple interface for handling File Uploads
=head1 SYNOPSIS
# In your handler:
sub run {
my ($s, $context) = @_;
if( my $file = $Request->FileUpload('fieldname') ) {
# Save the file:
$file->SaveAs('/var/media/uploads/budget.csv');
# Some info about it:
warn $file->UploadedFileName; # C:\Users\billg\budget.csv
warn $file->FileName; # budget.csv
lib/ASP4/FilterResolver.pm view on Meta::CPAN
package
ASP4::FilterResolver;
use strict;
use warnings 'all';
my %FilterCache = ( );
sub new
{
my ($class, %args) = @_;
return bless \%args, $class;
}# end new()
sub context { ASP4::HTTPContext->current }
sub resolve_request_filters
{
my ($s, $uri) = @_;
($uri) = split /\?/, $uri;
my $key = "$ENV{DOCUMENT_ROOT}:$uri";
return @{$FilterCache{$key}} if $FilterCache{$key};
$FilterCache{$key} = [
grep {
if( my $pattern = $_->uri_match )
{
lib/ASP4/FormHandler.pm view on Meta::CPAN
package my::handler;
use strict;
use warnings 'all';
use base 'ASP4::FormHandler';
# Import $Request, $Response, $Session, $Server, $Form, $Config, $Stash
use vars __PACKAGE__->VARS;
sub run {
my ($self, $context) = @_;
$Response->Write("Hello, World!");
}
1;# return true:
=head1 DESCRIPTION
All ASP4 *.asp scripts and C</handlers/*> classes should inherit from C<ASP4::FormHandler>.
lib/ASP4/HTTPContext.pm view on Meta::CPAN
use ASP4::ConfigLoader;
use ASP4::Request;
use ASP4::Response;
use ASP4::Server;
use ASP4::OutBuffer;
use ASP4::SessionStateManager::NonPersisted;
use Carp 'confess';
use vars '$_instance';
sub new
{
my ($class, %args) = @_;
my $s = bless {
config => ASP4::ConfigLoader->load,
buffer => [ ASP4::OutBuffer->new ],
stash => { },
headers_out => HTTP::Headers->new(),
is_subrequest => $args{is_subrequest},
}, $class;
lib/ASP4/HTTPContext.pm view on Meta::CPAN
my $web = $s->config->web;
$s->config->load_class( $web->handler_resolver );
$s->config->load_class( $web->handler_runner );
$s->config->load_class( $s->config->data_connections->session->manager );
$s->config->load_class( $web->filter_resolver );
return $s->is_subrequest ? $s : $_instance = $s;
}# end new()
sub setup_request
{
my ($s, $r, $cgi) = @_;
$ENV{DOCUMENT_ROOT} = $r->document_root;
$s->{r} = $r;
$s->{cgi} = $cgi;
# Must instantiate $_instance before creating the other objects:
$s->{request} ||= ASP4::Request->new();
$s->{response} ||= ASP4::Response->new();
lib/ASP4/HTTPContext.pm view on Meta::CPAN
else
{
$s->{session} ||= $s->config->data_connections->session->manager->new( $s->r );
}# end if()
return $_instance;
}# end setup_request()
# Intrinsics:
sub current { $_instance || shift->new }
sub request { shift->{request} }
sub response { shift->{response} }
sub server { shift->{server} }
sub session { shift->{session} }
sub config { shift->{config} }
sub stash { shift->{stash} }
# More advanced:
sub is_subrequest { shift->{is_subrequest} }
sub cgi { shift->{cgi} }
sub r { shift->{r} }
sub handler { shift->{handler} }
sub headers_out { shift->{headers_out} }
sub content_type { my $s = shift; $s->r->content_type( @_ ) }
sub status { my $s = shift; $s->r->status( @_ ) }
sub did_send_headers { shift->{did_send_headers} }
sub did_end {
my $s = shift;
@_ ? $s->{did_end} = shift : $s->{did_end};
}
sub rprint {
my ($s,$str) = @_;
$s->buffer->add( $str );
}
sub rflush {
my $s = shift;
$s->send_headers;
$s->r->print( $s->buffer->data );
$s->r->rflush;
$s->rclear;
}
sub rclear {
my $s = shift;
$s->buffer->clear;
}
sub send_headers
{
my $s = shift;
return if $s->{did_send_headers};
my $headers = $s->headers_out;
while( my ($k,$v) = each(%$headers) )
{
$s->r->err_headers_out->{$k} = $v;
}# end while()
$s->r->rflush;
$s->{did_send_headers} = 1;
}# end send_headers()
# Here be dragons:
sub buffer { shift->{buffer}->[-1] }
sub add_buffer {
my $s = shift;
$s->rflush;
push @{$s->{buffer}}, ASP4::OutBuffer->new;
}
sub purge_buffer { shift( @{shift->{buffer}} ) }
sub execute
{
my ($s, $args, $is_include) = @_;
unless( $is_include )
{
# Set up and execute any matching request filters:
my $resolver = $s->config->web->filter_resolver;
foreach my $filter ( $resolver->new()->resolve_request_filters( $s->r->uri ) )
{
$s->config->load_class( $filter->class );
lib/ASP4/HTTPContext.pm view on Meta::CPAN
}# end if()
$s->response->Flush;
my $res = $s->end_request();
$res = 0 if $res =~ m/^200/;
return $res;
}# end execute()
sub handle_phase
{
my ($s, $ref, $is_filter) = @_;
my $res = eval { $ref->( ) };
if( $@ )
{
$s->handle_error;
}# end if()
# Undef on success:
lib/ASP4/HTTPContext.pm view on Meta::CPAN
}# end if()
}
else
{
return if (! defined($res)) || $res == -1;
return $s->response->Status =~ m/^200/ ? undef : $s->response->Status;
}# end if()
}# end handle_phase()
sub handle_error
{
my $s = shift;
$s->response->Status( 500 );
$s->response->Clear();
my $err_str = $@;
my $error = $s->server->Error( $@ );
warn "[Error: @{[ HTTP::Date::time2iso() ]}] $err_str\n";
return $s->end_request;
}# end handle_error()
sub end_request
{
my $s = shift;
$s->response->End;
my $res = $s->response->Status =~ m/^200/ ? 0 : $s->response->Status;
return $res;
}# end end_request()
sub do_disable_session_state
{
my ($s) = @_;
# my ($uri) = split /\?/, $s->r->uri;
my ($uri) = split /\?/, $ENV{REQUEST_URI} || $s->r->uri;
my ($yes) = grep { $_->disable_session } grep {
if( my $pattern = $_->uri_match )
{
$uri =~ m/^$pattern$/
}
else
{
$uri eq $_->uri_equals;
}# end if()
} $s->config->web->disable_persistence;
return $yes;
}# end do_disable_session_state()
sub DESTROY
{
my $s = shift;
$s->session->save if $s->session && ! $s->session->is_read_only;
$s = { };
undef(%$s);
}# end DESTROY()
1;# return true:
=pod
lib/ASP4/HTTPHandler.pm view on Meta::CPAN
package
ASP4::HTTPHandler;
use strict;
use warnings 'all';
use Data::Properties::YAML;
BEGIN {
sub VARS {
qw(
$Request $Response
$Session $Server
$Config $Form
$Stash
)
}
use vars __PACKAGE__->VARS;
}
sub new {
my ($class, %args) = @_;
return bless \%args, $class;
}
sub before_run { 1; }
sub after_run { }
sub request { $Request }
sub response { $Response }
sub session { $Session }
sub stash { $Stash }
sub server { $Server }
sub form { $Form }
sub config { $Config }
sub init_asp_objects
{
my ($s, $context) = @_;
$Request = $context->request;
$Response = $context->response;
$Session = $context->session;
$Server = $context->server;
$Form = $context->request->Form;
$Config = $context->config;
$Stash = $context->stash;
lib/ASP4/HTTPHandler.pm view on Meta::CPAN
${"$_\::Server"} = $Server;
${"$_\::Form"} = $Form;
${"$_\::Config"} = $Config;
${"$_\::Stash"} = $Stash;
} grep { ! $saw{$_}++ } @classes;
return 1;
}# end init_asp_objects()
sub properties
{
my ($s, $file) = @_;
$file ||= $Config->web->application_root . '/etc/properties.yaml';
return Data::Properties::YAML->new( properties_file => $file );
}# end properties()
sub trim_form
{
no warnings 'uninitialized';
map {
$Form->{$_} =~ s/^\s+//;
$Form->{$_} =~ s/\s+$//;
} keys %$Form;
}# end trim_form()
sub _parents
{
my ($s, $class ) = @_;
no strict 'refs';
${"$class\::__PARENTS_TIME"} ||= 0;
my $diff = time() - ${"$class\::__PARENTS_TIME"};
my $max_age = 5;
if( @{"$class\::__PARENTS"} && $diff < $max_age )
{
lib/ASP4/HTTPHandler.pm view on Meta::CPAN
my %saw = ( );
push @classes, map { $s->_parents( $_ ) }
grep { ( ! $saw{$_}++ ) && $_->isa($pkg) }
@{"$class\::ISA"};
${"$class\::__PARENTS_TIME"} = time();
return @{"$class\::__PARENTS"} = @classes;
}# end _parents()
sub DESTROY
{
my $s = shift;
undef(%$s);
}# end DESTROY()
1;# return true:
lib/ASP4/HandlerResolver.pm view on Meta::CPAN
ASP4::HandlerResolver;
use strict;
use warnings 'all';
use ASP4::PageLoader;
use File::stat;
my %HandlerCache = ( );
my %FileTimes = ( );
sub new
{
my ($class, %args) = @_;
return bless \%args, $class;
}# end new()
sub context { ASP4::HTTPContext->current }
sub resolve_request_handler
{
my ($s, $uri) = @_;
($uri) = split /\?/, $uri;
$s->check_reload( $uri );
return $HandlerCache{"$ENV{DOCUMENT_ROOT}:$uri"} if $HandlerCache{"$ENV{DOCUMENT_ROOT}:$uri"};
if( $uri =~ m/^\/handlers\// )
{
(my $handler = $uri) =~ s/^\/handlers\///;
lib/ASP4/HandlerResolver.pm view on Meta::CPAN
return $HandlerCache{"$ENV{DOCUMENT_ROOT}:$uri"} = $page->package;
}
else
{
return;
}# end if()
}# end if()
}# end resolve_request_handler()
sub check_reload
{
my ($s, $uri) = @_;
if( $uri =~ m/^\/handlers\// )
{
(my $handler = $uri) =~ s/^\/handlers\///;
$handler =~ s/[^a-z0-9_]/::/gi;
(my $path = "$handler.pm") =~ s/::/\//g;
my $filepath = $s->context->config->web->handler_root . "/$path";
(my $inc_entry = "$handler.pm") =~ s/::/\//g;
lib/ASP4/HandlerResolver.pm view on Meta::CPAN
$FileTimes{ "$ENV{DOCUMENT_ROOT}:$info->{filename}" } = stat($info->{filename})->mtime;
$s->_forget_package(
$info->{compiled_as}, $info->{package}
);
delete( $HandlerCache{"$ENV{DOCUMENT_ROOT}:$uri"} );
}# end if()
}# end if()
}# end check_reload()
sub _forget_package
{
my ($s, $inc, $package) = @_;
# Forcibly forget all about the handler we are going to reload:
no strict 'refs';
delete( $INC{ $inc } );
if( *{"$package\::run"} )
{
no warnings;
*{"$package\::run"} = undef;
( run in 0.591 second using v1.01-cache-2.11-cpan-4d50c553e7e )