File Coverage

blib/lib/WebDAO/Lex.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             #===============================================================================
2             #
3             # DESCRIPTION: New Ng Lexer
4             #
5             # AUTHOR: Aliaksandr P. Zahatski, <zag@cpan.org>
6             #===============================================================================
7             package WebDAO::Lex;
8              
9             =head1 NAME
10              
11             WebDAO::Lex - Lexer class
12              
13             =head1 DESCRIPTION
14              
15             WebDAO::Lex - Lexer class
16              
17              
18             =head1 METHODS
19              
20             =cut
21              
22             our $VERSION = '0.01';
23              
24 5     5   84071 use strict;
  5         12  
  5         147  
25 5     5   31 use warnings;
  5         12  
  5         144  
26 5     5   811 use WebDAO::Base;
  5         13  
  5         313  
27 5     5   2372 use XML::Flow;
  0            
  0            
28             use base 'WebDAO::Base';
29             use WebDAO::Lexer::base;
30             use WebDAO::Lexer::method;
31             use WebDAO::Lexer::object;
32             use WebDAO::Lexer::regclass;
33             use WebDAO::Lexer::text;
34              
35              
36             __PACKAGE__->mk_attr( __tmpl__ => '' );
37              
38             sub new {
39             my $class = shift;
40             my $self = bless( $#_ == 0 ? {shift} : {@_}, ref($class) || $class );
41             $self
42              
43             }
44              
45             sub _parsed_template_ {
46             my $self = shift;
47             my $eng = shift;
48             my @res;
49             foreach ( @{ $self->split_template( shift || $self->__tmpl__ ) } ) {
50             my $res = ref($_) ? $self->buld_tree($$_) : [];
51             push @res, $res;
52             }
53             return \@res;
54             }
55              
56             =head2 split_template
57              
58             Return [ $pre_part, $main_html, $post_part ]
59              
60             =cut
61              
62             sub split_template {
63             my $self = shift;
64             my $txt = shift || return [ undef, undef, undef ];
65             my @parts = split( m%<!--\s*\<\/?wd:fetch>\s*-->%, $txt );
66             return [ undef, $parts[0], undef ] if scalar(@parts) == 1;
67             return [ @parts, undef ] if scalar(@parts) == 2;
68             \@parts;
69             }
70              
71             sub value {
72             my $self = shift;
73             my $eng = shift;
74             my $content = $self->{tmpl};
75             my @res;
76             foreach ( @{ $self->split_template($content) } ) {
77             my $res = $_ ? $self->buld_tree( $eng, $_ ) : [];
78             push @res, $res;
79             }
80             return \@res;
81             }
82              
83             sub parse {
84             my $self = shift;
85             my $txt = shift || return [];
86             my %classmap = (
87             object => 'WebDAO::Lexer::object',
88             regclass => 'WebDAO::Lexer::regclass',
89             objectref => 'WebDAO::Lexer::objectref',
90             text => 'WebDAO::Lexer::text',
91             include => 'WebDAO::Lexer::include',
92             default => 'WebDAO::Lexer::base',
93             method => 'WebDAO::Lexer::method'
94             );
95             our $result = [];
96             my %tags = (
97             wd => sub { shift; $result = \@_ },
98             '*' => sub {
99             my $name = shift;
100             my $a = shift;
101             my $childs = \@_;
102             my $class = $classmap{$name} || $classmap{'default'};
103             my $o = $class->new(
104             name => $name,
105             attr => $a,
106             childs => $childs
107             );
108             return $o;
109             }
110             );
111             my $rd = new XML::Flow:: \$txt;
112             $rd->read( \%tags );
113             $result;
114             }
115              
116             sub buld_tree {
117             my $self = shift;
118             my $eng = shift;
119             my $raw_html = shift || return [];
120              
121             #Mac and DOS line endings
122             $raw_html =~ s/\r\n?/\n/g;
123             my $mass;
124             $mass = [ split( /(\<WD>.*?<\/WD>)/is, $raw_html ) ];
125             my @res;
126             foreach my $text (@$mass) {
127             my @ref;
128             unless ( $text =~ /^<wd/i ) {
129             push @ref,
130             WebDAO::Lexer::object->new(
131             attr=>{
132             class=>'_rawhtml_element',
133             'id'=>'none'
134             },
135             'childs' =>
136             [ WebDAO::Lexer::text->new( value => \$text ) ],
137             )->value($eng)
138             unless $text =~ /^\s*$/;
139             }
140             else {
141             my $tree = $self->parse($text);
142             foreach my $o (@$tree) {
143             my $res = $o->value($eng);
144             push @ref, $res if defined $res;
145             }
146             }
147             next unless @ref;
148             push @res, @ref;
149             }
150             return \@res;
151             }
152             1;
153             __DATA__
154              
155             =head1 SEE ALSO
156              
157             http://webdao.sourceforge.net
158              
159             =head1 AUTHOR
160              
161             Zahatski Aliaksandr, E<lt>zag@cpan.orgE<gt>
162              
163             =head1 COPYRIGHT AND LICENSE
164              
165             Copyright 2002-2011 by Zahatski Aliaksandr
166              
167             This library is free software; you can redistribute it and/or modify
168             it under the same terms as Perl itself.
169              
170             =cut
171