ASP4
view release on metacpan or search on metacpan
README.markdown view on Meta::CPAN
# 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( $@ ) {
README.markdown view on Meta::CPAN
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:
inc/Module/Install.pm view on Meta::CPAN
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};
local $@;
my $new = eval { require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} = delete $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
inc/Module/Install/Base.pm view on Meta::CPAN
}
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 {
inc/Module/Install/Can.pm view on Meta::CPAN
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}), '.') {
inc/Module/Install/Fetch.pm view on Meta::CPAN
$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;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
inc/Module/Install/Makefile.pm view on Meta::CPAN
$args->{NAME} = $self->module_name || $self->name;
$args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
}
if ($] >= 5.005) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
$args->{NO_META} = 1;
}
if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
# merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ }
inc/Module/Install/Makefile.pm view on Meta::CPAN
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
foreach my $bundle (@{ $self->bundles }) {
my ($file, $dir) = @$bundle;
push @$subdirs, $dir if -d $dir;
delete $prereq->{$file};
}
}
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
$args->{INSTALLDIRS} = $self->installdirs;
my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
if (my $preop = $self->admin->preop($user_preop)) {
lib/ASP4.pm view on Meta::CPAN
# 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:
lib/ASP4.pm view on Meta::CPAN
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(
lib/ASP4/API.pm view on Meta::CPAN
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 };
$test_data = Data::Properties::JSON->new(
properties_file => $config->web->application_root . '/etc/test_fixtures.json'
) unless $@;
}
elsif( -f $config->web->application_root . '/etc/test_fixtures.yaml' )
{
$test_data = ASP4::Test::Fixtures->new(
properties_file => $config->web->application_root . '/etc/test_fixtures.yaml'
);
}# end if()
lib/ASP4/Config.pm view on Meta::CPAN
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);
}
lib/ASP4/ConfigNode/Web.pm view on Meta::CPAN
} $s->request_filters;
map {
$_->{uri_match} = undef unless defined($_->{uri_match});
$_->{uri_equals} = undef unless defined($_->{uri_equals});
$_->{disable_session} ||= 0;
$_->{disable_application} ||= 0;
$_ = $class->SUPER::new( $_ );
} $s->disable_persistence;
# Do we have "routes"?:
eval { require Router::Generic };
$s->{__has_router} = ! $@;
return $s;
}# end new()
sub request_filters
{
my $s = shift;
lib/ASP4/ConfigNode/Web.pm view on Meta::CPAN
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;
open my $ifh, '<', $item->{include_routes}
or die "Cannot open '$item->{include_routes}' for reading: $!";
local $/;
my $json = eval { decode_json( scalar(<$ifh>) ) }
or confess "Error parsing '$item->{include_routes}': $@";
ref($json) eq 'ARRAY'
or confess "File '$item->{include_routes}' should be an arrayref but it's a '@{[ ref($json) ]}' instead.";
@$json;
} : $_
} @original;
my $router = Router::Generic->new();
map { $router->add_route( %$_ ) } @{ $s->{routes} };
$s->{router} = $router;
lib/ASP4/Error.pm view on Meta::CPAN
last if $line_number > $high;
push @lines, "line $line_number: $line";
}# end while()
close($ifh);
$code = join "", @lines;
}# end if()
}# end if()
my %info = (
# Defaults:
domain => eval { $Config->errors->domain } || $ENV{HTTP_HOST},
request_uri => $ENV{REQUEST_URI},
file => $error->{file},
line => $error->{line},
message => $error->{message},
stacktrace => $error->{stacktrace},
code => $code,
form_data => encode_json($Form) || "{}",
session_data => eval { encode_json(\%session_data) } || "{}",
http_referer => $ENV{HTTP_REFERER},
user_agent => $ENV{HTTP_USER_AGENT},
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()
lib/ASP4/Error.pm view on Meta::CPAN
=head1 NAME
ASP4::Error - Representation of a server-side error
=head1 SYNOPSIS
use ASP4::Error;
# Pass in the $@ value after something dies or confesses:
eval { die "Foo" };
if( $@ ) {
my $error = ASP4::Error->new( $@ )
}
# Pass in your own info:
unless( $something ) {
my $error = ASP4::Error->new(
message => "If can, can. If no can, no can!"
);
}
lib/ASP4/HTTPContext.pm view on Meta::CPAN
$filter->class->init_asp_objects( $s );
my $IS_FILTER = 1;
my $res = $s->handle_phase(sub{ $filter->class->new()->run( $s ) }, $IS_FILTER);
if( $s->did_end || ( defined($res) && $res != -1 ) )
{
return $res;
}# end if()
}# end foreach()
}# end unless()
eval {
$s->{handler} = $s->config->web->handler_resolver->new()->resolve_request_handler( $s->r->uri );
};
if( $@ )
{
$s->server->{LastError} = $@;
return $s->handle_error;
}# end if()
return $s->response->Status( 404 ) unless $s->{handler};
eval {
$s->config->load_class( $s->handler );
$s->config->web->handler_runner->new()->run_handler( $s->handler, $args );
};
if( $@ )
{
$s->server->{LastError} = $@;
return $s->handle_error;
}# end if()
lib/ASP4/HTTPContext.pm view on Meta::CPAN
$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:
if( $is_filter )
{
if( defined($res) && $res > -1 )
{
lib/ASP4/ModPerl.pm view on Meta::CPAN
if( ($r->headers_in->{'content-type'}||'') =~ m/multipart\/form\-data/ )
{
$context->{r} = $r;
if( $@ )
{
warn $@;
$r->status( 500 );
return $r->status;
}# end if()
my $handler_class = eval {
$context->config->web->handler_resolver->new()->resolve_request_handler( $r->uri )
};
if( $@ )
{
warn $@;
$r->status( 500 );
return $r->status;
}# end if()
return 404 unless $handler_class;
eval {
my $cgi = CGI->new( $r );
my %args = map { my ($k,$v) = split /\=/, $_; ( $k => $v ) } split /&/, $ENV{QUERY_STRING};
map { $cgi->param($_ => $args{$_}) } keys %args;
$context->setup_request( $r, $cgi);
$context->execute;
};
if( $@ )
{
if( $@ =~ m/Software\scaused\sconnection\sabort/ )
{
return 0;
}# end if()
warn $@;
$r->status( 500 );
}# end if()
return $r->status =~ m/^2/ ? 0 : $r->status == 500 ? 0 : $r->status;
}
else
{
my $cgi = CGI->new( $r );
eval {
$context->setup_request( $r, $cgi );
$context->execute;
};
if( $@ =~ m/Software\scaused\sconnection\sabort/ )
{
return 0;
}# end if()
warn $@ if $@;
lib/ASP4/Request.pm view on Meta::CPAN
sub ServerVariables { $ENV{ $_[1] } }
sub FileUpload
{
my ($s, $field) = @_;
my $ifh = $s->context->cgi->upload($field)
or return;
my %info = ( );
if( my $upInfo = eval { $s->context->cgi->uploadInfo( $ifh ) } )
{
no warnings 'uninitialized';
%info = (
ContentType => $upInfo->{'Content-Type'},
FileHandle => $ifh,
FileName => $s->{form}->{ $field } . "",
ContentDisposition => $upInfo->{'Content-Disposition'},
);
}
else
lib/ASP4/Response.pm view on Meta::CPAN
{
my $s = shift;
$s->context->rprint( shift(@_) )
}# end Write()
sub SetCookie
{
my ($s, %args) = @_;
$args{domain} ||= eval { $s->context->config->data_connections->session->cookie_domain } || $ENV{HTTP_HOST};
$args{path} ||= '/';
my @parts = ( );
push @parts, $s->context->server->URLEncode($args{name}) . '=' . $s->context->server->URLEncode($args{value});
unless( $args{domain} eq '*' )
{
push @parts, 'domain=' . $s->context->server->URLEncode($args{domain});
}# end unless()
push @parts, 'path=' . $args{path};
if( $args{expires} )
{
lib/ASP4/UserAgent.pm view on Meta::CPAN
sub _setup_response
{
my ($s, $response_code) = @_;
$response_code = 200 if ($response_code || 0) eq '0';
my $response = HTTP::Response->new( $response_code );
# XXX: Sometimes this dies with 'HTTP::Message requires bytes' or similar:
eval { $response->content( $s->context->r->buffer ) };
if( $@ )
{
(my $ascii = $s->context->r->buffer) =~ s/[^[:ascii:]]//gs;
$response->content( $ascii );
}# end if()
$response->header( 'Content-Type' => $s->context->response->{ContentType} );
foreach my $header ( $s->context->response->Headers, $s->context->r->err_headers_out )
{
sbin/asp4-deploy view on Meta::CPAN
`rm -f deploying`;
# Copy over the config files:
`tar -zxvf "$src" && ln -s "$id" deploying`;
my @test_errors = ( );
foreach( grep { $_ !~ m{latest/common$} } <latest/*> )
{
my ($folder) = $_ =~ m{latest/([^/]+)};
`cp -rf latest/$folder/conf/* deploying/$folder/conf/`;
chdir("deploying/$folder");
unless( eval { runtests( <t/*/*.t> ) } ) #/
{
push @test_errors, $@;
}# end unless()
}# end foreach()
chdir($start_cwd);
if( @test_errors )
{
die "Tests failed:\n", join "\n", @test_errors;
}# end if()
sbin/asphelper view on Meta::CPAN
my @DSN = (
"DBI:mysql:$dbName:$dbHost",
$dbUser,
$dbPass
);
my $drh = DBI->install_driver("mysql");
my $rc = $drh->func('createdb', $dbName, $dbHost, $dbUser, $dbPass, 'admin');
my $dbh = eval { DBI->connect( @DSN, {RaiseError => 1} ) };
if( $@ )
{
(my $error = $@) =~ s/\sat\s\Q$0\E\s+line.*//;
die "[ERROR]: $error\n";
}# end if()
# Setup folder structure:
(my $project_path = lc($appName)) =~ s{::}{_}sg;
make_path($project_path);
chdir($project_path);
sbin/asphelper view on Meta::CPAN
}# end run()
1;# return true:
CODE
close($ofh);
}# end unless()
# Only write the base Model class if we have Class::DBI::Lite
my $CDBIL_Version = 0;
eval {
require Class::DBI::Lite;
$CDBIL_Version = $Class::DBI::Lite::VERSION = $Class::DBI::Lite::VERSION;
};
if( $dbName && $Class::DBI::Lite::VERSION )
{
unless( -f "common/lib/$appFolder/db/model.pm" )
{
warn "common/lib/$appFolder/db/model.pm\n";
open my $ofh, '>', "common/lib/$appFolder/db/model.pm"
or die "Cannot open 'common/lib/$appFolder/db/model.pm' for writing: $!";
( run in 2.729 seconds using v1.01-cache-2.11-cpan-98e64b0badf )