Placeholder

+ +

Name: Bob

Age: 23

+ +

' + }, + 'span:odd p' => { -add_class => 'alt' }, + ] + ) + ->stream_to(\*STDOUT) + ->render; + +will print - + + + + Hello world & dog! + + +

Hello world & dog!

+ +

Name: Matt

Age: 26

+ +

Name: Mark

Age: 0x29

+ +

Name: Epitaph

Age: <redacted>

+ +

+ + + +Using a layout - + + + + default title + + +

+ + + +=head1 SELECTORS + +http://docs.jquery.com/Selectors + +=cut + +1; diff --git a/code/HTML/Zoom/ActionBuilder.pm b/code/HTML/Zoom/ActionBuilder.pm new file mode 100644 index 0000000..70fd2c1 --- /dev/null +++ b/code/HTML/Zoom/ActionBuilder.pm @@ -0,0 +1,103 @@ +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; diff --git a/code/HTML/Zoom/EventFilter.pm b/code/HTML/Zoom/EventFilter.pm new file mode 100644 index 0000000..70635fe --- /dev/null +++ b/code/HTML/Zoom/EventFilter.pm @@ -0,0 +1,139 @@ +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('{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; diff --git a/code/HTML/Zoom/Parser/BuiltIn.pm b/code/HTML/Zoom/Parser/BuiltIn.pm new file mode 100644 index 0000000..bba4189 --- /dev/null +++ b/code/HTML/Zoom/Parser/BuiltIn.pm @@ -0,0 +1,88 @@ +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; +} + +sub _simple_escape { + my $str = shift; + $str =~ s/&/&/g; + $str =~ s/"/"/g; + $str =~ s//>/g; + $str; +} + +1; diff --git a/code/HTML/Zoom/SelectorParser.pm b/code/HTML/Zoom/SelectorParser.pm new file mode 100644 index 0000000..5b04c1b --- /dev/null +++ b/code/HTML/Zoom/SelectorParser.pm @@ -0,0 +1,71 @@ +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; diff --git a/code/Web/Simple.pm b/code/Web/Simple.pm new file mode 100644 index 0000000..df3f461 --- /dev/null +++ b/code/Web/Simple.pm @@ -0,0 +1,41 @@ +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; diff --git a/code/Web/Simple/Application.pm b/code/Web/Simple/Application.pm new file mode 100644 index 0000000..ef22143 --- /dev/null +++ b/code/Web/Simple/Application.pm @@ -0,0 +1,132 @@ +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; diff --git a/code/Web/Simple/DispatchParser.pm b/code/Web/Simple/DispatchParser.pm new file mode 100644 index 0000000..a42a8b1 --- /dev/null +++ b/code/Web/Simple/DispatchParser.pm @@ -0,0 +1,132 @@ +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; diff --git a/code/Web/Simple/HackedPlack.pm b/code/Web/Simple/HackedPlack.pm new file mode 100644 index 0000000..89f4e01 --- /dev/null +++ b/code/Web/Simple/HackedPlack.pm @@ -0,0 +1,95 @@ +# 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 + +=cut + + diff --git a/sdl.cgi b/sdl.cgi new file mode 100755 index 0000000..34415b5 --- /dev/null +++ b/sdl.cgi @@ -0,0 +1,84 @@ +#!/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 $/; ; } } } + +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__ + + +

+ +