Changeset 46
- Timestamp:
- 07/06/06 09:59:02 (2 years ago)
- Files:
-
- trunk/lib/PrlMnks/Plugin.pm (modified) (7 diffs)
- trunk/lib/PrlMnks/Plugin/Default.pm (modified) (1 diff)
- trunk/lib/PrlMnks/Plugin/XML.pm (modified) (1 diff)
- trunk/lib/PrlMnks/WWW.pm (modified) (4 diffs)
- trunk/lib/PrlMnks/WWW/Status.pm (deleted)
- trunk/t/plugin/xml/xml.t (modified) (2 diffs)
- trunk/templates/index.mason (added)
Legend:
- Unmodified
- Added
- Removed
- Modified
- Copied
- Moved
trunk/lib/PrlMnks/Plugin.pm
r45 r46 5 5 use base 'PrlMnks'; 6 6 7 use CGI; 7 8 use Data::Dumper; 8 use CGI;9 9 use HTTP::Response; 10 10 use Perl6::Slurp; 11 use PrlMnks::Template; 12 use Carp qw(cluck); 13 14 =head2 vars 15 16 my $vars_hashref = $self->vars; 17 18 When a template is called C<vars> is passed in as the data that needs to be 19 processed. This method provides access to the hashref that the data is stored 20 in. The first time it is called a new empty hashref is created. 21 22 =cut 11 23 12 24 sub vars { … … 14 26 return $self->{_vars} ||= {}; 15 27 } 28 29 =head2 req 30 31 my $req = $self->req; 32 33 Provides access to the request object, which is the CGI like object that was set in the main handler. 34 35 =cut 16 36 17 37 sub req { … … 25 45 } 26 46 47 =head2 url 48 49 my $absolute_url = $self->url; 50 51 Returns the absolute url of the request. We should never need to care about 52 the domain or port so it is ommitted. If the request was 53 C<http://prlmnks.org/foo/bar> then this will return C</foo/bar>. 54 55 =cut 56 57 sub url { 58 my $self = shift; 59 return $self->req->url( -absolute => 1 ); 60 } 61 62 =head2 res 63 64 my $http_response_obj = $self->res; 65 66 Returns the HTTP::Response object. The first time it is called a new object is created with status code 500 - so if nothing else is done a server error is reported to the client. 67 68 =cut 69 27 70 sub res { 28 71 my $self = shift; 29 72 return $self->{_res} ||= HTTP::Response->new(500); 30 73 } 74 75 =head2 error_404 76 77 return $self->error_404; 78 79 Sets up the response to be a 404 error - page not found. 80 81 =cut 31 82 32 83 sub error_404 { … … 37 88 } 38 89 90 =head2 send_file 91 92 return $self->send_file( '/absolute/path/to/file.xml' ); 93 94 Takes the given file and sends it to the client. It determines the mime type 95 from the file's suffix, or uses 'text/html' if there is no suffix. 96 97 If the file does not exist then a 404 error is produced instead. 98 99 =cut 100 101 my %SUFFIX_TO_MIME_TYPE = ( 102 '' => 'text/html', 103 'txt' => 'text/plain', 104 'xml' => 'text/xml', 105 'ico' => 'image/x-icon', 106 'png' => 'image/png', 107 'jpg' => 'image/jpeg', 108 'gif' => 'image/gif', 109 'html' => 'text/html', 110 'json' => 'application/json', 111 ); 112 39 113 sub send_file { 40 114 my $self = shift; … … 43 117 return $self->error_404 unless -e $file; 44 118 45 # FIXME - set content type based on file suffix 119 # content type based on file suffix 120 $file =~ m{ \. ([^\./]+) \z }xms; 121 my $type = $SUFFIX_TO_MIME_TYPE{ $1 || '' }; 122 warn "Cannot work out suffix for '$file'" unless $type; 123 46 124 $self->res->code(200); 47 $self->res->header( 'Content-Type' => 'text/plain', );125 $self->res->header( 'Content-Type' => $type, ); 48 126 $self->res->content( scalar slurp $file ); 49 127 … … 51 129 } 52 130 131 =head2 send_template 132 133 return $self->send_template( '/template/file.mason' ); 134 135 Processes the template and returns the result. The data for the template is 136 taken from C<$self->vars>; 137 138 =cut 139 53 140 sub send_template { 54 my $self = shift;141 my $self = shift; 55 142 my $template_file = shift; 56 143 … … 61 148 62 149 $self->res->code(200); 63 $self->res->content($content); 150 $self->res->header( 'Content-Type' => 'text/html', ); 151 $self->res->content($$content); 64 152 65 153 return 1; trunk/lib/PrlMnks/Plugin/Default.pm
r45 r46 8 8 9 9 sub process { 10 1; 10 my $self = shift; 11 my $url = $self->url; 12 13 # If this is the homepage then use the homepage template. 14 return $self->send_template('/index.mason') if $url eq '/'; 11 15 12 # my $self = shift; 13 # 14 # # Get the requested url. 15 # my $url = $self->req->url( -absolute => 1 ); 16 # 17 # warn $url; 18 # 19 # # Is this the homepage? 20 # return $self->send_template('/index.mason') 21 # if $url eq '/'; 22 # 23 # my $full_path = $self->htdocs($url); 24 # return $self->send_file($full_path); 16 # Assume it is a file and send it. 17 return $self->send_file( $self->htdocs($url) ); 25 18 } 26 19 trunk/lib/PrlMnks/Plugin/XML.pm
r45 r46 5 5 use base "PrlMnks::Plugin"; 6 6 7 sub start_of_url { '/xml ' };7 sub start_of_url { '/xml/' } 8 8 9 sub process { die } 9 =head2 process 10 11 Extract the id from the url, turn it into a poth to the file and then send 12 that file. 13 14 =cut 15 16 sub process { 17 my $self = shift; 18 my $url = $self->url; 19 20 # get the id from the url. 21 $url =~ m{ (\d+) }xms; 22 my $id = $1; 23 24 # Send the file. 25 my $file = $self->path_to_file( 'xml', $id ); 26 return $self->send_file($file); 27 } 10 28 11 29 1; trunk/lib/PrlMnks/WWW.pm
r45 r46 15 15 PrlMnks->plugins; 16 16 17 warn Dumper \%URL_TO_PLUGIN; 17 # warn Dumper \%URL_TO_PLUGIN; 18 19 =head2 plugin_for_url 20 21 my $plugin_class = PrlMnks::WWW->plugin_for_url( '/absolute/url' ); 22 23 Given an absolute url this returns the plugin class that process it. If no 24 class is found then the default class is returned. If that is not found then 25 the method dies. 26 27 =cut 18 28 19 29 sub plugin_for_url { … … 21 31 my $url = shift; 22 32 23 $url =~ m{ \A ( / [^/]+ ) }xms;33 $url =~ m{ \A ( / [^/]+ /? ) }xms; 24 34 my $start = $1 || ''; 25 35 … … 29 39 } 30 40 41 =head2 cgi_handler 42 43 PrlMnks::WWW->cgi_handler; 44 45 This is the entry point for for plain CGI scripts. It sets up the environment 46 as appropriate and then calls C<main_handler>. 47 48 =cut 49 31 50 sub cgi_handler { 32 51 my $class = shift; … … 34 53 } 35 54 55 =head2 main_handler 56 57 PrlMnks::WWW->main_handler( $cgi_object ); 58 59 This is the main handler that the other handlers call. It is passed the CGI 60 like object that is used to find the url etc. It uses the url to find the 61 correct plugin and then runs it. It then returns the response to the client. 62 63 =cut 64 36 65 sub main_handler { 37 66 my $class = shift; 38 67 my $cgi = shift; 68 my $url = $cgi->url( -absolute => 1 ); 39 69 40 my $plugin_class = $class->plugin_for_url( $cgi->url);70 my $plugin_class = $class->plugin_for_url($url); 41 71 my $plugin = $plugin_class->new; 42 72 $plugin->_set_req($cgi); 43 73 44 $plugin->process || die; 74 # warn "Using plugin '$plugin_class' for '$url'"; 75 76 $plugin->process || die "Could not process '$plugin'"; 45 77 46 78 # Bit of a dirty hack. trunk/t/plugin/xml/xml.t
r44 r46 3 3 4 4 use Test::More 'no_plan'; 5 6 use Perl6::Slurp; 5 7 6 8 BEGIN { require 't/setup_testing_environment.pl'; } … … 14 16 is $p, "PrlMnks::Plugin::XML", "got correct plugin for url"; 15 17 16 # check that the plugin serves files correctly. Mock the PrlMnks::Plugin code 17 # to catch the calls to return data. 18 # require 't/plugin/mock_www.pl'; 18 my $mech = test_mech(); 19 20 # Try a file that does not exist - should get 404 21 $mech->get( '/xml/11223344556677.xml', "get non-existant file" ); 22 is $mech->status, 404, "Got a 404"; 23 24 # Try a file that does exist and check that the contents are correct. 25 my @xml_ids = ( 10, 11, 508424 ); 26 27 foreach my $id (@xml_ids) { 28 my $url = "/xml/$id.xml"; 29 my $file = PrlMnks->path_to_file( 'xml', $id ); 30 31 $mech->get_ok( $url, "Get $url" ); 32 33 my $expected = scalar slurp $file; 34 is $mech->content, $expected, "content matches '$file'"; 35 is $mech->ct, 'text/xml', "Got correct content type"; 36 }
