--- /dev/null
+package CSS::Declare;
+
+use strict;
+use warnings;
+
+use Syntax::Keyword::Gather;
+
+my $IN_SCOPE = 0;
+
+sub import {
+ die "Can't import CSS::Declare into a scope when already compiling one that uses it"
+ if $IN_SCOPE;
+ my ($class, @args) = @_;
+ my $opts = shift(@args) if ref($args[0]) eq 'HASH';
+ my $target = $class->_find_target(0, $opts);
+ my $unex = $class->_export_tags_into($target);
+ $class->_install_unexporter($unex);
+ $IN_SCOPE = 1;
+}
+
+sub _find_target {
+ my ($class, $extra_levels, $opts) = @_;
+ return $opts->{into} if defined($opts->{into});
+ my $level = ($opts->{into_level} || 1) + $extra_levels;
+ return (caller($level))[0];
+}
+
+my @properties = qw{
+accelerator
+azimuth
+background
+background_attachment
+background_color
+background_image
+background_position
+background_position_x
+background_position_y
+background_repeat
+behavior
+border
+border_bottom
+border_bottom_color
+border_bottom_style
+border_bottom_width
+border_collapse
+border_color
+border_left
+border_left_color
+border_left_style
+border_left_width
+border_right
+border_right_color
+border_right_style
+border_right_width
+border_spacing
+border_style
+border_top
+border_top_color
+border_top_style
+border_top_width
+border_width
+bottom
+caption_side
+clear
+clip
+color
+content
+counter_increment
+counter_reset
+cue
+cue_after
+cue_before
+cursor
+direction
+display
+elevation
+empty_cells
+filter
+float
+font
+font_family
+font_size
+font_size_adjust
+font_stretch
+font_style
+font_variant
+font_weight
+height
+ime_mode
+include_source
+layer_background_color
+layer_background_image
+layout_flow
+layout_grid
+layout_grid_char
+layout_grid_char_spacing
+layout_grid_line
+layout_grid_mode
+layout_grid_type
+left
+letter_spacing
+line_break
+line_height
+list_style
+list_style_image
+list_style_position
+list_style_type
+margin
+margin_bottom
+margin_left
+margin_right
+margin_top
+marker_offset
+marks
+max_height
+max_width
+min_height
+min_width
+orphans
+outline
+outline_color
+outline_style
+outline_width
+overflow
+overflow_X
+overflow_Y
+padding
+padding_bottom
+padding_left
+padding_right
+padding_top
+page
+page_break_after
+page_break_before
+page_break_inside
+pause
+pause_after
+pause_before
+pitch
+pitch_range
+play_during
+position
+quotes
+_replace
+richness
+right
+ruby_align
+ruby_overhang
+ruby_position
+size
+speak
+speak_header
+speak_numeral
+speak_punctuation
+speech_rate
+stress
+scrollbar_arrow_color
+scrollbar_base_color
+scrollbar_dark_shadow_color
+scrollbar_face_color
+scrollbar_highlight_color
+scrollbar_shadow_color
+scrollbar_3d_light_color
+scrollbar_track_color
+table_layout
+text_align
+text_align_last
+text_decoration
+text_indent
+text_justify
+text_overflow
+text_shadow
+text_transform
+text_autospace
+text_kashida_space
+text_underline_position
+top
+unicode_bidi
+vertical_align
+visibility
+voice_family
+volume
+white_space
+widows
+width
+word_break
+word_spacing
+word_wrap
+writing_mode
+z_index
+zoom
+};
+
+sub _export_tags_into {
+ my ($class, $into) = @_;
+ for my $property (@properties) {
+ my $property_name = $property;
+ $property_name =~ tr/_/-/;
+ no strict 'refs';
+ *{"$into\::$property"} = sub ($) { return ($property_name => $_[0]) };
+ }
+ return sub {
+ foreach my $property (@properties) {
+ no strict 'refs';
+ delete ${"${into}::"}{$property}
+ }
+ $IN_SCOPE = 0;
+ };
+}
+
+sub _install_unexporter {
+ my ($class, $unex) = @_;
+ $^H |= 0x120000; # localize %^H
+ $^H{'CSS::Declare::Unex'} = bless($unex, 'CSS::Declare::Unex');
+}
+
+sub to_css_string {
+ my @css = @_;
+ return join q{ }, gather {
+ while (my ($selector, $declarations) = splice(@css, 0, 2)) {
+ take "$selector "._generate_declarations($declarations)
+ }
+ };
+}
+
+sub _generate_declarations {
+ my $declarations = shift;
+
+ return '{'.join(q{;}, gather {
+ while (my ($property, $value) = splice(@{$declarations}, 0, 2)) {
+ take "$property:$value"
+ }
+ }).'}';
+}
+
+package CSS::Declare::Unex;
+
+sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" }
+
+1;
--- /dev/null
+package HTML::Tags;
+
+use strict;
+use warnings FATAL => 'all';
+use XML::Tags ();
+
+my @HTML_TAGS = qw(
+a
+abbr
+address
+area
+article
+aside
+audio
+b
+base
+bb
+bdo
+blockquote
+body
+br
+button
+canvas
+caption
+cite
+code
+col
+colgroup
+command
+datagrid
+datalist
+dd
+del
+details
+dialog
+dfn
+div
+dl
+dt
+em
+embed
+eventsource
+fieldset
+figure
+footer
+form
+h1
+h2
+h3
+h4
+h5
+h6
+head
+header
+hr
+html
+i
+iframe
+img
+input
+ins
+kbd
+label
+legend
+li
+link
+mark
+map
+menu
+meta
+meter
+nav
+noscript
+object
+ol
+optgroup
+option
+output
+p
+param
+pre
+progress
+q
+ruby
+rp
+rt
+samp
+script
+section
+select
+small
+source
+span
+strong
+style
+sub
+sup
+table
+tbody
+td
+textarea
+tfoot
+th
+thead
+time
+title
+tr
+ul
+var
+video
+);
+
+sub import {
+ my ($class, @rest) = @_;
+ my $opts = ref($rest[0]) eq 'HASH' ? shift(@rest) : {};
+ ($opts->{into_level}||=1)++;
+ XML::Tags->import($opts, @HTML_TAGS, @rest);
+}
+
+sub to_html_string { XML::Tags::to_xml_string(@_) }
+
+1;
--- /dev/null
+package XML::Tags;
+
+use strict;
+use warnings FATAL => 'all';
+
+use File::Glob ();
+
+require overload;
+
+my $IN_SCOPE = 0;
+
+sub import {
+ die "Can't import XML::Tags into a scope when already compiling one that uses it"
+ if $IN_SCOPE;
+ my ($class, @args) = @_;
+ my $opts = shift(@args) if ref($args[0]) eq 'HASH';
+ my $target = $class->_find_target(0, $opts);
+ my @tags = $class->_find_tags(@args);
+ my $unex = $class->_export_tags_into($target => @tags);
+ $class->_install_unexporter($unex);
+ $IN_SCOPE = 1;
+}
+
+sub to_xml_string {
+ map { # string == text -> HTML, scalarref == raw HTML, other == passthrough
+ ref($_)
+ ? (ref $_ eq 'SCALAR' ? $$_ : $_)
+ : do { local $_ = $_; # copy
+ if (defined) {
+ s/&/&/g; s/"/"/g; s/</</g; s/>/>/g; $_;
+ } else {
+ ''
+ }
+ }
+ } @_
+}
+
+sub _find_tags { shift; @_ }
+
+sub _find_target {
+ my ($class, $extra_levels, $opts) = @_;
+ return $opts->{into} if defined($opts->{into});
+ my $level = ($opts->{into_level} || 1) + $extra_levels;
+ return (caller($level))[0];
+}
+
+sub _set_glob {
+ # stupid insanity. delete anything already there so we disassociated
+ # the *CORE::GLOBAL::glob typeglob. Then the string reference call
+ # revivifies it - i.e. creates us a new glob, which we get a reference
+ # to, which we can then assign to.
+ # doing it without the quotes doesn't - it binds to the version in scope
+ # at compile time, which means after a delete you get a nice warm segv.
+ delete ${CORE::GLOBAL::}{glob};
+ no strict 'refs';
+ *{'CORE::GLOBAL::glob'} = $_[0];
+}
+
+sub _export_tags_into {
+ my ($class, $into, @tags) = @_;
+ foreach my $tag (@tags) {
+ no strict 'refs';
+ tie *{"${into}::${tag}"}, 'XML::Tags::TIEHANDLE', \"<${tag}>";
+ }
+ _set_glob(sub {
+ local $XML::Tags::StringThing::IN_GLOBBERY = 1;
+ \('<'."$_[0]".'>');
+ });
+ overload::constant(q => sub { XML::Tags::StringThing->from_constant(@_) });
+ return sub {
+ foreach my $tag (@tags) {
+ no strict 'refs';
+ delete ${"${into}::"}{$tag}
+ }
+ _set_glob(\&File::Glob::glob);
+ overload::remove_constant('q');
+ $IN_SCOPE = 0;
+ };
+}
+
+sub _install_unexporter {
+ my ($class, $unex) = @_;
+ $^H |= 0x120000; # localize %^H
+ $^H{'XML::Tags::Unex'} = bless($unex, 'XML::Tags::Unex');
+}
+
+package XML::Tags::TIEHANDLE;
+
+sub TIEHANDLE { my $str = $_[1]; bless \$str, $_[0] }
+sub READLINE { ${$_[0]} }
+
+package XML::Tags::Unex;
+
+sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" }
+
+package XML::Tags::StringThing;
+
+use overload (
+ '.' => 'concat',
+ '""' => 'stringify',
+ fallback => 1
+);
+
+sub stringify {
+ join(
+ '',
+ ((our $IN_GLOBBERY)
+ ? XML::Tags::to_xml_string(@{$_[0]})
+ : (map +(ref $_ ? $$_ : $_), @{$_[0]})
+ )
+ );
+}
+
+sub from_constant {
+ my ($class, $initial, $parsed, $type) = @_;
+ return $parsed unless $type eq 'qq';
+ return $class->new($parsed);
+}
+
+sub new {
+ my ($class, $string) = @_;
+ bless([ \$string ], $class);
+}
+
+sub concat {
+ my ($self, $other, $rev) = @_;
+ my @extra = do {
+ if (ref($other) && ($other =~ /[a-z]=[A-Z]/) && $other->isa(__PACKAGE__)) {
+ @{$other}
+ } else {
+ $other;
+ }
+ };
+ my @new = @{$self};
+ $rev ? unshift(@new, @extra) : push(@new, @extra);
+ bless(\@new, ref($self));
+}
+
+1;
--- /dev/null
+use strict; use warnings FATAL => 'all';
+use Test::More qw(no_plan);
+
+{
+
+ package Foo;
+ sub foo {
+ use CSS::Declare;
+ return (
+ '*' => [ color 'red' ],
+ 'tr, td' => [ margin '1px' ],
+ );
+ }
+}
+
+is(
+ CSS::Declare::to_css_string(Foo::foo()),
+ '* {color:red} tr, td {margin:1px}',
+ 'Basic CSS::Declare usage'
+);
+
+ok(!Foo->can('color'), 'Death on use of unimported tag');
+
--- /dev/null
+use strict; use warnings FATAL => 'all';
+use Test::More qw(no_plan);
+
+{
+
+ package Foo;
+
+ sub foo {
+ use XML::Tags qw(one two three);
+ <one>, <two>, <three>;
+ }
+
+ sub bar {
+ no warnings 'once'; # this is supposed to warn, it's broken
+ <one>
+ }
+
+ sub baz {
+ use XML::Tags qw(bar);
+ </bar>;
+ }
+
+ sub quux {
+ use HTML::Tags;
+ <html>, <body id="spoon">, "YAY", </body>, </html>;
+ }
+
+ sub xquux {
+ use HTML::Tags;
+ <link href="#self" rel="me" />,
+ <table>,<tr>,<td>,'x',<sub>,1,</sub>,</td>,</tr>,</table>;
+ }
+
+ sub fleem {
+ use XML::Tags qw(woo);
+ my $ent = 'one&two<three>"four';
+ <woo ent="$ent">;
+ }
+
+ sub flaax {
+ use XML::Tags qw(woo);
+ my $data = "one&two<three>four";
+ <woo>, $data, </woo>,
+ <woo>, \$data, </woo>;
+ }
+
+ sub HTML_comment {
+ use HTML::Tags;
+ <!-- this is a comment -->;
+ }
+
+ sub PI {
+ use XML::Tags;
+ <?xml version="1.0" encoding="UTF-8"?>;
+ }
+
+ sub DTD {
+ use HTML::Tags;
+ <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+ }
+
+ sub globbery {
+ <t/globbery/*>;
+ }
+}
+
+is(
+ join(', ', XML::Tags::to_xml_string Foo::foo()),
+ '<one>, <two>, <three>',
+ 'open tags ok'
+);
+
+ok(!eval { Foo::bar(); 1 }, 'Death on use of unimported tag');
+
+is(
+ join(', ', XML::Tags::to_xml_string Foo::baz()),
+ '</bar>',
+ 'close tag ok'
+);
+
+is(
+ join('', HTML::Tags::to_html_string Foo::quux),
+ '<html><body id="spoon">YAY</body></html>',
+ 'HTML tags ok'
+);
+
+is(
+ join('', HTML::Tags::to_html_string Foo::xquux),
+ '<link href="#self" rel="me" />' .
+ '<table><tr><td>x<sub>1</sub></td></tr></table>',
+ 'Conflicting HTML tags ok'
+);
+
+is(
+ join('', XML::Tags::to_xml_string Foo::HTML_comment),
+ '<!-- this is a comment -->',
+ 'HTML comment ok'
+);
+
+is(
+ join('', XML::Tags::to_xml_string Foo::fleem),
+ '<woo ent="one&two<three>"four">',
+ 'Escaping ok'
+);
+
+is(
+ join('', XML::Tags::to_xml_string Foo::flaax),
+ '<woo>one&two<three>four</woo><woo>one&two<three>four</woo>',
+ 'Escaping user data ok'
+);
+
+is(
+ join('', XML::Tags::to_xml_string Foo::PI),
+ '<?xml version="1.0" encoding="UTF-8"?>',
+ 'XML processing instruction'
+);
+
+is(
+ join('', HTML::Tags::to_html_string Foo::DTD),
+ '<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">',
+ 'DTD ok'
+);
+
+is(
+ join(', ', Foo::globbery),
+ 't/globbery/one, t/globbery/two',
+ 'real glob re-installed ok'
+);
--- /dev/null
+use strict;
+use warnings FATAL => 'all';
+use Test::More;
+
+{
+ eval "use HTML::Zoom; 1" ?
+ plan qw(no_plan) :
+ plan skip_all => "HTML::Zoom is not installed";
+}
+
+{
+ package BasicPage;
+ use HTML::Tags;
+
+ sub show_landing_html {
+ as_html(\&landing, (
+ title => "Welcome to the Demo Home",
+ site_version => 10,
+ new_user_link => 'create_user.html',
+ ));
+ }
+
+ sub show_landing_events {
+ as_events(\&landing, (
+ title => "Welcome to the Demo Home",
+ site_version => 10,
+ new_user_link => 'create_user.html',
+ ));
+ }
+
+ sub layout {
+ my (%data) = @_;
+ \'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">',
+ <html>,
+ <head>,
+ <!-- here is a comment -->,
+ <title>, ($data{title} || 'Hello World'), </title>,
+ </head>,
+ <body>,
+ @{$data{content}},
+ </body>,
+ </html>;
+ }
+
+ sub landing {
+ my (%data) = @_;
+ <p>, "Hi, I'm version: ", $data{site_version}, </p>,
+ <p>, "Here's some interesting things about me", </p>,
+ <img src="smilyface.png" alt="smiles" />,
+ <ul>,
+ <li>, <a href="/user">, "My Users", </li>,
+ <li>, <a href="/user/$data{new_user_link}">, "Create", "New User", </li>,
+ </ul>;
+ }
+
+ sub process_templates {
+ my ($templates, %data) = @_;
+ for my $template(@$templates) {
+ my @processed = $template->(%data);
+ $data{content} = \@processed;
+ }
+ return @{$data{content}};
+ }
+
+ sub as_html {
+ my ($template, %data) = @_;
+ my @content = process_templates([$template, \&layout], %data);
+ return join '', HTML::Tags::to_html_string(@content);
+ }
+
+ sub as_events {
+ my ($template, %data) = @_;
+ my @content = process_templates([$template, \&layout], %data);
+ return [_convert_to_events(@content)];
+ }
+
+ sub _convert_to_events {
+ map {
+ my $raw = ref $_ ? $$_ : $_;
+ my @info = ($raw =~m{
+ (
+ (?:[^<]*) < (?:
+ ( / )? ( [^/!<>\s"'=]+ )
+ ( (?:"[^"]*"|'[^']*'|[^"'<>])+? )?
+ |
+ (!-- .*? -- | ![^\-] .*? )
+ ) (\s*/\s*)? >
+ )
+ ([^<]*)
+ }x);
+
+ my ($whole, $is_close, $tag_name, $attrs, $comment_or_directive,
+ $in_place_close) = @info;
+
+ if($comment_or_directive) {
+ +{ type => 'SPECIAL', raw => $raw };
+ } elsif(!scalar(@info)) {
+ +{ type => 'TEXT', raw => $raw };
+ } else {
+ if($is_close) {
+ $tag_name =~ tr/A-Z/a-z/;
+ +{ type => 'CLOSE', name => $tag_name, raw => $raw};
+ } else {
+ $attrs = '' if !defined($attrs) or $attrs =~ /^ +$/;
+ +{
+ type => 'OPEN',
+ name => $tag_name,
+ is_in_place_close => $in_place_close,
+ HTML::Zoom::Parser::BuiltIn::_hacky_attribute_parser($attrs),
+ raw_attrs => $attrs||'',
+ raw => $whole,
+ }, $in_place_close ?
+ +{
+ type => 'CLOSE',
+ name => $tag_name,
+ raw => '',
+ is_in_place_close => 1,
+ } :
+ +();
+ }
+ }
+ } @_;
+ }
+}
+
+ok my $html = BasicPage->show_landing_html;
+ok my $zoom = HTML::Zoom->from_html($html);
+ok my $events = BasicPage->show_landing_events;
+
+use Data::Dump 'dump';
+warn dump $html;
+warn dump $zoom->to_events;
+warn dump $events;
+
projects / catagits/HTML-Zoom.git / commitdiff