--- /dev/null
+#!/usr/bin/perl
+
+use FindBin;
+use lib $FindBin::Bin.'/code';
+use Web::Simple 'Bloggery';
+
+package Bloggery::PostList;
+
+use File::stat;
+
+sub from_dir {
+ my ($class, $dir) = @_;
+ bless ({ dir => $dir }, $class);
+}
+
+sub all {
+ my ($self) = @_;
+ map { Bloggery::Post->from_file($_) }
+ sort { stat($a)->mtime <=> stat($b)->mtime }
+ grep { !/\.summary\.html$/ }
+ glob($self->{dir}.'/*.html');
+}
+
+sub post {
+ my ($self, $name) = @_;
+ my $file = $self->{dir}."/${name}.html";
+ return unless $file && -f $file;
+ return Bloggery::Post->from_file($file);
+}
+
+package Bloggery::Post;
+
+sub from_file {
+ my ($class, $file) = @_;
+ bless({ file => $file }, $class);
+}
+
+sub name {
+ my $name = shift->{file};
+ $name =~ s/.*\///;
+ $name =~ s/\.html$//;
+ $name;
+}
+
+sub title {
+ my $title = shift->name;
+ $title =~ s/-/ /g;
+ $title;
+}
+
+sub html {
+ \do { local (@ARGV, $/) = shift->{file}; <> };
+}
+
+sub summary_html {
+ my $file = shift->{file};
+ $file =~ s/\.html$/.summary.html/;
+ return \'<p>No summary</p>' unless -f $file;
+ \do { local (@ARGV, $/) = $file; <> };
+}
+
+package Bloggery;
+
+default_config(
+ title => 'Bloggery',
+ posts_dir => $FindBin::Bin.'/posts',
+);
+
+sub post_list {
+ my ($self) = @_;
+ $self->{post_list}
+ ||= Bloggery::PostList->from_dir(
+ $self->config->{posts_dir}
+ );
+}
+
+sub post {
+ my ($self, $post) = @_;
+ $self->post_list->post($post);
+}
+
+dispatch [
+ sub (.html) {
+ filter_response { $self->render_html($_[1]) },
+ },
+ sub (GET + /) {
+ $self->redispatch('index.html')
+ },
+ sub (GET + /index) {
+ $self->post_list
+ },
+ sub (GET + /*) {
+ $self->post($_[1]);
+ },
+ sub (GET) {
+ [ 404, [ 'Content-type', 'text/plain' ], [ 'Not found' ] ]
+ },
+ sub {
+ [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ]
+ },
+];
+
+sub render_html {
+ my ($self, $data) = @_;
+ use HTML::Tags;
+ return $data if ref($data) eq 'ARRAY';
+ return [
+ 200,
+ [ 'Content-type', 'text/html' ],
+ [
+ HTML::Tags::to_html_string(
+ <html>,
+ <head>,
+ <title>, $self->title_for($data), </title>,
+ </head>,
+ <body>,
+ <h1>, $self->title_for($data), </h1>,
+ <div id="main">,
+ $self->main_html_for($data),
+ </div>,
+ </body>,
+ </html>
+ )
+ ]
+ ];
+}
+
+sub title_for {
+ my ($self, $data) = @_;
+ if ($data->isa('Bloggery::Post')) {
+ return $data->title;
+ }
+ return $self->config->{title};
+}
+
+sub main_html_for {
+ my ($self, $data) = @_;
+ use HTML::Tags;
+ if ($data->isa('Bloggery::Post')) {
+ $data->html
+ } elsif ($data->isa('Bloggery::PostList')) {
+ <ul>,
+ (map {
+ my $path = '/'.$_->name.'.html';
+ <li>,
+ <h4>, <a href="$path">, $_->title, </a>, </h4>,
+ <span class="summary">, $_->summary_html, </span>,
+ </li>;
+ } $data->all),
+ </ul>;
+ } else {
+ <h2>, "Don't know how to render $data", </h2>;
+ }
+}
+
+Bloggery->run_if_script;
--- /dev/null
+<p>This is also a post!</p>
--- /dev/null
+<p>This is a post!</p>
--- /dev/null
+<p>Excitement!</p>
--- /dev/null
+package Web::Simple;
+
+use strict;
+use warnings FATAL => 'all';
+
+sub import {
+ strict->import;
+ warnings->import(FATAL => 'all');
+ warnings->unimport('syntax');
+ warnings->import(FATAL => qw(
+ ambiguous bareword digit parenthesis precedence printf
+ prototype qw reserved semicolon
+ ));
+ my ($class, $app_package) = @_;
+ $class->_export_into($app_package);
+}
+
+sub _export_into {
+ my ($class, $app_package) = @_;
+ {
+ no strict 'refs';
+ *{"${app_package}::dispatch"} = sub {
+ $app_package->_setup_dispatchables(@_);
+ };
+ *{"${app_package}::filter_response"} = sub (&) {
+ $app_package->_construct_response_filter($_[0]);
+ };
+ *{"${app_package}::default_config"} = sub {
+ my @defaults = @_;
+ *{"${app_package}::_default_config"} = sub { @defaults };
+ };
+ *{"${app_package}::self"} = \${"${app_package}::self"};
+ require Web::Simple::Application;
+ unshift(@{"${app_package}::ISA"}, 'Web::Simple::Application');
+ }
+}
+
+1;
--- /dev/null
+package Web::Simple::Application;
+
+use strict;
+use warnings FATAL => 'all';
+
+sub new {
+ my ($class, $data) = @_;
+ my $config = { $class->_default_config, %{($data||{})->{config}||{}} };
+ bless({ config => $config }, $class);
+}
+
+sub config {
+ shift->{config};
+}
+
+sub _construct_response_filter {
+ bless($_[1], 'Web::Simple::ResponseFilter');
+}
+
+sub _is_response_filter {
+ # simple blessed() hack
+ "$_[1]" =~ /\w+=[A-Z]/
+ and $_[1]->isa('Web::Simple::ResponseFilter');
+}
+
+sub _dispatch_parser {
+ require Web::Simple::DispatchParser;
+ return Web::Simple::DispatchParser->new;
+}
+
+sub _setup_dispatchables {
+ my ($class, $dispatch_subs) = @_;
+ my $parser = $class->_dispatch_parser;
+ my @dispatchables;
+ foreach my $dispatch_sub (@$dispatch_subs) {
+ my $proto = prototype $dispatch_sub;
+ my $matcher = (
+ defined($proto)
+ ? $parser->parse_dispatch_specification($proto)
+ : sub { ({}) }
+ );
+ push @dispatchables, [ $matcher, $dispatch_sub ];
+ }
+ {
+ no strict 'refs';
+ *{"${class}::_dispatchables"} = sub { @dispatchables };
+ }
+}
+
+sub handle_request {
+ my ($self, $env) = @_;
+ $self->_run_dispatch_for($env, [ $self->_dispatchables ]);
+}
+
+sub _run_dispatch_for {
+ my ($self, $env, $dispatchables) = @_;
+ my @disp = @$dispatchables;
+ while (my $disp = shift @disp) {
+ my ($match, $run) = @{$disp};
+ if (my ($env_delta, @args) = $match->($env)) {
+ my $new_env = { %$env, %$env_delta };
+ if (my ($result) = $self->_run_with_self($run, @args)) {
+ if ($self->_is_response_filter($result)) {
+ return $self->_run_with_self(
+ $result,
+ $self->_run_dispatch_for($new_env, \@disp)
+ );
+ }
+ return $result;
+ }
+ }
+ }
+ return [
+ 500, [ 'Content-type', 'text/plain' ],
+ 'The management apologises but we have no idea how to handle that'
+ ];
+}
+
+sub _run_with_self {
+ my ($self, $run, @args) = @_;
+ my $class = ref($self);
+ no strict 'refs';
+ local *{"${class}::self"} = \$self;
+ $self->$run(@args);
+}
+
+sub run_if_script {
+ return 1 if caller(1); # 1 so we can be the last thing in the file
+ my $class = shift;
+ my $self = $class->new;
+ $self->run(@_);
+}
+
+sub run {
+ my $self = shift;
+ unless ($ENV{GATEWAY_INTERFACE}) {
+ die "mst is an idiot and didn't fix non-CGI yet";
+ }
+ require Web::Simple::HackedPlack;
+ Plack::Server::CGI->run(sub { $self->handle_request(@_) });
+}
+
+1;
--- /dev/null
+# This is Plack::Server::CGI, copied almost verbatim.
+# Except I inlined the bits of Plack::Util it needed.
+# Because it loads a number of modules that I didn't.
+# miyagawa, I'm sorry to butcher your code like this.
+# The apology would have been in the form of a haiku.
+# But I needed more syllables than that would permit.
+# So I thought perhaps I'd make it bricktext instead.
+# -- love, mst
+
+package Plack::Server::CGI;
+use strict;
+use warnings;
+use IO::Handle;
+BEGIN {
+
+ package Plack::Util;
+
+ sub foreach {
+ my($body, $cb) = @_;
+
+ if (ref $body eq 'ARRAY') {
+ for my $line (@$body) {
+ $cb->($line) if length $line;
+ }
+ } else {
+ local $/ = \4096 unless ref $/;
+ while (defined(my $line = $body->getline)) {
+ $cb->($line) if length $line;
+ }
+ $body->close;
+ }
+ }
+ sub TRUE() { 1==1 }
+ sub FALSE() { !TRUE }
+}
+
+sub new { bless {}, shift }
+
+sub run {
+ my ($self, $app) = @_;
+ my %env;
+ while (my ($k, $v) = each %ENV) {
+ next unless $k =~ qr/^(?:REQUEST_METHOD|SCRIPT_NAME|PATH_INFO|QUERY_STRING|SERVER_NAME|SERVER_PORT|SERVER_PROTOCOL|CONTENT_LENGTH|CONTENT_TYPE|REMOTE_ADDR|REQUEST_URI)$|^HTTP_/;
+ $env{$k} = $v;
+ }
+ $env{'HTTP_COOKIE'} ||= $ENV{COOKIE};
+ $env{'psgi.version'} = [ 1, 0 ];
+ $env{'psgi.url_scheme'} = ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http';
+ $env{'psgi.input'} = *STDIN;
+ $env{'psgi.errors'} = *STDERR;
+ $env{'psgi.multithread'} = Plack::Util::FALSE;
+ $env{'psgi.multiprocess'} = Plack::Util::TRUE;
+ $env{'psgi.run_once'} = Plack::Util::TRUE;
+ my $res = $app->(\%env);
+ print "Status: $res->[0]\n";
+ my $headers = $res->[1];
+ while (my ($k, $v) = splice(@$headers, 0, 2)) {
+ print "$k: $v\n";
+ }
+ print "\n";
+
+ my $body = $res->[2];
+ my $cb = sub { print STDOUT $_[0] };
+
+ Plack::Util::foreach($body, $cb);
+}
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ ## in your .cgi
+ #!/usr/bin/perl
+ use Plack::Server::CGI;
+
+ # or Plack::Util::load_psgi("/path/to/app.psgi");
+ my $app = sub {
+ my $env = shift;
+ return [
+ 200,
+ [ 'Content-Type' => 'text/plain', 'Content-Length' => 13 ],
+ 'Hello, world!',
+ ];
+ };
+
+ Plack::Server::CGI->new->run($app);
+
+=head1 SEE ALSO
+
+L<Plack::Server::Base>
+
+=cut
+
+
projects / catagits/Web-Simple.git / commitdiff