--- /dev/null
+package HTML::Zoom;
+
+use strict;
+use warnings FATAL => 'all';
+use Carp qw(confess);
+
+use HTML::Zoom::EventFilter;
+use HTML::Zoom::SelectorParser;
+use HTML::Zoom::ActionBuilder;
+use HTML::Zoom::Parser::BuiltIn;
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ bless({}, $class);
+}
+
+sub _clone_with {
+ my ($self, %clone) = @_;
+ bless({ %$self, %clone }, ref($self));
+}
+
+sub from_string {
+ my $new = shift->new;
+ $new->{source_html} = shift;
+ $new;
+}
+
+sub from_fh {
+ my $new = shift->new;
+ my $fh = $_[0];
+ $new->{source_html} = do { local $/; <$fh> || die "from_fh: $!" };
+ $new;
+}
+
+sub with_selectors {
+ my $self = shift;
+ my $pairs = [];
+ while (my @spec = splice(@_, 0, 2)) {
+ push(
+ @$pairs,
+ HTML::Zoom::EventFilter->build_selector_pair(@spec)
+ );
+ }
+ $self->_clone_with(
+ _selector_handler => HTML::Zoom::EventFilter->selector_handler($pairs)
+ );
+}
+
+sub render_to {
+ my ($self, $out) = @_;
+ $self->_clone_with(
+ _emitter => HTML::Zoom::EventFilter->standard_emitter($out)
+ )->render;
+}
+
+sub render {
+ my ($self) = @_;
+ my $s_h = $self->{_selector_handler};
+ $s_h->set_next($self->{_emitter});
+ HTML::Zoom::Parser::BuiltIn::_hacky_tag_parser(
+ $self->{source_html}, sub { $s_h->call(@_) }
+ );
+ $self;
+}
+
+=head1 NAME
+
+HTML::Zoom - Lightweight CSS selector based HTML templating
+
+=head1 SYNOPSIS
+
+ use HTML::Zoom;
+
+ my $html = <<HTML;
+ <html>
+ <head>
+ <title>Hello people</title>
+ </head>
+ <body>
+ <h1 id="greeting">Placeholder</h1>
+ <div id="list">
+ <span>
+ <p>Name: <span class="name">Bob</span></p>
+ <p>Age: <span class="age">23</span></p>
+ </span>
+ <hr class="between" />
+ </div>
+ </body>
+ </html>
+ HTML
+
+ HTML::Zoom->from_string($html)
+ ->add_selectors(
+ 'title, #greeting' => 'Hello world & dog!',
+ '#list' => [
+ { '.name' => 'Matt',
+ '.age' => 26
+ },
+ { '.name' => 'Mark',
+ '.age' => '0x29'
+ },
+ { '.name' => 'Epitaph',
+ '.age' => '<redacted>'
+ },
+ 'span:odd p' => { -add_class => 'alt' },
+ ]
+ )
+ ->stream_to(\*STDOUT)
+ ->render;
+
+will print -
+
+ <html>
+ <head>
+ <title>Hello world & dog!</title>
+ </head>
+ <body>
+ <h1 id="greeting">Hello world & dog!</h1>
+ <div id="list">
+ <span>
+ <p>Name: <span class="name">Matt</span></p>
+ <p>Age: <span class="age">26</span></p>
+ <span>
+ <hr class="between" />
+ <span>
+ <p class="alt">Name: <span class="name">Mark</span></p>
+ <p class="alt">Age: <span class="age">0x29</span></p>
+ <span>
+ <hr class="between" />
+ <span>
+ <p>Name: <span class="name">Epitaph</span></p>
+ <p>Age: <span class="age"><redacted></span></p>
+ <span>
+ </div>
+ </body>
+ </html>
+
+Using a layout -
+
+ <html>
+ <head>
+ <title>default title</title>
+ </head>
+ <body>
+ <img src="/logo.jpg" />
+ </body>
+ </html>
+
+=head1 SELECTORS
+
+http://docs.jquery.com/Selectors
+
+=cut
+
+1;
--- /dev/null
+package HTML::Zoom::ActionBuilder;
+
+use strict;
+use warnings FATAL => 'all';
+
+use HTML::Zoom::Parser::BuiltIn;
+use HTML::Zoom::EventFilter;
+use Storable ();
+use Carp qw(confess);
+
+sub build {
+ my ($tb, $name, @args) = @_;
+ confess "Don't know how to build ${name} in ${tb}"
+ unless $tb->can("build_${name}");
+
+ return $tb->${\"build_${name}"}(@args);
+}
+
+sub build_add_attribute {
+ my ($tb, $name, $value) = @_;
+ sub {
+ my ($self, $evt) = @_;
+ delete @{$evt}{qw(raw raw_attrs)};
+ if (defined $evt->{attrs}{$name}) {
+ $evt->{attrs}{$name} .= ' '.$value;
+ } else {
+ $evt->{attrs}{$name} = $value;
+ }
+ };
+}
+
+sub build_set_attribute {
+ my ($tb, $name, $value) = @_;
+ sub {
+ my ($self, $evt) = @_;
+ delete @{$evt}{qw(raw raw_attrs)};
+ $evt->{attrs}{$name} = $value;
+ };
+}
+
+sub build_add_class { shift->build_add_attribute('class' => @_) }
+sub build_set_class { shift->build_set_attribute('class' => @_) }
+
+sub build_replace_content {
+ my ($tb, $text) = @_;
+ my $raw = HTML::Zoom::Parser::BuiltIn::_simple_escape($text);
+ $tb->build_replace_content_raw($raw);
+}
+
+sub build_replace_content_raw {
+ my ($tb, $raw) = @_;
+ sub {
+ my ($self, $evt) = @_;
+ my $in_place_close = $evt->{is_in_place_close};
+ if ($in_place_close) {
+ delete $evt->{raw};
+ $evt->{is_in_place_close} = 0;
+ }
+ $self->until_close_do_last(
+ undef,
+ sub {
+ delete $_[1]->{raw} if $in_place_close;
+ $_[0]->next({ type => 'TEXT', raw => $raw })
+ }
+ )
+ };
+}
+
+sub build_repeat {
+ my ($tb, $args) = @_;
+ my $data = $args->{data};
+ my $do_repeat = sub {
+ my ($self, $to_repeat) = @_;
+ my $stole_last;
+ if ($to_repeat->[-1]->{type} eq 'TEXT') {
+ if ($to_repeat->[-1]->{raw} =~ s/(\s+)$//) {
+ $stole_last = $1;
+ }
+ }
+ foreach my $d (@$data) {
+ my @pairs = map {
+ HTML::Zoom::EventFilter->build_selector_pair($_, $d->{$_})
+ } sort keys %$d;
+ my $sel = HTML::Zoom::EventFilter->selector_handler(\@pairs);
+ $sel->set_next($self->get_next);
+ $sel->call($_) for @$to_repeat;
+ }
+ if (defined $stole_last) {
+ $self->next({ type => 'TEXT', raw => $stole_last });
+ }
+ };
+ sub {
+ my ($self, $evt) = @_;
+ return if $evt->{is_in_place_close}; # no content to repeat
+ my @repeat;
+ $self->until_close_do_last(
+ sub { push(@repeat, $_[1]) },
+ sub { $_[0]->$do_repeat(\@repeat) },
+ );
+ };
+}
+
+1;
--- /dev/null
+package HTML::Zoom::EventFilter;
+
+use strict;
+use warnings FATAL => 'all';
+use Carp qw(confess);
+
+sub from_code {
+ my ($class, $code) = @_;
+ confess "from_code is a class method" if ref $class;
+ bless({ code => $code }, $class);
+}
+
+sub next {
+ my $n = shift->{next} or return;
+ $n->${\$n->{code}}(@_);
+}
+
+sub call {
+ $_[0]->{code}->(@_);
+}
+
+sub set_next {
+ $_[0]->{next} = $_[1];
+ $_[0];
+}
+
+sub get_next { $_[0]->{next} }
+
+sub push_next {
+ my ($self, $code) = @_;
+ $self->{next} = bless(
+ { code => $code, next => $self->{next} }
+ );
+}
+
+sub push_last {
+ my ($self, $code) = @_;
+ my $target = $self;
+ while ($target->{next} && $target->{next}{next}) {
+ $target = $target->{next}
+ }
+ $target->push_next($code);
+}
+
+sub pop {
+ my ($self, $to) = @_;
+ die "$self doesn't have a next (->pop($to))"
+ unless $self->{next};
+ my $target = $self;
+ until ($target->{next} eq $to) {
+ $target = $target->{next} || die "Didn't find $to as next of $self";
+ }
+ $target->{next} = $to->{next};
+ $_[0];
+}
+
+sub until_close_do_next { shift->until_close_do(next => @_) }
+sub until_close_do_last { shift->until_close_do(last => @_) }
+
+sub until_close_do {
+ my ($self, $direction, $do, $before_close, $after_close) = @_;
+ my %depth = (OPEN => 1, CLOSE => -1, TEXT => 0);
+ my $count = 1;
+ my $outer = $self;
+ $self->${\"push_${direction}"}(
+ sub {
+ my ($self, $evt) = @_;
+ $count += $depth{$evt->{type}};
+ if ($count) {
+ $do->(@_, $count) if $do;
+ return;
+ }
+ $before_close->($self, $evt) if $before_close;
+ $outer->pop($self)->next($evt);
+ $after_close->($outer, $evt) if $after_close;
+ }
+ )
+}
+
+sub standard_emitter {
+ my ($class, $out) = @_;
+ confess "standard_emitter is a class method" if ref $class;
+ $class->from_code(sub {
+ my ($self, $evt) = @_;
+ return $out->print($evt->{raw}) if defined $evt->{raw};
+ if ($evt->{type} eq 'OPEN') {
+ $out->print(
+ '<'
+ .$evt->{name}
+ .(defined $evt->{raw_attrs}
+ ? $evt->{raw_attrs}
+ : do {
+ my @names = @{$evt->{attr_names}};
+ @names
+ ? join(' ', '', map qq{${_}="${\$evt->{attrs}{$_}}"}, @names)
+ : ''
+ }
+ )
+ .($evt->{is_in_place_close} ? ' /' : '')
+ .'>'
+ );
+ } elsif ($evt->{type} eq 'CLOSE') {
+ $out->print('</'.$evt->{name}.'>');
+ } else {
+ confess "No raw value in event and no special handling for type ".$evt->{type};
+ }
+ });
+}
+
+sub selector_handler {
+ my ($class, $pairs) = @_;
+ confess "selector_handler is a class method" if ref $class;
+ $class->from_code(sub {
+ my ($self, $evt) = @_;
+ my $next = $self->get_next;
+ if ($evt->{type} eq 'OPEN') {
+ foreach my $p (@$pairs) {
+ $p->[1]->($self, $evt) if $p->[0]->($evt);
+ }
+ }
+ $next->call($evt);
+ });
+}
+
+sub build_selector_pair {
+ my ($class, $sel_spec, $action_spec) = @_;
+ my $selector = HTML::Zoom::SelectorParser->parse_selector($sel_spec);
+ my $action;
+ if (ref($action_spec) eq 'HASH') {
+ confess "hash spec must be single key"
+ unless keys(%$action_spec) == 1;
+ my ($key) = keys (%$action_spec);
+ $key =~ s/^-//;
+ $action = HTML::Zoom::ActionBuilder->build($key, values %$action_spec);
+ }
+ [ $selector, $action ];
+}
+
+1;
--- /dev/null
+package HTML::Zoom::Parser::BuiltIn;
+
+sub _hacky_tag_parser {
+ my ($text, $handler) = @_;
+ while (
+ $text =~ m{
+ (
+ (?:[^<]*) < (?:
+ ( / )? ( [^/!<>\s"'=]+ )
+ ( (?:"[^"]*"|'[^']*'|[^"'<>])+? )?
+ |
+ (!-- .*? -- | ![^\-] .*? )
+ ) (\s*/\s*)? >
+ )
+ ([^<]*)
+ }sxg
+ ) {
+ my ($whole, $is_close, $tag_name, $attributes, $is_comment,
+ $in_place_close, $content)
+ = ($1, $2, $3, $4, $5, $6, $7, $8);
+ next if defined $is_comment;
+ $tag_name =~ tr/A-Z/a-z/;
+ if ($is_close) {
+ $handler->({ type => 'CLOSE', name => $tag_name, raw => $whole });
+ } else {
+ $attributes = '' if $attributes =~ /^ +$/;
+ $handler->({
+ type => 'OPEN',
+ name => $tag_name,
+ is_in_place_close => $in_place_close,
+ _hacky_attribute_parser($attributes),
+ raw_attrs => $attributes||'',
+ raw => $whole,
+ });
+ if ($in_place_close) {
+ $handler->({
+ type => 'CLOSE', name => $tag_name, raw => '',
+ is_in_place_close => 1
+ });
+ }
+ }
+ if (length $content) {
+ $handler->({ type => 'TEXT', raw => $content });
+ }
+ }
+}
+
+sub _hacky_attribute_parser {
+ my ($attr_text) = @_;
+ my (%attrs, @attr_names);
+ while (
+ $attr_text =~ m{
+ ([^\s\=\"\']+)(\s*=\s*(?:(")(.*?)"|(')(.*?)'|([^'"\s=]+)['"]*))?
+ }sgx
+ ) {
+ my $key = $1;
+ my $test = $2;
+ my $val = ( $3 ? $4 : ( $5 ? $6 : $7 ));
+ my $lckey = lc($key);
+ if ($test) {
+ $attrs{$lckey} = _simple_unescape($val);
+ } else {
+ $attrs{$lckey} = $lckey;
+ }
+ push(@attr_names, $lckey);
+ }
+ (attrs => \%attrs, attr_names => \@attr_names);
+}
+
+sub _simple_unescape {
+ my $str = shift;
+ $str =~ s/"/"/g;
+ $str =~ s/</</g;
+ $str =~ s/>/>/g;
+ $str =~ s/&/&/g;
+ $str;
+}
+
+sub _simple_escape {
+ my $str = shift;
+ $str =~ s/&/&/g;
+ $str =~ s/"/"/g;
+ $str =~ s/</</g;
+ $str =~ s/>/>/g;
+ $str;
+}
+
+1;
--- /dev/null
+package HTML::Zoom::SelectorParser;
+
+use strict;
+use warnings FATAL => 'all';
+use Carp qw(confess);
+
+my $sel_char = '-\w_';
+my $sel_re = qr/([$sel_char]+)/;
+
+sub _raw_parse_simple_selector {
+ for ($_[1]) { # same pos() as outside
+
+ # '*' - match anything
+
+ /\G\*/gc and
+ return sub { 1 };
+
+ # 'element' - match on tag name
+
+ /\G$sel_re/gc and
+ return do {
+ my $name = $1;
+ sub { $_[0]->{name} && $_[0]->{name} eq $name }
+ };
+
+ # '#id' - match on id attribute
+
+ /\G#$sel_re/gc and
+ return do {
+ my $id = $1;
+ sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
+ };
+
+ # '.class1.class2' - match on intersection of classes
+
+ /\G((?:\.$sel_re)+)/gc and
+ return do {
+ my $cls = $1; $cls =~ s/^\.//;
+ my @cl = split(/\./, $cls);
+ sub {
+ $_[0]->{attrs}{class}
+ && !grep $_[0]->{attrs}{class} !~ /\b$_\b/, @cl
+ }
+ };
+
+ confess "Couldn't parse $_ as starting with simple selector";
+ }
+}
+
+sub parse_selector {
+ my $self = $_[0];
+ my $sel = $_[1]; # my pos() only please
+ local *_;
+ for ($sel) {
+ my @sub;
+ PARSE: { do {
+ push(@sub, $self->_raw_parse_simple_selector($_));
+ last PARSE if (pos == length);
+ /\G\s*,\s*/gc or confess "Selectors not comma separated";
+ } until (pos == length) };
+ return $sub[0] if (@sub == 1);
+ return sub {
+ foreach my $inner (@sub) {
+ if (my $r = $inner->(@_)) { return $r }
+ }
+ };
+ }
+}
+
+
+1;
--- /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}::redispatch_to"} = sub {
+ $app_package->_construct_redispatch($_[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 _construct_redispatch {
+ bless(\$_[1], 'Web::Simple::Redispatch');
+}
+
+sub _is_redispatch {
+ return unless
+ "$_[1]" =~ /\w+=[A-Z]/
+ and $_[1]->isa('Web::Simple::Redispatch');
+ return ${$_[1]};
+}
+
+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)
+ );
+ } elsif (my $path = $self->_is_redispatch($result)) {
+ $new_env->{PATH_INFO} = $path;
+ return $self->_run_dispatch_for($new_env, $dispatchables);
+ }
+ 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_cgi {
+ my $self = shift;
+ require Web::Simple::HackedPlack;
+ Plack::Server::CGI->run(sub { $self->handle_request(@_) });
+}
+
+sub run {
+ my $self = shift;
+ if ($ENV{GATEWAY_INTERFACE}) {
+ $self->_run_cgi;
+ }
+ my $path = shift(@ARGV);
+
+ require HTTP::Request::AsCGI;
+ require HTTP::Request::Common;
+ local *GET = \&HTTP::Request::Common::GET;
+
+ my $request = GET($path);
+ my $c = HTTP::Request::AsCGI->new($request)->setup;
+ $self->_run_cgi;
+ $c->restore;
+ print $c->response->as_string;
+}
+
+1;
--- /dev/null
+package Web::Simple::DispatchParser;
+
+use strict;
+use warnings FATAL => 'all';
+
+sub new { bless({}, ref($_[0])||$_[0]) }
+
+sub _blam {
+ my ($self, $error) = @_;
+ my $hat = (' ' x pos).'^';
+ die "Error parsing dispatch specification: ${error}\n
+${_}
+${hat} here\n";
+}
+
+sub parse_dispatch_specification {
+ my ($self, $spec) = @_;
+ for ($spec) {
+ my @match;
+ local $self->{already_have};
+ /^\G\s*/; # eat leading whitespace
+ PARSE: { do {
+ push @match, $self->_parse_spec_section($spec)
+ or $self->_blam("Unable to work out what the next section is");
+ last PARSE if (pos == length);
+ /\G\+/gc or $self->_blam('Spec sections must be separated by +');
+ } until (pos == length) }; # accept trailing whitespace
+ return $match[0] if (@match == 1);
+ return sub {
+ my $env = { %{$_[0]} };
+ my $new_env;
+ my @got;
+ foreach my $match (@match) {
+ if (my @this_got = $match->($env)) {
+ my %change_env = %{shift(@this_got)};
+ @{$env}{keys %change_env} = values %change_env;
+ @{$new_env}{keys %change_env} = values %change_env;
+ push @got, @this_got;
+ } else {
+ return;
+ }
+ }
+ return ($new_env, @got);
+ };
+ }
+}
+
+sub _dupe_check {
+ my ($self, $type) = @_;
+ $self->_blam("Can't have more than one ${type} match in a specification")
+ if $self->{already_have}{$type};
+ $self->{already_have}{$type} = 1;
+}
+
+sub _parse_spec_section {
+ my ($self) = @_;
+ for ($_[1]) {
+
+ # GET POST PUT HEAD ...
+
+ /\G([A-Z]+)/gc and
+ return $self->_http_method_match($_, $1);
+
+ # /...
+
+ /\G(?=\/)/gc and
+ return $self->_url_path_match($_);
+
+ /\G\.(\w+)/gc and
+ return $self->_url_extension_match($_, $1);
+ }
+ return; # () will trigger the blam in our caller
+}
+
+sub _http_method_match {
+ my ($self, $str, $method) = @_;
+ $self->_dupe_check('method');
+ sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
+}
+
+sub _url_path_match {
+ my ($self) = @_;
+ $self->_dupe_check('path');
+ for ($_[1]) {
+ my @path;
+ while (/\G\//gc) {
+ push @path, $self->_url_path_segment_match($_)
+ or $self->_blam("Couldn't parse path match segment");
+ }
+ my $re = '^()'.join('/','',@path).'$';
+ return sub {
+ if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
+ $cap[0] = {}; return @cap;
+ }
+ return ();
+ };
+ }
+ return;
+}
+
+sub _url_path_segment_match {
+ my ($self) = @_;
+ for ($_[1]) {
+ # trailing / -> require / on end of URL
+ /\G(?:(?=\s)|$)/gc and
+ return '$';
+ # word chars only -> exact path part match
+ /\G(\w+)/gc and
+ return "\Q$1";
+ # ** -> capture unlimited path parts
+ /\G\*\*/gc and
+ return '(.+?)';
+ # * -> capture path part
+ /\G\*/gc and
+ return '([^/]+)';
+ }
+ return ();
+}
+
+sub _url_extension_match {
+ my ($self, $str, $extension) = @_;
+ $self->_dupe_check('extension');
+ sub {
+ if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
+ ({ PATH_INFO => $tmp });
+ } else {
+ ();
+ }
+ };
+}
+
+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
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use FindBin;
+use lib $FindBin::RealBin.'/code';
+use Web::Simple 'SDL_Perl::WebSite';
+
+sub SDL_Perl::WebSite::Page::html { ${+shift} }
+
+package SDL_Perl::WebSite;
+
+use HTML::Zoom;
+
+default_config(
+ pages_dir => $FindBin::RealBin.'/pages',
+);
+
+sub page {
+ my ($self, $page) = @_;
+ my $file = $self->config->{pages_dir}.'/'.$page.'.html-inc';
+ return () unless -e $file;
+ return bless(
+ \do { local (@ARGV, $/) = $file; <> },
+ 'SDL_Perl::WebSite::Page'
+ )
+}
+
+dispatch [
+ sub (GET + /) { redispatch_to '/index.html' },
+ sub (GET + /**/) {
+ redispatch_to do { my $x = join('/','',$_[1],'index.html'); warn $x; $x };
+ },
+ sub (.html) {
+ filter_response { $self->render_html($_[1]) }
+ },
+ sub (GET + /**) {
+ $self->page($_[1])
+ },
+];
+
+{ my $DATA; sub _read_data { $DATA ||= do { local $/; <DATA>; } } }
+
+sub layout_zoom {
+ my $self = shift;
+ $self->{layout_zoom} ||= do {
+ HTML::Zoom->from_string($self->_read_data)
+ };
+}
+
+sub render_html {
+ my ($self, $data) = @_;
+ return $data if ref($data) eq 'ARRAY';
+ my ($zoom) = map {
+ if ($data->isa('SDL_Perl::WebSite::Page')) {
+ $_->with_selectors(
+ '#main' => {
+ -replace_content_raw => $data->html
+ }
+ );
+ } else {
+ die "WTF is ${data} supposed to be? A mallard?";
+ }
+ } ($self->layout_zoom);
+ $self->zoom_to_response($zoom);
+}
+
+sub zoom_to_response {
+ my ($self, $zoom) = @_;
+ open my $fh, '>', \my $out_str;
+ $zoom->render_to($fh);
+ return [
+ 200,
+ [ 'Content-type' => 'text/html' ],
+ [ $out_str ]
+ ];
+}
+
+
+SDL_Perl::WebSite->run_if_script;
+__DATA__
+<html>
+ <body>
+ <div id="main"/>
+ </body>
+</html>
projects / sdlgit/SDL-Site.git / commitdiff