![[staff profile]](https://www.dreamwidth.org/img/silk/identity/user_staff.png){kind=small}
![[site community profile]](https://www.dreamwidth.org/img/comm_staff.png){kind=small}
[dw-free] Template Toolikt / Routing System
[commit: http://hg.dwscoalition.org/dw-free/rev/8f4e3e7a0082]
http://bugs.dwscoalition.org/show_bug.cgi?id=2054
Add support for a routing system and Template Toolkit. This is Apache2
specific right now but as that's all we support, that's fine. Nothing yet
uses TT, either, but the edges data page is now using the routing system.
This should be considered experimental while Andrea (mostly) and I (some)
work on it.
Patch by![[personal profile]](https://www.dreamwidth.org/img/silk/identity/user.png)
exor674.
Files modified:
http://bugs.dwscoalition.org/show_bug.cgi?id=2054
Add support for a routing system and Template Toolkit. This is Apache2
specific right now but as that's all we support, that's fine. Nothing yet
uses TT, either, but the edges data page is now using the routing system.
This should be considered experimental while Andrea (mostly) and I (some)
work on it.
Patch by
exor674.Files modified:
- bin/checkconfig.pl
- bin/upgrading/texttool.pl
- cgi-bin/Apache/LiveJournal.pm
- cgi-bin/DW/Controller/Edges.pm
- cgi-bin/DW/FragmentCache.pm
- cgi-bin/DW/Request/Apache2.pm
- cgi-bin/DW/Routing/Apache2.pm
- cgi-bin/DW/Template/Apache2.pm
- htdocs/data/edges.bml
- t/routing.t
- views/.placeholder
--------------------------------------------------------------------------------
diff -r e9c38b4446a4 -r 8f4e3e7a0082 bin/checkconfig.pl
--- a/bin/checkconfig.pl Fri Dec 11 15:48:55 2009 +0000
+++ b/bin/checkconfig.pl Sun Dec 13 09:57:28 2009 +0000
@@ -69,6 +69,7 @@ my %modules = (
"MIME::Words" => { 'deb' => 'libmime-perl', },
"Compress::Zlib" => { 'deb' => 'libcompress-zlib-perl', },
"Net::DNS" => { 'deb' => 'libnet-dns-perl', },
+ "Template" => { 'deb' => 'libtemplate-perl', },
"Net::OpenID::Server" => {
opt => 'Required for OpenID server support.'
},
diff -r e9c38b4446a4 -r 8f4e3e7a0082 bin/upgrading/texttool.pl
--- a/bin/upgrading/texttool.pl Fri Dec 11 15:48:55 2009 +0000
+++ b/bin/upgrading/texttool.pl Sun Dec 13 09:57:28 2009 +0000
@@ -364,7 +364,7 @@ sub poptext {
# learn about local files
chdir "$ENV{LJHOME}" or die "Failed to chdir to \$LJHOME.\n";
- my @textfiles = `find htdocs/ -name '*.text' -or -name '*.text.local'`;
+ my @textfiles = `find htdocs/ views/ -name '*.text' -or -name '*.text.local'`;
chomp @textfiles;
foreach my $tf (@textfiles) {
my $is_local = $tf =~ /\.local$/;
@@ -375,6 +375,7 @@ sub poptext {
}
my $pfx = $tf;
$pfx =~ s!^htdocs/!!;
+ $pfx =~ s!^views/!!;
$pfx =~ s!\.text(\.local)?$!!;
$pfx = "/$pfx";
$source{"$ENV{'LJHOME'}/$tf"} = [$lang, $pfx];
diff -r e9c38b4446a4 -r 8f4e3e7a0082 cgi-bin/Apache/LiveJournal.pm
--- a/cgi-bin/Apache/LiveJournal.pm Fri Dec 11 15:48:55 2009 +0000
+++ b/cgi-bin/Apache/LiveJournal.pm Sun Dec 13 09:57:28 2009 +0000
@@ -27,6 +27,7 @@ use Compress::Zlib;
use Compress::Zlib;
use XMLRPC::Transport::HTTP;
use LJ::URI;
+use DW::Routing::Apache2;
BEGIN {
$LJ::OPTMOD_ZLIB = eval "use Compress::Zlib (); 1;";
@@ -176,14 +177,12 @@ sub totally_down_content
if ($uri =~ m!^/interface/flat! || $uri =~ m!^/cgi-bin/log\.cg!) {
$r->content_type("text/plain");
-# $r->send_http_header();
$r->print("success\nFAIL\nerrmsg\n$LJ::SERVER_DOWN_MESSAGE");
return OK;
}
if ($uri =~ m!^/customview.cgi!) {
$r->content_type("text/html");
-# $r->send_http_header();
$r->print("<!-- $LJ::SERVER_DOWN_MESSAGE -->");
return OK;
}
@@ -193,7 +192,6 @@ sub totally_down_content
$r->status_line("503 Server Maintenance");
$r->content_type("text/html");
$r->headers_out->{"Content-length"} = length $body;
-# $r->send_http_header();
$r->print($body);
return OK;
@@ -205,7 +203,6 @@ sub blocked_bot
$r->status_line("403 Denied");
$r->content_type("text/html");
-# $r->send_http_header();
my $subject = $LJ::BLOCKED_BOT_SUBJECT || "403 Denied";
my $message = $LJ::BLOCKED_BOT_MESSAGE || "You don't have permission to view this page.";
@@ -323,6 +320,9 @@ sub trans
# only allow certain pages over SSL
if ($is_ssl) {
+ my $ret = DW::Routing::Apache2->call( $r, ssl => 1 );
+ return $ret if defined $ret;
+
if ($uri =~ m!^/interface/! || $uri =~ m!^/__rpc_!) {
# handled later
} elsif ($LJ::SSLDOCS && $uri !~ m!(\.\.|\%|\.\/)!) {
@@ -617,11 +617,6 @@ sub trans
my ($mode, $path) = ($1, $2);
- if ( $mode eq "edges" ) {
- $r->notes->{_journal} = $opts->{user};
- return $bml_handler->( "$LJ::HOME/htdocs/data/edges.bml" );
- }
-
if ($mode eq "customview") {
$r->handler("perl-script");
$r->push_handlers(PerlResponseHandler => \&customview_content);
@@ -650,7 +645,8 @@ sub trans
return DECLINED if $uuri eq "/favicon.ico";
# see if there is a modular handler for this URI
- my $ret = LJ::URI->handle($uuri, $r);
+ my $ret = LJ::URI->handle($uuri, $r) ||
+ DW::Routing::Apache2->call( $r, username => $user );
return $ret if defined $ret;
if ($uuri eq "/__setdomsess") {
@@ -946,7 +942,8 @@ sub trans
}
# see if there is a modular handler for this URI
- my $ret = LJ::URI->handle($uri, $r);
+ my $ret = LJ::URI->handle($uri, $r) ||
+ DW::Routing::Apache2->call( $r );
return $ret if defined $ret;
# customview (get an S1 journal by number)
@@ -1089,7 +1086,6 @@ sub userpic_content
$r->headers_out->{"Content-length"} = $size+0;
$r->headers_out->{"Cache-Control"} = "no-transform";
$r->headers_out->{"Last-Modified"} = LJ::time_to_http($lastmod);
-# $r->send_http_header();
};
# Load the user object and pic and make sure the picture is viewable
@@ -1270,7 +1266,6 @@ sub journal_content
$u->preload_props("opt_blockrobots", "adult_content");
$r->content_type("text/plain");
-# $r->send_http_header();
my @extra = LJ::run_hook("robots_txt_extra", $u), ();
$r->print($_) foreach @extra;
$r->print("User-Agent: *\n");
@@ -1296,7 +1291,6 @@ sub journal_content
my $res = LJ::auth_digest($r);
unless ($res) {
$r->content_type("text/html");
-# $r->send_http_header();
$r->print("<b>Digest authentication failed.</b>");
return OK;
}
@@ -1323,7 +1317,6 @@ sub journal_content
BML::get_request()->err_headers_out->add('Set-Cookie' => $cookiestr);
}
-# $r->send_http_header();
$r->print("Invalid cookies. Try <a href='$LJ::SITEROOT/logout.bml'>logging out</a> and then logging back in.\n");
$r->print("<!-- xxxxxxxxxxxxxxxxxxxxxxxx -->\n") for (0..100);
return OK;
@@ -1535,7 +1528,6 @@ sub journal_content
$r->headers_out->{'Vary'} = 'Accept-Encoding';
$r->headers_out->{"Content-length"} = $length;
-# $r->send_http_header();
$r->print($html) unless $r->header_only;
return OK;
@@ -1552,7 +1544,6 @@ sub customview_content
$charset = $FORM{'charset'};
if ($charset ne "utf-8" && ! Unicode::MapUTF8::utf8_supported_charset($charset)) {
$r->content_type("text/html");
-# $r->send_http_header();
$r->print("<b>Error:</b> requested charset not supported.");
return OK;
}
@@ -1616,7 +1607,6 @@ sub customview_content
$r->headers_out->{"Cache-Control"} = "must-revalidate";
$r->headers_out->{"Content-Length"} = length($data);
-# $r->send_http_header();
$r->print($data) unless $r->header_only;
return OK;
}
@@ -1754,7 +1744,6 @@ sub anti_squatter
$r->push_handlers(PerlResponseHandler => sub {
my $r = shift;
$r->content_type("text/html");
-# $r->send_http_header();
$r->print("<html><head><title>Dev Server Warning</title>",
"<style> body { border: 20px solid red; padding: 30px; margin: 0; font-family: sans-serif; } ",
"h1 { color: #500000; }",
diff -r e9c38b4446a4 -r 8f4e3e7a0082 cgi-bin/DW/Controller/Edges.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/DW/Controller/Edges.pm Sun Dec 13 09:57:28 2009 +0000
@@ -0,0 +1,116 @@
+#!/usr/bin/perl
+#
+# DW::Controller::Edges
+#
+# Outputs an account's edges in JSON format.
+#
+# Authors:
+# Thomas Thurman <thomas@thurman.org.uk>
+# foxfirefey <skittisheclipse@gmail.com>
+# Mark Smith <mark@dreamwidth.org>
+# Andrea Nall <anall@andreanall.com>
+#
+# Copyright (c) 2009 by Dreamwidth Studios, LLC.
+#
+# This program is free software; you may redistribute it and/or modify it under
+# the same terms as Perl itself. For a copy of the license, please reference
+# 'perldoc perlartistic' or 'perldoc perlgpl'.
+#
+
+package DW::Controller::Edges;
+
+use strict;
+use warnings;
+use DW::Routing::Apache2;
+use DW::Request;
+use JSON;
+
+DW::Routing::Apache2->register_string( "/data/edges", \&edges_handler, user => 1, format => 'json' );
+
+my $formats = {
+ 'json' => [ "application/json; charset=utf-8", sub { $_[0]->print( objToJson( $_[1] ) ); } ],
+};
+
+sub edges_handler {
+ my $opts = shift;
+ my $r = DW::Request->get;
+
+ # allow them to pick what format they want the data in, but bail if they ask for one
+ # we don't understand
+ my $format = $formats->{$opts->format};
+ return $r->NOT_FOUND if ! $format;
+
+ # content type early on
+ $r->content_type( $format->[0] );
+
+ # Outputs an error message
+ my $error_out = sub {
+ my ( $code, $message ) = @_;
+ $r->status( $code );
+ $format->[1]->( $r, { error => $message } );
+
+ return $r->OK;
+ };
+
+ # Load the account or error
+ return $error_out->(404, 'Need account name as user parameter') unless $opts->username;
+ my $u = LJ::load_user_or_identity( $opts->username )
+ or return $error_out->( 404, "invalid account");
+
+ # Check for other conditions
+ return $error_out->( 410, 'expunged' ) if $u->is_expunged;
+ return $error_out->( 403, 'suspended' ) if $u->is_suspended;
+ return $error_out->( 404, 'deleted' ) if $u->is_deleted;
+
+ # deal with renamed accounts
+ my $renamed_u = $u->get_renamed_user;
+ unless ( $renamed_u && $u->equals( $renamed_u ) ) {
+ $r->header_out("Location", $renamed_u->journalbase . "/data/edges");
+ $r->print( objToJson( { error => 'moved', moved_to => $renamed_u->journalbase . "/data/edges" } ) );
+ return $r->REDIRECT;
+ }
+
+ # Load appropriate usernames for different accounts
+ my $us;
+
+ if ( $u->is_individual ) {
+ $us = LJ::load_userids( $u->trusted_userids, $u->watched_userids, $u->trusted_by_userids, $u->watched_by_userids, $u->member_of_userids );
+ } elsif ( $u->is_community ) {
+ $us = LJ::load_userids( $u->maintainer_userids, $u->moderator_userids, $u->member_userids, $u->watched_by_userids );
+ } elsif ( $u->is_syndicated ) {
+ $us = LJ::load_userids( $u->watched_by_userids );
+ }
+
+ # Contruct the JSON response hash
+ my $response = {};
+
+ # all accounts have this
+ $response->{account_id} = $u->userid;
+ $response->{name} = $u->user;
+ $response->{display_name} = $u->display_name if $u->is_identity;
+ $response->{account_type} = $u->journaltype;
+ $response->{watched_by} = [ $u->watched_by_userids ];
+
+ # different individual and community edges
+ if ( $u->is_individual ) {
+ $response->{trusted} = [ $u->trusted_userids ];
+ $response->{watched} = [ $u->watched_userids ];
+ $response->{trusted_by} = [ $u->trusted_by_userids ];
+ $response->{member_of} = [ $u->member_of_userids ];
+ } elsif ( $u->is_community ) {
+ $response->{maintainer} = [ $u->maintainer_userids ];
+ $response->{moderator} = [ $u->moderator_userids ];
+ $response->{member} = [ $u->member_userids ];
+ }
+
+ # now dump information about the users we loaded
+ $response->{accounts} = {
+ map { $_ => { name => $us->{$_}->user, type => $us->{$_}->journaltype } } keys %$us
+ };
+
+ $format->[1]->( $r, $response );
+
+ return $r->OK;
+}
+
+1;
diff -r e9c38b4446a4 -r 8f4e3e7a0082 cgi-bin/DW/FragmentCache.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/DW/FragmentCache.pm Sun Dec 13 09:57:28 2009 +0000
@@ -0,0 +1,108 @@
+#!/usr/bin/perl
+#
+# DW::FragmentCache
+#
+# This module allows for caching the text return of a sub.
+#
+# Authors:
+# Mark Smith <mark@dreamwidth.org>
+# Andrea Nall <anall@andreanall.com>
+#
+# Copyright (c) 2009 by Dreamwidth Studios, LLC.
+#
+# This program is free software; you may redistribute it and/or modify it under
+# the same terms as Perl itself. For a copy of the license, please reference
+# 'perldoc perlartistic' or 'perldoc perlgpl'.
+#
+
+package DW::FragmentCache;
+use strict;
+
+=head1 NAME
+
+DW::FragmentCache - memcached fragment cache, with locks.
+
+=head1 SYNOPSIS
+
+=head1 API
+
+=head2 C<< $class->get( $key, $opts, $extra ) >>
+
+Valid $opts:
+
+=over
+
+=item B< lock_failed > - The text returned by this subref is returned if the lock is failed and the grace period is up.
+
+=item B< render > - This subref is only called if the cache is invalid, to regenerate the data
+
+=item B< expire > - Number of seconds the fragment is valid for
+
+=item B< grace_period > - Number of seconds that an expired fragment could still be served if the lock is in place
+
+=back
+
+extra is a hashref that'll be merged with whatever is stored.
+
+=cut
+
+sub get {
+ my ( $class, $key, $opts, $extra ) = @_;
+
+ $opts->{expire} ||= 60;
+ $opts->{grace_period} ||= 20;
+
+ my $page = LJ::MemCache::get( $key );
+
+ # return from the cache
+ if ( $page && $page->[0] > time ) {
+ LJ::text_uncompress( \$page->[1] );
+ $extra->{$_} = $page->[2]->{$_} foreach keys %{$page->[2]};
+ return $page->[1];
+ }
+
+ my $lock = LJ::locker()->trylock( $key );
+ unless ( $lock ) {
+ # no lock, someone else is updating this. let's try to print out the stale memcache
+ # page if possible, we know that next time it will be updated
+ if ( $page && $page->[1] > 0 ) {
+ LJ::text_uncompress( \$page->[1] );
+ $extra->{$_} = $page->[2]->{$_} foreach keys %{$page->[2]};
+ return $page->[1];
+ }
+
+ # if we get here, we don't have any data, and we don't have the lock so we can't
+ # construct any data. this should only happen in the rare case of a memcache
+ # flush when multiple people are hitting the page.
+ return $opts->{lock_failed} ? $opts->{lock_failed}->( $extra ) : "Sorry, something happened. Please refresh and try again!";
+ }
+
+ my $res = $opts->{render}->( $extra );
+ return $res if $extra->{abort_cache};
+ my $out = $res;
+ LJ::text_compress( \$out );
+ LJ::MemCache::set( $key, [ time + $opts->{expire}, $out, $extra ], $opts->{expire} + $opts->{grace_period} );
+ return $res;
+}
+
+=head1 AUTHOR
+
+=over
+
+=item Mark Smith <mark@dreamwidth.org>
+
+=item Andrea Nall <anall@andreanall.com>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2009 by Dreamwidth Studios, LLC.
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself. For a copy of the license, please reference
+'perldoc perlartistic' or 'perldoc perlgpl'.
+
+=cut
+
+1;
\ No newline at end of file
diff -r e9c38b4446a4 -r 8f4e3e7a0082 cgi-bin/DW/Request/Apache2.pm
--- a/cgi-bin/DW/Request/Apache2.pm Fri Dec 11 15:48:55 2009 +0000
+++ b/cgi-bin/DW/Request/Apache2.pm Sun Dec 13 09:57:28 2009 +0000
@@ -27,12 +27,15 @@ use Apache2::RequestIO ();
use Apache2::RequestIO ();
use Apache2::SubProcess ();
+use DW::Routing::Apache2;
+
use fields (
'r', # The Apache2::Request object
# these are mutually exclusive; if you use one you can't use the other
'content', # raw content
'post_args', # hashref of POST arguments
+ 'get_args', # hashref of GET arguments
);
# creates a new DW::Request object, based on what type of server environment we
@@ -111,6 +114,14 @@ sub post_args {
return $self->{post_args};
}
+sub get_args {
+ my DW::Request::Apache2 $self = $_[0];
+ return $self->{get_args} if defined $self->{get_args};
+
+ my %gets = LJ::parse_args( $self->query_string );
+ return $self->{get_args} = \%gets;
+}
+
# searches for a given note and returns the value, or sets it
sub note {
my DW::Request::Apache2 $self = $_[0];
@@ -163,10 +174,19 @@ sub set_last_modified {
return $self->{r}->set_last_modified($_[1]);
}
+sub status {
+ my DW::Request::Apache2 $self = $_[0];
+ if (scalar(@_) == 2) {
+ $self->{r}->status($_[1]+0);
+ } else {
+ return $self->{r}->status();
+ }
+}
+
sub status_line {
my DW::Request::Apache2 $self = $_[0];
if (scalar(@_) == 2) {
- # Apparently both status and status_line must be set
+ # If we set status_line, we must also set status.
my ($status) = $_[1] =~ m/^(\d+)/;
$self->{r}->status($status);
return $self->{r}->status_line($_[1]);
@@ -198,6 +218,16 @@ sub OK {
return Apache2::Const::OK;
}
+sub REDIRECT {
+ my DW::Request::Apache2 $self = $_[0];
+ return Apache2::Const::REDIRECT;
+}
+
+sub NOT_FOUND {
+ my DW::Request::Apache2 $self = $_[0];
+ return Apache2::Const::NOT_FOUND;
+}
+
# spawn a process for an external program
sub spawn {
my DW::Request::Apache2 $self = shift;
diff -r e9c38b4446a4 -r 8f4e3e7a0082 cgi-bin/DW/Routing/Apache2.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/DW/Routing/Apache2.pm Sun Dec 13 09:57:28 2009 +0000
@@ -0,0 +1,393 @@
+#!/usr/bin/perl
+#
+# DW::Routing::Apache2
+#
+# Module to allow calling non-BML controller/views.
+#
+# Authors:
+# Andrea Nall <anall@andreanall.com>
+# Mark Smith <mark@dreamwidth.org>
+#
+# Copyright (c) 2009 by Dreamwidth Studios, LLC.
+#
+# This program is free software; you may redistribute it and/or modify it under
+# the same terms as Perl itself. For a copy of the license, please reference
+# 'perldoc perlartistic' or 'perldoc perlgpl'.
+#
+
+package DW::Routing::Apache2;
+use strict;
+
+use LJ::ModuleLoader;
+use DW::Template::Apache2;
+use JSON;
+
+# FIXME: This shouldn't depend on Apache, but I'm using it here as I need to do a few calls
+# that aren't supported by DW::Request, as well as it's needed in DW::Template.
+use Apache2::Const qw/ :common REDIRECT HTTP_NOT_MODIFIED
+ HTTP_MOVED_PERMANENTLY HTTP_MOVED_TEMPORARILY
+ M_TRACE M_OPTIONS /;
+
+my %string_choices;
+my %regex_choices = (
+ app => [],
+ ssl => [],
+ user => []
+);
+
+my $default_content_types = {
+ 'html' => "text/html; charset=utf-8",
+ 'json' => "application/json; charset=utf-8",
+};
+
+LJ::ModuleLoader->autouse_subclasses( "DW::Controller" );
+
+=head1 NAME
+
+DW::Routing::Apache2 - Module to allow calling non-BML controller/views.
+
+=head1 SYNOPSIS
+
+=head1 Page Call API
+
+=head2 C<< $class->call( $r, %opts ) >>
+
+=cut
+
+sub call {
+ my ( $class, $r, %opts ) = @_;
+
+ my ( $uri, $format ) = ( $r->uri, undef );
+ ( $uri, $format ) = ( $1, $2 )
+ if $uri =~ m/^(.+?)\.([a-z]+)$/;
+
+ # add more data to the options hash, we'll need it
+ $opts{mode} = $opts{ssl} ? 'ssl' : ( $opts{username} ? 'user' : 'app' );
+ $opts{uri} = $uri;
+ $opts{format} = $format;
+ $opts{__r} = $r;
+
+ # we construct this object as an easy way to get options later, it gives
+ # us accessors. FIXME: this should be a separate class, not DW::Routing.
+ my $call_opts = bless( \%opts, $class );
+
+ # try the string options first as they're fast
+ my $hash = $opts{__hash} = $string_choices{$opts{mode} . $uri};
+ return $class->call_hash( $call_opts ) if defined $hash;
+
+ # try the regex choices next
+ # FIXME: this should be a dynamically sorting array so the most used items float to the top
+ # for now it doesn't matter so much but eventually when everything is in the routing table
+ # that will have to be done
+ my @args;
+ foreach $hash ( @{ $regex_choices{$opts{mode}} } ) {
+ if ( ( @args = $uri =~ $hash->{regex} ) ) {
+ $opts{__hash} = $hash;
+ $opts{subpatterns} = \@args;
+ return $class->call_hash( $call_opts );
+ }
+ }
+
+ # failed to find anything so fall through
+ return undef;
+}
+
+=head2 C<< $class->call_hash( $class, $call_opts ) >>
+
+Calls the raw hash.
+
+=cut
+
+sub call_hash {
+ my ( $class, $opts ) = @_;
+
+ my $hash = $opts->{__hash};
+ return undef unless $hash && $hash->{sub} && $opts->{__r};
+
+ $opts->{__r}->handler( 'perl-script' );
+ $opts->{__r}->pnotes->{routing_opts} = $opts;
+ $opts->{__r}->push_handlers( PerlResponseHandler => \&_call_hash );
+
+ return OK;
+}
+
+=head2 C<< $class->_call_hash( $r ) >>
+
+Perl Response Handler for call_hash
+
+=cut
+
+sub _call_hash {
+ my ( $r ) = @_;
+ my $opts = $r->pnotes->{routing_opts};
+ my $hash = $opts->{__hash};
+
+ $opts->{format} ||= $hash->{format};
+
+ my $format = $opts->{format};
+ $r->content_type( $default_content_types->{$format} )
+ if $default_content_types->{$format};
+
+ # try to call the handler that actually does the content creation; it will
+ # return either a string (valid result), or a number (HTTP code), or undef
+ # means there was an error of some sort
+ my $ret = eval { return $hash->{sub}->( $opts ) };
+ return $ret unless $@;
+
+ # here down is simply error handling for whatever the handler sub above
+ # might have died with
+ my $msg = $@;
+
+ my $err = LJ::errobj( $msg )
+ or die "LJ::errobj didn't return anything.";
+ $err->log;
+
+ # JSON error rendering
+ if ( $format eq 'json' ) {
+ my $text = $LJ::MSG_ERROR || "Sorry, there was a problem.";
+ my $remote = LJ::get_remote();
+ $text = "$msg" if ( $remote && $remote->show_raw_errors ) || $LJ::IS_DEV_SERVER;
+
+ $r->status( 500 );
+ $r->print(objToJson( { error => $text } ));
+ return OK;
+
+ # default error rendering
+ } else {
+ $msg = $err->as_html;
+
+ chomp $msg;
+ $msg .= " \@ $LJ::SERVER_NAME" if $LJ::SERVER_NAME;
+ warn "$msg\n";
+
+ $r->status( 500 );
+ my $text = $LJ::MSG_ERROR || "Sorry, there was a problem.";
+ my $remote = LJ::get_remote();
+ $text = "<b>[Error: $msg]</b>" if ( $remote && $remote->show_raw_errors ) || $LJ::IS_DEV_SERVER;
+ return DW::Template::Apache2->render_string( $r, $text, { status=>500, content_type=>'text/html' } );
+ }
+}
+
+sub _static_helper {
+ return NOT_FOUND unless $_[0]->format eq 'html';
+ return $_[0]->render_template( $_[0]->args );
+}
+
+=head1 Registration API
+
+=head2 C<< $class->register_static($string, $filename, $opts) >>
+
+Static page helper.
+
+=over
+
+=item string - path
+
+=item filename - template filename
+
+=item Opts:
+
+=over
+
+=item ssl - If this sub should run for ssl.
+
+=item app - 1 if app
+
+=item user - 1 if user
+
+=back
+
+=back
+
+=cut
+
+sub register_static {
+ my ( $class, $string, $fn, %opts ) = @_;
+
+ $opts{args} = $fn;
+ $class->register_string( $string, \&_static_helper, %opts );
+}
+
+=head2 C<< $class->register_string($string, $sub, $opts) >>
+
+=over
+
+=item string - path
+
+=item sub - sub
+
+=item Opts:
+
+=over
+
+=item ssl - If this sub should run for ssl.
+
+=item args - passed verbatim to sub.
+
+=item app - 1 if app
+
+=item user - 1 if user
+
+=back
+
+=back
+
+=cut
+
+sub register_string {
+ my ( $class, $string, $sub, %opts ) = @_;
+
+ $opts{app} = 1 if ! defined $opts{app} && ! $opts{user};
+ my $hash = {
+ args => $opts{args},
+ sub => $sub,
+ ssl => $opts{ssl} || 0,
+ app => $opts{app} || 0,
+ user => $opts{user} || 0,
+ format => $opts{format} || 'html',
+ };
+ $string_choices{'app' . $string} = $hash if $hash->{app};
+ $string_choices{'ssl' . $string} = $hash if $hash->{ssl};
+ $string_choices{'user' . $string} = $hash if $hash->{user};
+}
+
+=head2 C<< $class->register_regex($regex, $sub, $opts) >>
+
+=over
+
+=item regex
+
+=item sub - sub
+
+=over
+
+=item Opts:
+
+=over
+
+=item ssl - If this sub should run for ssl.
+
+=item args - passed verbatim to sub.
+
+=item app - 1 if app
+
+=item user - 1 if user
+
+=back
+
+=back
+
+=cut
+sub register_regex {
+ my ( $class, $regex, $sub, %opts ) = @_;
+
+ $opts{app} = 1 if ! defined $opts{app} && !$opts{user};
+ my $hash = {
+ regex => $regex,
+ args => $opts{args},
+ sub => $sub,
+ ssl => $opts{ssl} || 0,
+ app => $opts{app} || 0,
+ user => $opts{user} || 0,
+ format => $opts{format} || 'html',
+ };
+ push @{$regex_choices{app}}, $hash if $hash->{app};
+ push @{$regex_choices{ssl}}, $hash if $hash->{ssl};
+ push @{$regex_choices{user}}, $hash if $hash->{user};
+}
+
+=head1 Controller API
+
+API to be used from the controllers.
+
+=head2 C<< $self->render_template( $template, $data, $extra ) >>
+
+Wrap stuff in the sitescheme.
+
+Helper so the controller doesn't need to dig out the Apache request.
+
+=cut
+
+sub render_template {
+ my $self = shift;
+ return DW::Template::Apache2->render_template( $self->{__r}, @_ );
+}
+
+=head2 C<< $self->render_cached_template( $key, $template, $subref, $extra ) >>
+
+Wrap stuff in the sitescheme.
+
+Helper so the controller doesn't need to dig out the Apache request.
+
+=cut
+
+sub render_cached_template {
+ my $self = shift;
+ return DW::Template::Apache2->render_cached_template( $self->{__r}, @_ );
+}
+
+=head2 C<< $self->args >>
+
+Return the arguments passed to the register call.
+
+=cut
+
+sub args { return $_[0]->{__hash}->{args}; }
+
+=head2 C<< $self->format >>
+
+Return the format.
+
+=cut
+
+sub format { return $_[0]->{format}; }
+
+=head2 C<< $self->mode >>
+
+Current mode: 'app' or 'user' or 'ssl'
+
+=cut
+
+sub mode { return $_[0]->{mode}; }
+
+=head2 C<< $self->ssl >>
+
+Is SSL request?
+
+=cut
+
+sub ssl { return $_[0]->{mode} eq 'ssl' ? 1 : 0; }
+
+=head2 C<< $self->subpatterns >>
+
+Return the regex matches.
+
+=cut
+
+sub subpatterns { return $_[0]->{subpatterns}; }
+
+=head2 C<< $self->username >>
+
+Username
+
+=cut
+
+sub username { return $_[0]->{username}; }
+
+=head1 AUTHOR
+
+=item Andrea Nall <anall@andreanall.com>
+
+=item Mark Smith <mark@dreamwidth.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2009 by Dreamwidth Studios, LLC.
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself. For a copy of the license, please reference
+'perldoc perlartistic' or 'perldoc perlgpl'.
+
+=cut
+
+1;
diff -r e9c38b4446a4 -r 8f4e3e7a0082 cgi-bin/DW/Template/Apache2.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/DW/Template/Apache2.pm Sun Dec 13 09:57:28 2009 +0000
@@ -0,0 +1,319 @@
+#!/usr/bin/perl
+#
+# DW::Template::Apache2
+#
+# Template Toolkit helpers for Apache2.
+#
+# Authors:
+# Andrea Nall <anall@andreanall.com>
+#
+# Copyright (c) 2009 by Dreamwidth Studios, LLC.
+#
+# This program is free software; you may redistribute it and/or modify it under
+# the same terms as Perl itself. For a copy of the license, please reference
+# 'perldoc perlartistic' or 'perldoc perlgpl'.
+#
+
+package DW::Template::Apache2;
+use strict;
+use Template;
+use Template::Plugins;
+use Template::Namespace::Constants;
+use DW::FragmentCache;
+
+# FIXME: I cannot use a DW::Request for the Apache::BML::handler call,
+# so I am only using Apache2 requests here, not mixing the two objects inside the same methods.
+# Once we dispose of BML, this can switch.
+use Apache2::Const qw/ :common /;
+
+=head1 NAME
+
+DW::Template::Apache2 - Template Toolkit helpers for Apache2.
+
+=head1 SYNOPSIS
+
+=cut
+
+# setting this to 0 -- have to explicitly specify which plugins we want.
+$Template::Plugins::PLUGIN_BASE = '';
+
+my $site_constants = Template::Namespace::Constants->new({
+ name => $LJ::SITENAME,
+ nameshort => $LJ::SITENAMESHORT,
+ nameabbrev => $LJ::SITENAMEABBREV,
+ company => $LJ::SITECOMPANY,
+});
+
+my $roots_constants = Template::Namespace::Constants->new({
+ site => $LJ::SITEROOT,
+});
+
+# precreating this
+my $view_engine = Template->new({
+ INCLUDE_PATH => "$LJ::HOME/views/",
+ NAMESPACE => {
+ site => $site_constants,
+ roots => $roots_constants,
+ },
+ FILTERS => {
+ ml => [ \&ml, 0 ],
+ },
+ CACHE_SIZE => $LJ::TEMPLATE_CACHE_SIZE, # this can be undef, and that means cache everything.
+ STAT_TTL => $LJ::IS_DEV_SERVER ? 1 : 3600,
+ PLUGINS => {
+ autoformat => 'Template::Plugin::Autoformat',
+ date => 'Template::Plugin::Date',
+ url => 'Template::Plugin::URL',
+ },
+});
+
+=head1 API
+
+=head2 C<< $class->template_string( $filename, $opts ) >>
+
+Render a template to a string.
+
+=cut
+
+sub template_string {
+ my ($class, $filename, $opts) = @_;
+ my $r = DW::Request->get;
+
+ $r->note('ml_scope',"/$filename") unless $r->note('ml_scope');
+
+ my $out;
+ $view_engine->process( $filename, $opts, \$out ) or die $view_engine->error();
+
+ return $out;
+}
+
+=head2 C<< $class->cached_template_string( $key, $filename, $subref, $opts, $extra ) >>
+
+Render a template to a string -- optionally fragment caching it.
+$subref returns the options for template_string.
+
+fragment opts:
+
+=over
+
+=item B< lock_failed > - The text returned by this subref is returned if the lock is failed and the grace period is up.
+
+=item B< expire > - Number of seconds the fragment is valid for
+
+=item B< grace_period > - Number of seconds that an expired fragment could still be served if the lock is in place
+
+=back
+
+=cut
+
+sub cached_template_string {
+ my ($class, $key, $filename, $subref, $opts, $extra ) = @_;
+
+ return DW::FragmentCache->get( $key, {
+ lock_failed => $opts->{lock_failed},
+ expire => $opts->{expire},
+ grace_period => $opts->{grace_period},
+ render => sub {
+ return $class->template_string( $filename, $subref->( $_[0] ) );
+ }
+ }, $extra);
+}
+
+=head2 C<< $class->render_cached_template( $r, $key, $filename, $subref, $extra ) >>
+
+Render a template inside the sitescheme or alone.
+
+NOTE: $r needs to be an Apache2 request, not a DW::Request.
+
+See render_template, except note that the opts hash is returned by subref if it's needed.
+
+$extra can contain:
+
+=over
+
+=item B< no_sitescheme > == render alone
+
+=item B< title / windowtitle / head / bodyopts / ... > == text to get thrown in the section if inside sitescheme
+
+=item B< content_type > = content type
+
+=item B< status > = HTTP status code
+
+=item B< lock_failed > = subref for lock failed.
+
+=item B< expire > - Number of seconds the fragment is valid for
+
+=item B< grace_period > - Number of seconds that an expired fragment could still be served if the lock is in place
+
+=back
+
+=cut
+
+sub render_cached_template {
+ my ($class, $r, $key, $filename, $subref, $opts, $extra) = @_;
+
+ $extra ||= {};
+
+ my $out = $class->cached_template_string( $key, $filename, $subref, $opts, $extra );
+
+ return $class->render_string( $r, $out, $extra );
+}
+
+=head2 C<< $class->render_template( $r, $filename, $opts, $extra ) >>
+
+Render a template inside the sitescheme or alone.
+
+NOTE: $r needs to be an Apache2 request, not a DW::Request.
+
+$extra can contain:
+
+=over
+
+=item B< no_sitescheme > == render alone
+
+=item B< title / windowtitle / head / bodyopts / ... > == text to get thrown in the section if inside sitescheme
+
+=item B< content_type > = content type
+
+=item B< status > = HTTP status code
+
+=back
+
+=cut
+
+sub render_template {
+ my ( $class, $r, $filename, $opts, $extra ) = @_;
+
+ my $out = $class->template_string( $filename, $opts );
+
+ return $class->render_string( $r, $out, $extra );
+}
+
+=head2 C<< $class->render_string( $r, $string, $extra ) >>
+
+Render a string inside the sitescheme or alone.
+
+NOTE: $r needs to be an Apache2 request, not a DW::Request.
+
+$extra can contain:
+
+=over
+
+=item B< no_sitescheme > == render alone
+
+=item B< title / windowtitle / head / bodyopts / ... > == text to get thrown in the section if inside sitescheme
+
+=item B< content_type > = content type
+
+=item B< status > = HTTP status code
+
+=back
+
+=cut
+sub render_string {
+ my ( $class, $r, $out, $extra ) = @_;
+
+ $r->status( $extra->{status} ) if $extra->{status};
+ $r->content_type( $extra->{content_type} ) if $extra->{content_type};
+
+ if ( $extra->{no_sitescheme} ) {
+ $r->print( $out );
+
+ return OK;
+ } else {
+ $r->pnotes->{render_sitescheme_code} = $out;
+ $r->pnotes->{render_sitescheme_extra} = $extra || {};
+ $r->notes->{bml_filename} = "$LJ::HOME/htdocs/misc/render_sitescheme.bml";
+
+ return Apache::BML::handler($r);
+ }
+}
+
+=head1 ML Stuff
+
+NOTE: All these methods use DW::Template::Apache2::blah, not DW::Template::Apache2->blah.
+
+=head2 C<< DW::Template::Apache2::ml_scope( $scope ) >>
+
+Gets the scope or sets the scope to the given location
+
+=cut
+
+sub ml_scope {
+ return DW::Request->get->note('ml_scope', $_[0]);
+}
+
+=head2 C<< DW::Template::Apache2::ml( $code, $vars ) >>
+
+=cut
+
+sub ml {
+ my ( $code, $vars ) = @_;
+ my $r = DW::Request->get;
+ $code = $r->note( 'ml_scope' ) . $code if rindex($code, '.', 0) == 0;
+ my $lang = decide_language();
+ return $code if $lang eq 'debug';
+ LJ::Lang::get_text( $lang, $code, undef, $vars );
+}
+
+sub decide_language {
+ my $r = DW::Request->get;
+ return $r->note( 'ml_lang' ) if $r->note( 'ml_lang' );
+
+ my $lang = _decide_language();
+
+ $r->note( 'ml_lang', $lang );
+ return $lang;
+}
+
+sub _decide_language
+{
+ my $r = DW::Request->get;
+
+ my $args = $r->get_args;
+ # GET param 'uselang' takes priority
+ my $uselang = $args->{'uselang'};
+ if ( $uselang eq "debug" || LJ::Lang::get_lang($uselang) ) {
+ return $uselang;
+ }
+
+ # next is their cookie preference
+ #FIXME: COOKIE!
+ #if ($BML::COOKIE{'langpref'} =~ m!^(\w{2,10})/(\d+)$!) {
+ # if (exists $env->{"Langs-$1"}) {
+ # # FIXME: Probably should actually do this!!!
+ # # make sure the document says it was changed at least as new as when
+ # # the user last set their current language, else their browser might
+ # # show a cached (wrong language) version.
+ # return $1;
+ # }
+ #}
+
+ # FIXME: next is their browser's preference
+
+ # next is the default language
+ return $LJ::DEFAULT_LANG || $LJ::LANGS[0];
+
+ # lastly, english.
+ return "en";
+}
+
+=head1 AUTHOR
+
+=over
+
+=item Andrea Nall <anall@andreanall.com>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2009 by Dreamwidth Studios, LLC.
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself. For a copy of the license, please reference
+'perldoc perlartistic' or 'perldoc perlgpl'.
+
+=cut
+
+1;
diff -r e9c38b4446a4 -r 8f4e3e7a0082 htdocs/data/edges.bml
--- a/htdocs/data/edges.bml Fri Dec 11 15:48:55 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,93 +0,0 @@
-<?_code
-{
- #
- # edges.bml
- #
- # Outputs an account's edges in JSON format.
- #
- # Authors:
- # Thomas Thurman <thomas@thurman.org.uk>
- # foxfirefey <skittisheclipse@gmail.com>
- # Mark Smith <mark@dreamwidth.org>
- #
- # Copyright (c) 2009 by Dreamwidth Studios, LLC.
- #
- # This program is free software; you may redistribute it and/or modify it under
- # the same terms as Perl itself. For a copy of the license, please reference
- # 'perldoc perlartistic' or 'perldoc perlgpl'.
- #
-
- use strict;
- use warnings;
- use vars qw/ %GET /;
- use JSON;
-
- BML::set_content_type( "application/json" );
-
- # Outputs an error message
- my $error_in_json = sub {
- my ( $code, $message ) = @_;
- BML::set_status( $code );
- BML::noparse( objToJson( { error => $message } ) );
- };
-
- # make sure we get a user
- eval { $GET{user} ||= DW::Request->get->note( '_journal' ); };
-
- # Load the account or error
- return $error_in_json->(404, 'Need account name as user parameter') unless $GET{user};
- my $u = LJ::load_user_or_identity( $GET{user} )
- or return $error_in_json->( 404, "invalid account");
-
- # Check for other conditions
- return $error_in_json->( 410, 'expunged' ) if $u->is_expunged;
- return $error_in_json->( 403, 'suspended' ) if $u->is_suspended;
- return $error_in_json->( 404, 'deleted' ) if $u->is_deleted;
-
- # deal with renamed accounts
- my $renamed_u = $u->get_renamed_user;
- return $renamed_u->journal_base . '/edges'
- unless $renamed_u && $u->equals( $renamed_u );
-
- # Load appropriate usernames for different accounts
- my $us;
-
- if ( $u->is_individual ) {
- $us = LJ::load_userids( $u->trusted_userids, $u->watched_userids, $u->trusted_by_userids, $u->watched_by_userids, $u->member_of_userids );
- } elsif ( $u->is_community ) {
- $us = LJ::load_userids( $u->maintainer_userids, $u->moderator_userids, $u->member_userids, $u->watched_by_userids );
- } elsif ( $u->is_syndicated ) {
- $us = LJ::load_userids( $u->watched_by_userids );
- }
-
- # Contruct the JSON response hash
- my $response = {};
-
- # all accounts have this
- $response->{account_id} = $u->userid;
- $response->{name} = $u->user;
- $response->{display_name} = $u->display_name if $u->is_identity;
- $response->{account_type} = $u->journaltype;
- $response->{watched_by} = [ $u->watched_by_userids ];
-
- # different individual and community edges
- if ( $u->is_individual ) {
- $response->{trusted} = [ $u->trusted_userids ];
- $response->{watched} = [ $u->watched_userids ];
- $response->{trusted_by} = [ $u->trusted_by_userids ];
- $response->{member_of} = [ $u->member_of_userids ];
- } elsif ( $u->is_community ) {
- $response->{maintainer} = [ $u->maintainer_userids ];
- $response->{moderator} = [ $u->moderator_userids ];
- $response->{member} = [ $u->member_userids ];
- }
-
- # now dump information about the users we loaded
- $response->{accounts} = {
- map { $_ => { name => $us->{$_}->user, type => $us->{$_}->journaltype } } keys %$us
- };
-
- # Output to BML
- return BML::noparse( objToJson( $response ) );
-}
-_code?>
diff -r e9c38b4446a4 -r 8f4e3e7a0082 t/routing.t
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/t/routing.t Sun Dec 13 09:57:28 2009 +0000
@@ -0,0 +1,250 @@
+# -*-perl-*-
+use strict;
+use Test::More tests => 294;
+use lib "$ENV{LJHOME}/cgi-bin";
+require 'ljlib.pl';
+use DW::Routing::Apache2;
+use Apache2::Const qw/ :common REDIRECT HTTP_NOT_MODIFIED
+ HTTP_MOVED_PERMANENTLY HTTP_MOVED_TEMPORARILY
+ M_TRACE M_OPTIONS /;
+
+my $result;
+my $expected_format = 'html';
+my $__name;
+
+handle_request( "foo", "/foo", 0, 0 ); # 1 test
+handle_request( "foo", "/foo.format", 0, 0 ); # 1 test
+# 2
+
+DW::Routing::Apache2->register_string( "/test/app", \&handler, app => 1, args => "it_worked_app" );
+
+$expected_format = 'html';
+handle_request( "/test app (app)" , "/test/app", 1, "it_worked_app" ); # 6 tests
+handle_request( "/test app (ssl)" , "/test/app", 0, "it_worked_app", ssl => 1 ); # 1 test
+handle_request( "/test app (user)", "/test/app", 0, "it_worked_app", username => 'test' ); # 1 test
+# 10
+
+$expected_format = 'format';
+handle_request( "/test app (app)" , "/test/app.format", 1, "it_worked_app" ); # 6 tests
+handle_request( "/test app (ssl)" , "/test/app.format", 0, "it_worked_app", ssl => 1 ); # 1 test
+handle_request( "/test app (user)", "/test/app.format", 0, "it_worked_app", username => 'test' ); # 1 test
+# 18
+
+DW::Routing::Apache2->register_string( "/test/ssl", \&handler, ssl => 1, app => 0, args => "it_worked_ssl" );
+
+$expected_format = 'html';
+handle_request( "/test ssl (app)" , "/test/ssl", 0, "it_worked_ssl" ); # 1 tests
+handle_request( "/test ssl (ssl)" , "/test/ssl", 1, "it_worked_ssl", ssl => 1 ); # 1 test
+handle_request( "/test ssl (user)", "/test/ssl", 0, "it_worked_ssl", username => 'test' ); # 6 tests
+# 26
+
+$expected_format = 'format';
+handle_request( "/test ssl (app)" , "/test/ssl.format", 0, "it_worked_ssl" ); # 1 tests
+handle_request( "/test ssl (ssl)" , "/test/ssl.format", 1, "it_worked_ssl", ssl => 1 ); # 1 test
+handle_request( "/test ssl (user)", "/test/ssl.format", 0, "it_worked_ssl", username => 'test' ); # 6 tests
+# 34
+
+DW::Routing::Apache2->register_string( "/test/user", \&handler, user => 1, args => "it_worked_user" );
+
+$expected_format = 'html';
+handle_request( "/test user (app)" , "/test/user", 0, "it_worked_user" ); # 1 tests
+handle_request( "/test user (ssl)" , "/test/user", 0, "it_worked_user", ssl => 1 ); # 1 test
+handle_request( "/test user (user)", "/test/user", 1, "it_worked_user", username => 'test' ); # 6 tests
+# 42
+
+$expected_format = 'format';
+handle_request( "/test user (app)" , "/test/user.format", 0, "it_worked_user" ); # 1 tests
+handle_request( "/test user (ssl)" , "/test/user.format", 0, "it_worked_user", ssl => 1 ); # 1 test
+handle_request( "/test user (user)", "/test/user.format", 1, "it_worked_user", username => 'test' ); # 6 tests
+# 50
+
+DW::Routing::Apache2->register_string( "/test", \&handler, app => 1, args => "it_worked_app" );
+DW::Routing::Apache2->register_string( "/test", \&handler, ssl => 1, app => 0, args => "it_worked_ssl" );
+DW::Routing::Apache2->register_string( "/test", \&handler, user => 1, args => "it_worked_user" );
+
+$expected_format = 'html';
+handle_request( "/test multi (app)" , "/test", 1, "it_worked_app" ); # 6 tests
+handle_request( "/test multi (ssl)" , "/test", 1, "it_worked_ssl", ssl => 1 ); # 6 tests
+handle_request( "/test multi (user)", "/test", 1, "it_worked_user", username => 'test' ); # 6 tests
+# 68
+
+$expected_format = 'format';
+handle_request( "/test multi (app)" , "/test.format", 1, "it_worked_app" ); # 6 tests
+handle_request( "/test multi (ssl)" , "/test.format", 1, "it_worked_ssl", ssl => 1 ); # 6 tests
+handle_request( "/test multi (user)", "/test.format", 1, "it_worked_user", username => 'test' ); # 6 tests
+# 86
+
+DW::Routing::Apache2->register_string( "/test/all", \&handler, app => 1, user => 1, ssl => 1, format => 'json', args => "it_worked_multi" );
+
+$expected_format = 'json';
+handle_request( "/test all (app)" , "/test/all", 1, "it_worked_multi"); # 6 tests
+handle_request( "/test all (ssl)" , "/test/all", 1, "it_worked_multi", ssl => 1 ); # 6 tests
+handle_request( "/test all (user)", "/test/all", 1, "it_worked_multi", username => 'test' ); # 6 tests
+# 104
+
+$expected_format = 'format';
+handle_request( "/test all (app)" , "/test/all.format", 1, "it_worked_multi"); # 6 tests
+handle_request( "/test all (ssl)" , "/test/all.format", 1, "it_worked_multi", ssl => 1 ); # 6 tests
+handle_request( "/test all (user)", "/test/all.format", 1, "it_worked_multi", username => 'test' ); # 6 tests
+# 122
+
+DW::Routing::Apache2->register_regex( qr !^/r/app(/.+)$!, \®ex_handler, app => 1, args => ["/test", "it_worked_app"] );
+
+$expected_format = 'html';
+handle_request( "/r/app (app)" , "/r/app/test", 1, "it_worked_app" ); # 6 tests
+handle_request( "/r/app (ssl)" , "/r/app/test", 0, "it_worked_app", ssl => 1 ); # 1 test
+handle_request( "/r/app (user)", "/r/app/test", 0, "it_worked_app", username => 'test' ); # 1 test
+# 130
+
+$expected_format = 'format';
+handle_request( "/r/app (app)" , "/r/app/test.format", 1, "it_worked_app" ); # 6 tests
+handle_request( "/r/app (ssl)" , "/r/app/test.format", 0, "it_worked_app", ssl => 1 ); # 1 test
+handle_request( "/r/app (user)", "/r/app/test.format", 0, "it_worked_app", username => 'test' ); # 1 test
+# 138
+
+DW::Routing::Apache2->register_regex( qr !^/r/ssl(/.+)$!, \®ex_handler, ssl => 1, app => 0, args => ["/test", "it_worked_ssl"] );
+
+$expected_format = 'html';
+handle_request( "/r/ssl (app)" , "/r/ssl/test", 0, "it_worked_ssl" ); # 1 tests
+handle_request( "/r/ssl (ssl)" , "/r/ssl/test", 1, "it_worked_ssl", ssl => 1 ); # 6 test
+handle_request( "/r/ssl (user)", "/r/ssl/test", 0, "it_worked_ssl", username => 'test' ); # 1 test
+# 146
+
+$expected_format = 'format';
+handle_request( "/r/ssl (app)" , "/r/ssl/test.format", 0, "it_worked_ssl" ); # 1 tests
+handle_request( "/r/ssl (ssl)" , "/r/ssl/test.format", 1, "it_worked_ssl", ssl => 1 ); # 6 test
+handle_request( "/r/ssl (user)", "/r/ssl/test.format", 0, "it_worked_ssl", username => 'test' ); # 1 test
+# 154
+
+DW::Routing::Apache2->register_regex( qr !^/r/user(/.+)$!, \®ex_handler, user => 1, args => ["/test", "it_worked_user"] );
+
+$expected_format = 'html';
+handle_request( "/r/user (app)" , "/r/user/test", 0, "it_worked_user" ); # 1 tests
+handle_request( "/r/user (ssl)" , "/r/user/test", 0, "it_worked_user", ssl => 1 ); # 1 test
+handle_request( "/r/user (user)", "/r/user/test", 1, "it_worked_user", username => 'test' ); # 6 test
+# 162
+
+$expected_format = 'format';
+handle_request( "/r/user (app)" , "/r/user/test.format", 0, "it_worked_user" ); # 1 tests
+handle_request( "/r/user (ssl)" , "/r/user/test.format", 0, "it_worked_user", ssl => 1 ); # 1 test
+handle_request( "/r/user (user)", "/r/user/test.format", 1, "it_worked_user", username => 'test' ); # 6 test
+# 170
+
+DW::Routing::Apache2->register_regex( qr !^/r/multi(/.+)$!, \®ex_handler, app => 1, args => ["/test", "it_worked_app"] );
+DW::Routing::Apache2->register_regex( qr !^/r/multi(/.+)$!, \®ex_handler, ssl => 1, app => 0, args => ["/test", "it_worked_ssl"] );
+DW::Routing::Apache2->register_regex( qr !^/r/multi(/.+)$!, \®ex_handler, user => 1, args => ["/test", "it_worked_user"] );
+
+$expected_format = 'html';
+handle_request( "/r/multi (app)" , "/r/multi/test", 1, "it_worked_app" ); # 6 test
+handle_request( "/r/multi (ssl)" , "/r/multi/test", 1, "it_worked_ssl", ssl => 1 ); # 6 test
+handle_request( "/r/multi (user)", "/r/multi/test", 1, "it_worked_user", username => 'test' ); # 6 test
+# 188
+
+$expected_format = 'format';
+handle_request( "/r/multi (app)" , "/r/multi/test.format", 1, "it_worked_app" ); # 6 tests
+handle_request( "/r/multi (ssl)" , "/r/multi/test.format", 1, "it_worked_ssl", ssl => 1 ); # 6 test
+handle_request( "/r/multi (user)", "/r/multi/test.format", 1, "it_worked_user", username => 'test' ); # 6 test
+# 206
+
+DW::Routing::Apache2->register_regex( qr !^/r/all(/.+)$!, \®ex_handler, app => 1, user => 1, ssl => 1, format => 'json', args => ["/test", "it_worked_all"] );
+
+$expected_format = 'json';
+handle_request( "/r/all (app)" , "/r/all/test", 1, "it_worked_all" ); # 6 test
+handle_request( "/r/all (ssl)" , "/r/all/test", 1, "it_worked_all", ssl => 1 ); # 6 test
+handle_request( "/r/all (user)", "/r/all/test", 1, "it_worked_all", username => 'test' ); # 6 test
+# 224
+
+$expected_format = 'format';
+handle_request( "/r/all (app)" , "/r/all/test.format", 1, "it_worked_all" ); # 6 tests
+handle_request( "/r/all (ssl)" , "/r/all/test.format", 1, "it_worked_all", ssl => 1 ); # 6 test
+handle_request( "/r/all (user)", "/r/all/test.format", 1, "it_worked_all", username => 'test' ); # 6 test
+# 242
+
+DW::Routing::Apache2->register_string( "/test/app_implicit", \&handler, args => "it_worked_app" );
+
+$expected_format = 'html';
+handle_request( "/test appapp_implicit (app)" , "/test/app_implicit", 1, "it_worked_app" ); # 6 tests
+handle_request( "/test appapp_implicit (ssl)" , "/test/app_implicit", 0, "it_worked_app", ssl => 1 ); # 1 test
+handle_request( "/test appapp_implicit (user)", "/test/app_implicit", 0, "it_worked_app", username => 'test' ); # 1 test
+# 250
+
+$expected_format = 'format';
+handle_request( "/test appapp_implicit (app)" , "/test/app_implicit.format", 1, "it_worked_app" ); # 6 tests
+handle_request( "/test appapp_implicit (ssl)" , "/test/app_implicit.format", 0, "it_worked_app", ssl => 1 ); # 1 test
+handle_request( "/test appapp_implicit (user)", "/test/app_implicit.format", 0, "it_worked_app", username => 'test' ); # 1 test
+# 258
+
+DW::Routing::Apache2->register_regex( qr !^/r/app_implicit(/.+)$!, \®ex_handler, args => ["/test", "it_worked_app"] );
+
+$expected_format = 'html';
+handle_request( "/r/app_implicit (app)" , "/r/app_implicit/test", 1, "it_worked_app" ); # 6 tests
+handle_request( "/r/app_implicit (ssl)" , "/r/app_implicit/test", 0, "it_worked_app", ssl => 1 ); # 1 test
+handle_request( "/r/app_implicit (user)", "/r/app_implicit/test", 0, "it_worked_app", username => 'test' ); # 1 test
+# 266
+
+$expected_format = 'format';
+handle_request( "/r/app_implicit (app)" , "/r/app_implicit/test.format", 1, "it_worked_app" ); # 6 tests
+handle_request( "/r/app_implicit (ssl)" , "/r/app_implicit/test.format", 0, "it_worked_app", ssl => 1 ); # 1 test
+handle_request( "/r/app_implicit (user)", "/r/app_implicit/test.format", 0, "it_worked_app", username => 'test' ); # 1 test
+# 274
+
+sub handle_request {
+ my ( $name, $uri, $valid, $expected, %opts ) = @_;
+ my $r = DummyRequest->new( $uri );
+ $result = undef;
+ $__name = $name;
+
+ my $ret = DW::Routing::Apache2->call( $r, %opts );
+ if ( ! $valid ) {
+ is( $ret, undef, "$name: wrong return" );
+ return 1;
+ }
+ is( $ret, OK, "$name: wrong return" );
+ if ( ! defined $ret || $ret != OK ) {
+ return 0;
+ }
+ is ( $r->{handler}, 'perl-script', "$name: wrong handler type" );
+ is ( ref $r->{perl_handler}, 'CODE', "$name: handler missing/incorrect" );
+ if ( ref $r->{perl_handler} ne 'CODE' ) {
+ return;
+ }
+ $ret = $r->{perl_handler}->($r);
+ is( $ret, OK, "$name: wrong return (from perl handler)" );
+ if ( $ret != OK ) {
+ return 0;
+ }
+ is ( $result, $expected, "$name: handler set wrong value.");
+}
+
+sub handler {
+ $result = $_[0]->args;
+ is ( $_[0]->format, $expected_format, "$__name: format wrong!" );
+ return OK;
+}
+
+sub regex_handler {
+ $result = $_[0]->args->[1];
+ is ( $_[0]->format, $expected_format, "$__name: format wrong!" );
+ is( $_[0]->subpatterns->[0], $_[0]->args->[0], "$__name: capture wrong!" );
+ return OK;
+}
+
+# This is sorta hackish, but we need something that pretends to be
+# an Apache2 request enough to at least allow DW::Routing::Apache2 to work
+package DummyRequest;
+
+sub new {
+ my ($class, $uri) = @_;
+
+ return bless({ uri => $uri, handler => '', perl_handler => undef, pnotes => {}, notes => {} }, $class);
+}
+
+sub uri { return $_[0]->{uri}; }
+sub handler { $_[0]->{handler} = $_[1]; }
+sub pnotes { return $_[0]->{pnotes}; }
+sub notes { return $_[0]->{notes}; }
+sub content_type { }
+sub status { }
+sub push_handlers {
+ $_[0]->{perl_handler} = $_[2] if $_[1] eq 'PerlResponseHandler';
+}
--------------------------------------------------------------------------------