Bivio::UI::XHTML::Widget::WikiText
# Copyright (c) 2006-2012 bivio Software, Inc. All Rights Reserved. # $Id$ package Bivio::UI::XHTML::Widget::WikiText; use strict; use Bivio::Base 'XHTMLWidget.ControlBase'; my($_D) = b_use('Bivio.Die'); my($_A) = b_use('IO.Alert'); my($_C) = b_use('IO.Config'); my($_CA) = b_use('Collection.Attributes'); my($_CC) = b_use('IO.CallingContext'); my($_DT) = b_use('Type.DateTime'); my($_FCC) = b_use('FacadeComponent.Constant'); my($_I) = b_use('View.Inline'); my($_R) = b_use('IO.Ref'); my($_RF) = b_use('Action.RealmFile'); my($_RFC) = b_use('Mail.RFC822'); my($_T) = b_use('FacadeComponent.Task'); my($_TI) = b_use('Agent.TaskId'); my($_V) = b_use('UI.View'); my($_WDN) = b_use('Type.WikiDataName'); my($_WN) = b_use('Type.WikiName'); my($_VS) = b_use('UIXHTML.ViewShortcuts'); my($_INLINE_RE); my($_WV); my($_REALM_PLACEHOLDER) = b_use('Type.RealmName')->SPECIAL_PLACEHOLDER; my($_CAMEL_CASE) = qr{((?-i:[A-Z][A-Z0-9]*[a-z][a-z0-9]*[A-Z][A-za-z0-9]*))}; my($_EMAIL) = qr{@{[$_RFC->ATOM_ONLY_ADDR]}}o; my($_DOMAIN) = qr{(@{[ 'www\.' . $_RFC->DOMAIN . '\.(?:' . join('|', qw( ar fm ma ms pl pm sh )) . ')|' . $_RFC->DOMAIN . '\.(?:' . join('|', qw( aero biz cat com coop edu gov info int jobs mil mobi museum name net org pro travel asia post tel geo ac ad ae af ag ai al am an ao aq as at au aw az ax ba bb bd be bf bg bh bi bj bm bn bo br bs bt bv bw by bz ca cd cf cg ch ci ck cl cm cn co cr cs cu cv cx cy cz de dj dk dm do dz ec ee eg eh er es et eu fi fj fk fo fr ga gb gd ge gf gg gh gi gl gm gn gp gq gr gs gt gu gw gy hk hm hn hr ht hu id ie il im in io iq ir is it je jm jo jp ke kg kh ki km kn kp kr kw ky kz la lb lc li lk lr ls lt lu lv ly mc md mg mh mk ml mm mn mo mp mq mr mt mu mv mw mx my mz na nc ne nf ng ni nl no np nr nu nz om pa pe pf pg ph pk pn pr ps pt pw py qa re ro ru rw sa sb sc sd se sg si sj sk sl sm sn so sr st sv sy sz tc td tf tg th tj tk tl tm tn to tp tr tt tv tw tz ua ug uk um us uy uz va vc ve vg vi vn vu wf ws ye yt yu za zm zw )) . ')' ]})}x; my($_ROOT_TAG) = '#ROOT'; my($_CHILDREN) = _init_children(); my($_MY_TAGS); my($_MY_TAG_CLASSES) = []; _require_my_tags(__PACKAGE__); my($_IMG) = qr{.*\.(?:jpg|gif|jpeg|png|jpe)}; my($_WIDGET_ATTRS) = [qw(value realm_id realm_name task_id is_public)]; my($_TT) = $_WN->TITLE_TAG =~ /(\w+)/; my($_EMPTY) = {map((@{$_CHILDREN->{$_}} ? () : ($_ => 1)), keys(%$_CHILDREN))}; my($_NOT_FILE) = '<inline>'; b_use('IO.Config')->register(my $_CFG = { paragraphing => 1, }); sub CAMEL_CASE_REGEX { return $_CAMEL_CASE; } sub DOMAIN_REGEX { return $_DOMAIN; } sub EMAIL_REGEX { return $_EMAIL; } sub IMG_REGEX { return $_IMG; } sub NEW_ARGS { return [qw(value ?class)]; } sub control_on_render { my($self, $source, $buffer) = @_; #TODO: there should be two or more objects here: widget, language, and render(?) my($req) = $source->req; my($args) = { source => $source, req => $req, map(($_ => $self->render_simple_attr($_, $source)), @$_WIDGET_ATTRS), }; if (my $cc = $self->unsafe_get('calling_context')) { $args->{calling_context} = $cc->inc_line(-1); } else { $args->{path} = $args->{value}; } $$buffer .= $self->render_html($args); # Don't call SUPER; we don't want html_attrs return; } sub do_parse_lines { my(undef, $state, $op) = @_; # Set line number via include/macro just like CPP. Don't print messages # until eval. render_error #rjn: need to be able to set the line when parsing a content item while () { my($line) = shift(@{$state->{lines}}); return unless defined($line); if ($_CC->is_blesser_of($line)) { $state->{calling_context} = $line; next; } $state->{calling_context} = $state->{calling_context}->inc_line(1); return unless $op->($line); } return; } sub handle_config { my(undef, $cfg) = @_; $_CFG = $cfg; return; } sub include_content { my($proto, $content, $calling_context, $state) = @_; unshift( @{$state->{lines}}, split(/\r?\n/, ref($content) ? $$content : $content), ref($state->{calling_context}) ? $state->{calling_context} : (), ); $state->{calling_context} = $calling_context; return; } sub initialize { my($self) = @_; $self->map_invoke(unsafe_initialize_attr => $_WIDGET_ATTRS); return shift->SUPER::initialize(@_); } sub internal_format_uri { my($proto, $uri, $args) = @_; my($orig) = $uri; #ignore leading caret $uri =~ s/^\^//; $uri = $uri =~ qr{^$_EMAIL$}o ? "mailto:$uri" : $uri =~ qr{^$_DOMAIN$}o ? 'http://' . ($uri =~ /^[^\.]+\.\w+$/s ? 'www.' : '') . $uri : $uri; $uri =~ s/#([a-z][a-z0-9_:\.-]*)$//is; my($anchor) = $1 ? "#$1" : ''; return _check_uri( $uri =~ m{^/+$_REALM_PLACEHOLDER(/.+)}os && $args->{realm_name} ? $_T->format_uri({uri => "/$args->{realm_name}$1"}, $args->{req}) : $uri =~ m{^(?:\w+:|/)} ? $_T->format_uri({uri => $uri}, $args->{req}) : $_WN->is_valid($uri) ? $args->{req}->format_uri({ task_id => $args->{task_id}, realm => $args->{realm_name}, query => undef, path_info => $uri, }) : $_WDN->is_valid($uri) ? $_WDN->format_uri($uri, $args) #TODO: Probably should die? : $_T->format_uri({uri => $uri}, $args->{req}), $orig, $args, ) . $anchor; } sub unsafe_load_wiki_data { my($proto, $path, $args, $ignore_not_found) = @_; my($die_code); return $ignore_not_found ? () : $proto->render_error($path, $die_code, $args) unless my $rf = b_use('Action.WikiView') ->unsafe_load_wiki_data($path, $args, \$die_code); return $rf; } sub new { my($self) = shift->SUPER::new(@_); $self->put_unless_exists( calling_context => sub {Bivio::UI::ViewLanguageAUTOLOAD->unsafe_calling_context_for_wiki_text}, ); return $self; } sub parse_calling_context { my(undef, $state) = @_; return $state->{calling_context}; } sub prepare_html { my($proto, $arg1, $arg2, $task_id, $req) = @_; my($args) = $_CA->new({}); my($rf); if (ref($arg1) eq 'HASH') { b_die($arg1, ': missing req') unless $arg1->{req}; $args->internal_put($arg1); } elsif (Bivio::UNIVERSAL->is_blesser_of($arg1)) { $rf = $arg1; } elsif (ref($arg1) eq 'SCALAR') { $args->put( value => $$arg1, req => $arg2, ); } elsif (ref($arg1)) { b_die($arg1, ': invalid first argument'); } else { $rf = $_RF->access_controlled_load( $arg1, $_WN->to_absolute($arg2), $req); } $args->put( map(($_ => $rf->get($_)), @{$rf->get_keys}), value => ${$rf->get_content}, req => $req = $rf->req, name => $_WN->is_absolute($rf->get('path')) ? $_WN->from_absolute($rf->get('path')) : $rf->get('path'), path => $rf->get('path'), is_inline_text => 0, ) if $rf; $req ||= $args->get('req'); $args->put_unless_exists( is_public => 0, modified_date_time => $_DT->now, name => $_NOT_FILE, realm_id => $req->get('auth_id'), user_id => $req->get('auth_user_id'), proto => $proto, task_id => $task_id, ); $args = $args->internal_get; return $args if defined($args->{title}); _validator($args); my($v) = \$args->{value}; if ($$v =~ s{^( \@${_TT}[ \t]*\S[^\r\n]+\r?\n | \@$_TT.*?\r?\n\@/$_TT\s*?\r?\n )}{}isox) { my($x) = $1; $args->{calling_context} ||= $_CC->new_from_file_line($args->{path}, 1); my($t) = $proto->render_html({ %$args, is_inline_text => 1, value => $x, }) =~ m{^<$_TT>(.*)$}so; if (defined($t)) { $t =~ s/^\s+|\s+$//g; $args->{title} = $t; } else { $args->{proto}->render_error($x, 'not a header pattern', $args); substr($$v, 0, 0) = $x; } } $args->{title} = Bivio::HTML->escape($_WN->to_title($args->{name})) unless defined($args->{title}); return $args; } sub register_tag { my(undef, $tag, $class) = @_; $tag = lc($tag); b_die($tag, ': invalid tag format: ', $class) unless $tag =~ /^[a-z][-\w]+$/ && $tag =~ /-/; b_die($class, ': does not implement render_html') unless $class->can('render_html'); b_die( $tag, ': already registered by ', $_MY_TAGS->{$tag}, ' cannot register to: ', $class, ) if $_MY_TAGS->{$tag} && $_MY_TAGS->{$tag}->simple_package_name ne $class->simple_package_name; # Super class will register first so we always override $_MY_TAGS->{$tag} = $class; return; } sub render_error { my(undef, $object, $err, $state) = @_; $state->{validator}->validate_error($object, $err, $state); return ''; } sub render_html { my($proto, $args) = @_; unless (ref($args) eq 'HASH') { my(undef, $value, $name, $req, $task_id, $no_auto_links) = @_; Bivio::IO::Alert->warn_deprecated('pass a hash, not positional'); $args = { value => ref($value) ? $$value : $value, name => $name, req => $req, source => $req, task_id => $task_id, no_auto_links => $no_auto_links, }; } _validator($args); $args->{name} ||= $_NOT_FILE; $args->{path} ||= $args->{name}; $args->{source} ||= $args->{req}; $args->{proto} = $proto; $args->{task_id} = _task_id($args) unless ref($args->{task_id}); $args->{realm_id} ||= $args->{req}->get('auth_id'); unless ($args->{realm_name}) { my($ro) = Bivio::Biz::Model->new($args->{req}, 'RealmOwner'); $args->{realm_name} = $ro->get('name') if $ro->unauth_load({realm_id => $args->{realm_id}}); } $args->{is_public} = 1 unless defined($args->{is_public}); my($state) = { # Allow %$args override is_inline_text => $args->{name} eq $_NOT_FILE ? 1 : 0, %$args, proto => $proto, args => $args, tags => [], attrs => [], lines => [], }; $proto->include_content( \$args->{value}, $args->{calling_context} || $_CC->new_from_file_line($args->{path}, 0), $state, ); return _eval($state, _parse($state)); } sub render_html_without_view { my($args) = shift->prepare_html(@_); # Generate unique symbol related to this module return ( $_I->render_code_as_string( sub {$args->{proto}->render_html($args)}, $args->{req}, 'XHTMLWidget', $_VS, ), $args, ); } sub render_plain_text { my($args) = shift->prepare_html(@_); $args->{want_plain_text} = 1; my($body) = $_I->render_code_as_string( sub {$args->{proto}->render_html($args)}, $args->{req}, 'XHTMLWidget', ); $body =~ s/\n+/\n/sg; return ($body, $args); } sub _call_my_tag { my($state, $tag, $method, $args) = @_; my($die); my($res) = $_D->catch_quietly_unless_test( sub {$_MY_TAGS->{$tag}->$method($args)}, \$die, ); return $die ? $state->{proto}->render_error($tag, $die, $state) : defined($res) ? $res : ''; } sub _check_uri { my($uri, $orig, $args) = @_; #TODO: Consider dropping this if ($uri =~ /^javascript:/i) { $args->{proto}->render_error($orig, 'javascript links not allowed', $args); return 'link-error'; } $args->{validator}->validate_uri($uri, $args); return $uri; } sub _eval { my($state, $tree) = @_; return join( '', map({ $state->{calling_context} = $_->{calling_context}; $_->{op}->($state, $_); } @{$tree->{children}}), ); } sub _eval_char_entity { my($state, $args) = @_; return $state->{want_plain_text} ? Bivio::HTML->unescape($args->{content}) : $args->{content}; } sub _eval_literal { my($state, $args) = @_; return $state->{want_plain_text} ? $args->{content} : Bivio::HTML->escape($args->{content}); } sub _eval_my_tag { my($state, $args) = @_; return _call_my_tag( $state, $args->{tag}, $state->{want_plain_text} ? 'render_plain_text' : 'render_html', { %$state, %$args, state => $state, }, ); } sub _eval_tag { my($state, $args) = @_; my($tag) = $args->{tag}; my($attrs) = {%{$args->{attrs}}}; return $_MY_TAGS->{$tag} ? _eval_my_tag($state, $args) : $_EMPTY->{$tag} ? '' : _eval($state, $args) . "\n" if $state->{want_plain_text}; $attrs->{target} = $state->{link_target} if $tag eq 'a' && ! defined($attrs->{target}) && defined($state->{link_target}); foreach my $k (qw(src href)) { next unless $attrs->{$k}; $attrs->{$k} = $state->{proto}->internal_format_uri($attrs->{$k}, $state); } return _eval_my_tag($state, $args) if $_MY_TAGS->{$tag}; my($start) = join( ' ', $tag, map( qq{$_="} . Bivio::HTML->escape_attr_value($attrs->{$_}) . '"', sort(keys(%$attrs)), ), ); if ($_EMPTY->{$tag}) { $state->{proto}->render_error( $tag, ['empty tags are not allowed to have a value: ', $args->{children}], $state, ) if @{$args->{children}}; return "<$start />"; } my($content) = _eval($state, $args); return length($content) || $tag ne 'p' ? "<$start>$content</$tag>" : ''; } sub _fix_word { my($word) = @_; $word =~ s/#/ /; $word =~ s/_/ /g if $word =~ /^\w+$/; return $word; } sub _init_children { # From the XHTML DTD 1.0 my($special_pre) = ['br', 'span', 'bdo', 'map']; my($special) = [@$special_pre, 'object', 'img']; my($fontstyle) = ['tt', 'i', 'b', 'big', 'small']; my($phrase) = ['em', 'strong', 'dfn', 'code', 'q', 'samp', 'kbd', 'var', 'cite', 'abbr', 'acronym', 'sub', 'sup']; my($inline_forms) = ['input', 'select', 'textarea', 'label', 'button']; my($misc_inline) = ['ins', 'del', 'script']; my($misc) = ['noscript', @$misc_inline]; my($inline) = ['a', @$special, @$fontstyle, @$phrase, @$inline_forms]; my($Inline) = [@$inline, @$misc_inline]; $_INLINE_RE = qr{^(?:@{[join('|', grep(!/^br$/, @$Inline))]})$}; my($heading) = ['h1', 'h2', 'h3', 'h4', 'h5', 'h6']; my($lists) = ['ul', 'ol', 'dl']; my($blocktext) = ['pre', 'hr', 'blockquote', 'address']; my($block) = ['p', @$heading, 'div', @$lists, @$blocktext, 'fieldset', 'table']; my($Block) = [@$block, 'form', @$misc]; my($Flow) = [@$block, 'form', @$inline, @$misc]; my($a_content) = [@$special, @$fontstyle, @$phrase, @$inline_forms, @$misc_inline]; my($pre_content) = ['a', @$fontstyle, @$phrase, @$special_pre, @$misc_inline, @$inline_forms]; my($form_content) = [@$block, @$misc]; my($button_content) = ['p', @$heading, 'div', @$lists, @$blocktext, 'table', @$special, @$fontstyle, @$phrase, @$misc]; my($res) = $_R->nested_copy({ a => $a_content, abbr => $Inline, acronym => $Inline, address => $Inline, bdo => $Inline, big => $Inline, blockquote => $Block, br => [], button => $button_content, caption => $Inline, cite => $Inline, code => $Inline, col => [], colgroup => [qw(col)], dd => $Flow, del => $Flow, dfn => $Inline, div => $Flow, dl => [qw(dt dd)], dt => $Inline, em => $Inline, fieldset => ['legend', @$block, 'form', @$inline, @$misc], form => $form_content, h1 => $Inline, h2 => $Inline, h3 => $Inline, h4 => $Inline, h5 => $Inline, h6 => $Inline, hr => [], img => [], input => [], ins => $Flow, kbd => $Inline, label => $Inline, legend => $Inline, li => $Flow, object => ['param', @$block, 'form', @$inline, @$misc], ol => [qw(li)], optgroup => [qw(option)], option => ['#PCDATA'], p => $Inline, param => [], pre => $pre_content, q => $Inline, samp => $Inline, select => [qw(optgroup option)], small => $Inline, span => $Inline, strong => $Inline, sub => $Inline, sup => $Inline, table => [qw(caption col colgroup thead tfoot tbody tr)], tbody => [qw(tr)], td => $Flow, textarea => ['#PCDATA'], tfoot => [qw(tr)], th => $Flow, thead => [qw(tr)], tr => [qw(th td)], ul => [qw(li)], var => $Inline, }); $res->{$_ROOT_TAG} = [sort(keys(%$res))]; return $res; } sub _parse { my($state) = @_; $state->{option} = {paragraphing => $_CFG->{paragraphing}}; $state->{parse} = { stack => [], }; _parse_stack_push($state, my $root = { op => \&_eval, tag => $_ROOT_TAG, }); _pre_parse_my_tags($state); $state->{proto}->do_parse_lines( $state, sub { my($line) = @_; if ($line =~ /^\@[a-z]/i) { _parse_tag_start($state, $line); } elsif ($line =~ /^\@\/[a-z]/i) { _parse_tag_end($state, $line); } else { _parse_line($state, $line); } return 1; }, ); delete($state->{parse}); return $root; } sub _pre_parse_my_tags { my($state) = @_; foreach my $class (@$_MY_TAG_CLASSES) { $class->pre_parse($state); } return; } sub _parse_child_ok { my($state, $tag) = @_; return grep($tag eq $_, @{$_CHILDREN->{_parse_stack_top($state)->{tag}}}) ? 1 : 0; } sub _parse_content { my($state, $value) = @_; # OPTIMIZATION: Only parse chars if magic chars appear in string at all my($chars) = [split('', $value)]; my($ch); my($res) = ''; my($next) = sub { return !@$chars ? '' : ord($ch = shift(@$chars)) > 0 ? $ch : $state->{proto}->render_error( undef, [sprintf('0x%x', ord($ch)), ': invalid character'], $state, ); }; my($out) = sub { my($code, @args) = @_; _parse_out_p($state) if ($code || length($res)) && _parse_paragraphing_ok($state); _parse_out($state, \&_eval_literal, $res) if length($res); $res = $ch = ''; $ch = $code->($state, $next, @args) if $code; unshift(@$chars, split('', $ch)) if length($ch); $ch = ''; return; }; # OPTIMIZATION: don't loop over characters if no specials unless ($value =~ /[\@\^\*_]/) { $res = $value; $out->(); return 1; } my($prev); while (length($next->())) { if ($ch eq '^') { $out->(\&_parse_content_link); } elsif ($ch =~ /[\*\_]/ && !_parse_stack_in_tag($state, qr{^(?:pre|code)$}) ) { $out->(\&_parse_content_font, $ch) if !defined($prev) || !length($prev) || $prev =~ /\W/; } elsif ($ch eq '@') { last unless length($next->()); next if $ch eq '@'; if ($ch eq '&') { $out->(\&_parse_content_special) } else { $ch = '@' . $ch; } } } continue { $prev = $ch; $res .= $ch; $ch = ''; } $out->(); return $ch ne '@'; } sub _parse_content_font { my($state, $next, $which) = @_; _parse_out($state, \&_eval_tag, { tag => $which eq '*' ? 'strong' : 'em', attrs => {}, }); my($my_op) = _parse_stack_top($state); my($content) = ''; my($ch); my($extra) = ''; while (length($ch = $next->())) { if ($ch =~ /[\*\_\s]/) { last unless $ch eq $which; $extra = ''; $ch = ''; $content .= ' '; } else { $content .= $ch; $extra .= $ch; } } substr($content, -length($extra)) = '' if length($extra); $content =~ s/\s+$//s; _parse_content($state, $content); _parse_stack_pop($state, $my_op); return $extra . $ch; } sub _parse_content_link { my($state, $next) = @_; my($link) = ''; my($ch) = $next->(); return _parse_out($state, \&_eval_literal, $ch) if $ch eq '^'; while ($ch =~ /\S/) { $link .= $ch; last unless length($ch = $next->()); } $ch = ($link =~ s/([\)\]\}\>\.,:;"'`~!\|]*)$// ? $1 : '') . $ch; _parse_out( $state, length($link) ? ( \&_eval_tag, $link =~ $_IMG ? {tag => 'img', attrs => {alt => $link, src => $link}} : ( {tag => 'a', attrs => {href => $link}}, _fix_word($link), ), ) : ( \&_eval_literal, '^', ), ); return $ch; } sub _parse_content_special { my($state, $next) = @_; my($value) = ''; my($ch) = $next->(); my($pat) = qr{[a-z]}i; if ($ch eq '#') { $pat = qr{[0-9]}; $value .= $ch; $ch = $next->(); } while ($ch =~ $pat) { $value .= $ch; $ch = $next->(); } $state->{proto}->render_error(undef, 'invalid character entity', $state) unless length($value) >= ($value =~ /#/ ? 3 : 2); _parse_out($state, \&_eval_char_entity, "&$value;"); return $ch eq ';' ? '' : $ch; } sub _parse_die { my($state) = shift; $state->{proto}->render_error(@_, $state); return $state->{req}->if_test(sub {b_die('assertion fault')}); } sub _parse_hr { my($state) = @_; _parse_tag_start($state, '@hr'); _parse_tag_start($state, '@br'); return; } sub _parse_line { my($state, $line) = @_; return if $line =~ /^\@\!/s; return _parse_line_empty($state) if $line =~ /^\s*$/s; return _parse_hr($state) if $line =~ /^--+\s*$/s; _parse_out($state, \&_eval_literal, "\n") if _parse_content($state, $line); return; } sub _parse_line_empty { my($state) = @_; return _parse_out($state, \&_eval_literal, "\n") unless _parse_paragraphing_ok( $state, _parse_stack_top($state)->{tag}, 1); my($p) = _parse_stack_in_tag($state, qr{^p$}); return _parse_out_p( $state, !$p ? () : defined($p->{attrs}->{class}) ? $p->{attrs}->{class} : '', ); } sub _parse_my_tag { my($state, $tag, $attrs, $line) = @_; return 0 unless $_MY_TAGS->{$tag} && $_MY_TAGS->{$tag}->can('parse_tag_start'); return 1 unless _call_my_tag( $state, $tag, 'parse_tag_start', my $args = { state => $state, tag => $tag, attrs => $attrs, line => $line, }, ); _parse_out($state, \&_eval_tag, $args); _parse_stack_pop($state, $tag); return 1; } sub _parse_out { my($state, $op, $args, $content) = @_; $args = {content => $args} unless ref($args); $args->{op} = $op; push(@{_parse_stack_top($state)->{children}}, $args); _parse_stack_push($state, $args); if (defined($content)) { _parse_out($state, \&_eval_literal, $content); _parse_stack_pop($state, $args->{tag}); } _parse_stack_pop($state, $args) unless $args->{tag} && !$_EMPTY->{$args->{tag}}; return ''; } sub _parse_out_p { my($state, $class) = @_; $class = 'b_prose' if !defined($class); _parse_stack_pop($state, 'p') until _parse_child_ok($state, 'p'); return _parse_out( $state, \&_eval_tag, { tag => 'p', attrs => length($class) ? {class => $class} : {}, }, ); } sub _parse_paragraphing_ok { my($state, $tag, $line_empty) = @_; return $state->{option}->{paragraphing} && ( $line_empty ? $tag eq 'p' : !_parse_stack_in_tag($state, qr{^p$}) && (!$tag || $tag =~ $_INLINE_RE) ) && !_parse_stack_in_tag($state, qr{^(?:div|dt|h\d|pre|script|select|textarea)$}) && !_parse_stack_top($state, qr{^(?:ul|dl|ol)$}) && ( _parse_stack_in_tag( $state, qr{^(?:blockquote|del|dd|fieldset|form|ins|li|object|p|td)$}, ) || _parse_stack_top($state, $_ROOT_TAG) ) ? 1 : 0; } sub _parse_stack_in_tag { my($state, $tag_re) = @_; return (grep($_->{tag} =~ $tag_re, @{$state->{parse}->{stack}}))[0]; } sub _parse_stack_pop { my($state, $tag) = @_; my($stack) = $state->{parse}->{stack}; return _parse_die($state, $tag, 'stack too short') unless @$stack > 1; shift(@$stack); return; } sub _parse_stack_push { my($state, $args) = @_; $args->{calling_context} = $state->{calling_context}; $args->{children} = []; unshift(@{$state->{parse}->{stack}}, $args); return; } sub _parse_stack_top { my($state, $tag) = @_; my($top) = $state->{parse}->{stack}->[0]; return $top unless $tag; return $top->{tag} =~ $tag if ref($tag); return $top->{tag} eq $tag; } sub _parse_tag_attrs { my($state, $line) = @_; my($attrs) = {}; my($postfix) = $$line =~ s/^(\S+)//s ? $1 : ''; while (length($postfix)) { if ($postfix =~ s/^\.(\w[\w\-]*)//is) { $attrs->{class} .= (defined($attrs->{class}) ? ' ' : '') . $1; } elsif ($postfix =~ s/^\#([\:\_a-z][\-\.\:\w]*)//is) { if ($attrs->{id}) { $state->{proto}->render_error('#' . $1, 'only one id attribute allowed', $state); last; } $attrs->{id} = $1; } else { $state->{proto}->render_error($postfix, 'invalid tag postfix', $state); last; } } while ($$line =~ s/^\s+(?:(?:(\w+)=)([^"\s]+|(?=(?:\s|$)))|(?:(\w+)=)"([^\"]*)("?))//s) { if (defined($3) && !$5) { $state->{proto}->render_error($1, 'attribute value not terminated by quote', $state); last; } $attrs->{lc($1 ? $1 : $3)} = defined($2) ? $2 : $4; } return $attrs; } sub _parse_tag_end { my($state, $line) = @_; return unless my $tag = _parse_tag_ok($state, \$line); return $state->{proto}->render_error( '@/' . $tag, 'spurious end tag', $state, ) unless _parse_stack_in_tag($state, qr{^$tag$}); _parse_stack_pop($state, $tag) until _parse_stack_top($state, $tag); _parse_stack_pop($state, $tag); return; } sub _parse_tag_start { my($state, $line) = @_; return unless my $tag = _parse_tag_ok($state, \$line); my($attrs) = _parse_tag_attrs($state, \$line); $line =~ s/^\s+|\s+$//s; return if _parse_my_tag($state, $tag, $attrs, $line); _parse_out_p($state) if _parse_paragraphing_ok($state, $tag); _parse_stack_pop($state, $tag) until _parse_child_ok($state, $tag); _parse_out($state, \&_eval_tag, {tag => $tag, attrs => $attrs}); if (length($line)) { return $state->{proto}->render_error( $tag, ['empty tags are not allowed to have content: ', $line], $state, ) if $_EMPTY->{$tag}; _parse_content($state, $line); _parse_stack_pop($state, $tag); } return; } sub _parse_tag_ok { my($state, $line) = @_; $$line =~ s/^(\@\/?)([\w\-]+)//s || _parse_die($state, $line, ': invalid internal call'); my($tag) = lc($2); return $state->{proto}->render_error("$1$tag$$line", 'unknown tag', $state) unless $_CHILDREN->{$tag}; return $tag } sub _require_my_tags { my($proto) = @_; foreach my $c (@{b_use('IO.ClassLoader')->map_require_all('WikiText')}) { push(@$_MY_TAG_CLASSES, $c); foreach my $t (@{$c->handle_register}) { $proto->register_tag($t, $c); } } my($tags) = [sort(keys(%$_MY_TAGS))]; while (my($k, $v) = each(%$_CHILDREN)) { push(@$v, @$tags) if @$v; } foreach my $tag (@$tags) { $_CHILDREN->{$tag} = $_MY_TAGS->{$tag}->ACCEPTS_CHILDREN ? [grep($tag ne $_, @{$_CHILDREN->{$_ROOT_TAG}})] : []; } return; } sub _task_id { my($args) = @_; return $_TI->from_any($args->{task_id}) if $args->{task_id}; my($t) = $args->{req}->get('task_id'); return $t if $t->get_name =~ /WIKI_VIEW/; #TODO: This is really dicey return $t->get_name =~ /BLOG|WIKI|HELP/ ? $t : 'FORUM_WIKI_VIEW'; } sub _validator { my($args) = @_; #TODO: This should be encapsulated in validator return $args->{validator} ||= ($_WV ||= b_use('Action.WikiValidator')) ->get_current_or_new($args->{path}, $args->{realm_id}, $args->{req}); } 1;