ASP4

 view release on metacpan or  search on metacpan

Changes  view on Meta::CPAN


[CHANGELOG]

2012-05-07    1.087
  - Marking ASP4 and its entire ecosystem "DEPRECATED" until further notice.

2012-03-01    1.086
  - Use of $api->get within a handler is disabled at this time.

2012-02-24    1.085
  - Fixed ASP4::UserAgent to take advantage of new subrequest option.
  - Use of the ASP4::API within an existing asp script, handler or request filter
    is fully-functional now.  Before, the behavior was unpredictable.

2012-02-24    1.084
  - The Response->Redirect hack has been removed.
  - Added concept of 'context->is_subrequest'
    - this simplifies things a great deal.
    - ->is_subrequest means that a subrequest context will not clobber ->current.

2012-02-24    1.083
  - A wild Meta.json appeared in 1.082!

2012-02-24    1.082
  - Response->Redirect after Response->TrapInclude was causing the redirect to fail.
  - This release introduces a hack to fix it, by writing a meta tag to the client.

2012-02-13    1.081
  - Updated logging of errors so that it outputs something interesting, instead

Changes  view on Meta::CPAN

  - Documented asp4-prep and asp4-deploy.  These are deployment tools for ASP4 apps.
  - Other POD updates here and there.

2011-11-15    1.064
  - 1.063 was broken - please upgrade.

2011-11-15    1.063
  - Stealth-mode ASP4::ErrorHandler::Remote will send your error messages to a
    remote server via http.
  - Added ASP4::Error
  - Refactored ASP4::ErrorHandler to be more easily sub-classable.
  - GlobalASA is now officially removed.

2011-11-13    1.062
  - The httpd.conf produced by asphelper had an incorrect DocumentRoot.  Fixed now.

2011-11-07    1.061
  - asphelper now creates new ASP4 apps using the proper structure.

2011-11-06    1.060
  - $Response->Include on a missing file will no longer result in a 404 on the

Changes  view on Meta::CPAN

  - 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 

MANIFEST  view on Meta::CPAN

t/htdocs/404.asp
t/htdocs/child-returns-404.asp
t/htdocs/everything/master.asp
t/htdocs/everything/step01.asp
t/htdocs/form.pm
t/htdocs/GlobalASA.pm
t/htdocs/include-missing.asp
t/htdocs/index.asp
t/htdocs/masters/deep.asp
t/htdocs/masters/global.asp
t/htdocs/masters/submaster.asp
t/htdocs/pageparser/010.asp
t/htdocs/pageparser/01simple.asp
t/htdocs/pageparser/child-inner1.asp
t/htdocs/pageparser/child-inner2.asp
t/htdocs/pageparser/child-outer.asp
t/htdocs/pageparser/does-trapinclude.asp
t/htdocs/pageparser/has-2-includes.asp
t/htdocs/pageparser/has-include.asp
t/htdocs/pageparser/has-nested-include.asp
t/htdocs/pageparser/is-include.asp

README.markdown  view on Meta::CPAN

### $Server->Mail( %args )

Sends an email via [Mail::Sendmail](http://search.cpan.org/perldoc?Mail::Sendmail).  In fact it simply calls the `sendmail(...)` function
provided by [Mail::Sendmail](http://search.cpan.org/perldoc?Mail::Sendmail).

Simple Example:

    $Server->Mail(
      from    => 'foo@bar.com',
      to      => 'bar@foo.com',
      subject => 'Hello, world!',
      message => 'this is a test message'
    );

To send an HTML email do the following:

    use MIME::Base64;
    $Server->Mail(
      from                        => 'foo@bar.com',
      to                          => 'bar@foo.com',
      subject                     => 'Hello, world!',
      'content-type'              => 'text/html',
      'content-transfer-encoding' => 'base64',
      message => encode_base64(<<"HTML")
    <html>
    <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
for dealing with whatever the browser sent us.

Examples:

README.markdown  view on Meta::CPAN

`\%args` is optional.

Within the included ASP script, `\%args` is accessible like this:

    <%
      my ($self, $context, $args) = @_;
    %>

## $Session

The `$Session` object is an instance of a subclass of [ASP4::SessionStateManager](http://search.cpan.org/perldoc?ASP4::SessionStateManager)
(depending on your website's configuration).

The `$Session` object is a simple blessed hashref and should be used like a hashref.

Examples:

### Set a session variable

    $Session->{foo} = "bar";

README.markdown  view on Meta::CPAN

      password    char(32) not null,
      created_on  timestamp not null default current_timestamp,
      unique(email)
    ) engine=innodb charset=utf8;
    

    create table messages (
      message_id    bigint unsigned not null primary key auto_increment,
      from_user_id  bigint unsigned not null,
      to_user_id    bigint unsigned not null,
      subject       varchar(100) not null,
      body          text,
      created_on    timestamp not null default current_timestamp,
      foreign key fk_messages_to_senders (from_user_id) references users (user_id) on delete cascade,
      foreign key fk_messages_to_recipients (to_user_id) references users (user_id) on delete cascade
    ) engine=innodb charset=utf8;

__NOTE:__ It's best to assign every ASP4 application its own namespace.  For this
example the namespace is `App::db::`

Create the file `lib/App::db/model.pm` and add the following lines:

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

        <label>Password:</label>
        <input type="password" name="password" />
        <% $::err->("password"); %>
      </p>
      <p>
        <label>Confirm Password:</label>
        <input type="password" name="password2" />
        <% $::err->("password2"); %>
      </p>
      <p>
        <input type="submit" value="Register Now" />
      </p>
    </form>
    </asp:Content>

The form submits to the URL `/handlers/app.register` which means `handlers/app/register.pm`

File: `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:

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

      foreach my $user ( @users ) {
    %>
            <option value="<%= $user->id %>"><%= $Server->HTMLEncode( $user->email ) %></option>
    <%
      }# end foreach()
    %>
          </select>
        </p>
        <p>
          <label>Subject:</label>
          <input type="text" name="subject" maxlength="100" />
        </p>
        <p>
          <label>Message:</label><br/>
          <textarea name="body"></textarea>
        </p>
        <p>
          <input type="submit" value="Send Message" />
        </p>
      </form>
    </div>
    </asp:Content>

The form submits to `/handlers/app.send` which maps to `handlers/app/send.pm`

File: `handlers/app/send.pm`

    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',
          'reply-to'  => $msg->sender->email,
          to          => $msg->recipient->email,
          subject     => 'New in-club message',
          message     => <<"MSG",
    Dear user,
    

    Another user (@{[ $msg->sender->email ]}) has sent you an in-club message.
    

    Please login and view it on your profile at http://$ENV{HTTP_HOST}/
    

README.markdown  view on Meta::CPAN

        $Session->{msg} = "New message sent successfully.";
        $Session->save;
        return $Response->Redirect( $ENV{HTTP_REFERER} );
      }
    }

# BUGS

It's possible that some bugs have found their way into this release.

Use RT [http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4](http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4) to submit bug reports.

# HOMEPAGE

Please visit the ASP4 homepage at [http://0x31337.org/code/](http://0x31337.org/code/) to see examples
of ASP4 in action.

# AUTHOR

John Drago <jdrago_999@yahoo.com>

inc/Module/Install.pm  view on Meta::CPAN


END_DIE





# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));





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);
		goto &{"$self->{name}::import"};
	}

	*{"${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
		# correctly.  Otherwise, root through the file to locate the case-preserved
		# version of the package name.
		if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
			my $content = Module::Install::_read($subpath . '.pm');
			my $in_pod  = 0;
			foreach ( split //, $content ) {
				$in_pod = 1 if /^=\w/;
				$in_pod = 0 if /^=cut/;
				next if ($in_pod || /^=cut/);  # skip pod text
				next if /^\s*#/;               # and comments
				if ( m/^\s*package\s+($pkg)\s*;/i ) {
					$pkg = $1;
					last;
				}

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

		map { @$_ }
		map { @$_ }
		grep $_,
		($self->configure_requires, $self->build_requires, $self->requires)
	);

	# Remove any reference to perl, PREREQ_PM doesn't support it
	delete $args->{PREREQ_PM}->{perl};

	# merge both kinds of requires into prereq_pm
	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";
	}

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

=head3 $Server->Mail( %args )

Sends an email via L<Mail::Sendmail>.  In fact it simply calls the C<sendmail(...)> function
provided by L<Mail::Sendmail>.

Simple Example:

  $Server->Mail(
    from    => 'foo@bar.com',
    to      => 'bar@foo.com',
    subject => 'Hello, world!',
    message => 'this is a test message'
  );

To send an HTML email do the following:

  use MIME::Base64;
  $Server->Mail(
    from                        => 'foo@bar.com',
    to                          => 'bar@foo.com',
    subject                     => 'Hello, world!',
    'content-type'              => 'text/html',
    'content-transfer-encoding' => 'base64',
    message => encode_base64(<<"HTML")
  <html>
  <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
for dealing with whatever the browser sent us.

Examples:

lib/ASP4.pm  view on Meta::CPAN

C<\%args> is optional.

Within the included ASP script, C<\%args> is accessible like this:

  <%
    my ($self, $context, $args) = @_;
  %>

=head2 $Session

The C<$Session> object is an instance of a subclass of L<ASP4::SessionStateManager>
(depending on your website's configuration).

The C<$Session> object is a simple blessed hashref and should be used like a hashref.

Examples:

=head3 Set a session variable

  $Session->{foo} = "bar";

lib/ASP4.pm  view on Meta::CPAN

    email       varchar(200) not null,
    password    char(32) not null,
    created_on  timestamp not null default current_timestamp,
    unique(email)
  ) engine=innodb charset=utf8;
  
  create table messages (
    message_id    bigint unsigned not null primary key auto_increment,
    from_user_id  bigint unsigned not null,
    to_user_id    bigint unsigned not null,
    subject       varchar(100) not null,
    body          text,
    created_on    timestamp not null default current_timestamp,
    foreign key fk_messages_to_senders (from_user_id) references users (user_id) on delete cascade,
    foreign key fk_messages_to_recipients (to_user_id) references users (user_id) on delete cascade
  ) engine=innodb charset=utf8;

B<NOTE:> It's best to assign every ASP4 application its own namespace.  For this
example the namespace is C<App::db::>

Create the file C<lib/App::db/model.pm> and add the following lines:

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

      <label>Password:</label>
      <input type="password" name="password" />
      <% $::err->("password"); %>
    </p>
    <p>
      <label>Confirm Password:</label>
      <input type="password" name="password2" />
      <% $::err->("password2"); %>
    </p>
    <p>
      <input type="submit" value="Register Now" />
    </p>
  </form>
  </asp:Content>

The form submits to the URL C</handlers/app.register> which means C<handlers/app/register.pm>

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

    foreach my $user ( @users ) {
  %>
          <option value="<%= $user->id %>"><%= $Server->HTMLEncode( $user->email ) %></option>
  <%
    }# end foreach()
  %>
        </select>
      </p>
      <p>
        <label>Subject:</label>
        <input type="text" name="subject" maxlength="100" />
      </p>
      <p>
        <label>Message:</label><br/>
        <textarea name="body"></textarea>
      </p>
      <p>
        <input type="submit" value="Send Message" />
      </p>
    </form>
  </div>
  </asp:Content>

The form submits to C</handlers/app.send> which maps to C<handlers/app/send.pm>

File: C<handlers/app/send.pm>

  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',
          'reply-to'  => $msg->sender->email,
          to          => $msg->recipient->email,
          subject     => 'New in-club message',
          message     => <<"MSG",
    Dear user,
    
    Another user (@{[ $msg->sender->email ]}) has sent you an in-club message.
    
    Please login and view it on your profile at http://$ENV{HTTP_HOST}/
    
    Yours,
    The "In Club"
    MSG

lib/ASP4.pm  view on Meta::CPAN

      $Session->{msg} = "New message sent successfully.";
      $Session->save;
      return $Response->Redirect( $ENV{HTTP_REFERER} );
    }
  }

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=head1 AUTHOR

John Drago <jdrago_999@yahoo.com>

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/API.pm  view on Meta::CPAN

Returns an object representing your C</etc/properties.yaml> file.

=head2 data

Returns an object representing your C</etc/test_fixtures.yaml> file.

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=cut

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';
  foreach( @{ $s->{system}->{libs} } )
  {
    $_ =~ s/\@ServerRoot\@/$root/;
    $_ =~ s/\@ProjectRoot\@/$project_root/;

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/Config.pm  view on Meta::CPAN

        "username": "",
        "password": ""
      }
    }
  }

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=head1 AUTHOR

John Drago <jdrago_999@yahoo.com>

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/ConfigLoader.pm  view on Meta::CPAN

=head1 PUBLIC METHODS

=head2 load( )

Returns a L<ASP4::Config> object.

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=head1 AUTHOR

John Drago <jdrago_999@yahoo.com>

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/System.pm  view on Meta::CPAN

=head2 settings

A collection of special read-only values that should be available throughout the application.

Examples include encryption keys, API keys and username/password combos to access remote services.

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=head1 AUTHOR

John Drago <jdrago_999@yahoo.com>

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/ConfigNode/Web.pm  view on Meta::CPAN

  $Config->web->router

=head1 SEE ALSO

L<ASP4::RequestFilter>

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=head1 AUTHOR

John Drago <jdrago_999@yahoo.com>

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/Error.pm  view on Meta::CPAN

The current value of C<<$Response->Status>>

=head2 remote_addr

Default value is C<$ENV{REMOTE_ADDR}> -- the IP address of the remote client.

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=cut

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

  ...

=head1 DESCRIPTION

This class provides a default error handler which does the following:

1) Makes a simple HTML page and prints it to the browser, telling the user
that an error has just occurred.

2) Sends that same HTML to the email address specified in the config, using the
SMTP server also specified in the config.  The email subject will look something like:

  ASP4: Error in your-site.com/index.asp

=head1 SUBCLASSING

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.pm  view on Meta::CPAN


=head2 send_error( $error )

Sends the error html to the email address specified in the config, using C<<$Server->Mail(...)>>
and the smtp server specified in the config.

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=head1 AUTHOR

John Drago <jdrago_999@yahoo.com>

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/ErrorHandler/Remote.pm  view on Meta::CPAN

=head2 send_error( $error )

Sends the error data to the web address specified in C<<$Config->errors->post_errors_to>>.

The field names and values will correspond to the properties of an C<ASP4::Error> object.

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=head1 AUTHOR

John Drago <jdrago_999@yahoo.com>

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/FileUpload.pm  view on Meta::CPAN


=head2 SaveAs( $path )

Writes the contents of the uploaded file to C<$path>.  Will throw an exception if
something goes wrong.

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=cut

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/FormHandler.pm  view on Meta::CPAN

Where most of your action is expected to occur.

=head2 after_run( $self, $context )

Called after C<run>, can be used

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=cut

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;
  $s->config->_init_inc();
  
  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 );
      $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 );
  };

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/HTTPContext.pm  view on Meta::CPAN

=head2 r

Provided B<Just In Case> - returns the L<Apache2::RequestRec> for the HTTP request.

B<NOTE:> Under L<ASP4::API> (eg: in a unit test) C<$r> will be an instance of L<ASP4::Mock::RequestRec> instead.

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=cut

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:



( run in 1.910 second using v1.01-cache-2.11-cpan-88abd93f124 )