blib/lib/Web/XDO.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 147 | 604 | 24.3 |
branch | 0 | 156 | 0.0 |
condition | 0 | 24 | 0.0 |
subroutine | 49 | 93 | 52.6 |
pod | 10 | 10 | 100.0 |
total | 206 | 887 | 23.2 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Web::XDO; | ||||||
2 | 1 | 1 | 1375 | use strict; | |||
1 | 3 | ||||||
1 | 34 | ||||||
3 | 1 | 1 | 4196 | use CGI; | |||
1 | 20927 | ||||||
1 | 7 | ||||||
4 | 1 | 1 | 942 | use URI::URL; | |||
1 | 10569 | ||||||
1 | 57 | ||||||
5 | 1 | 1 | 1033 | use String::Util ':all'; | |||
1 | 4095 | ||||||
1 | 3069 | ||||||
6 | |||||||
7 | # debug tools | ||||||
8 | # use Debug::ShowStuff ':all'; | ||||||
9 | # use Debug::ShowStuff::ShowVar; | ||||||
10 | |||||||
11 | # VERSION | ||||||
12 | our $VERSION = '0.11'; | ||||||
13 | |||||||
14 | |||||||
15 | =head1 NAME | ||||||
16 | |||||||
17 | Web::XDO -- static web site tool | ||||||
18 | |||||||
19 | =head1 SYNOPSIS | ||||||
20 | |||||||
21 | #!/usr/bin/perl -wT | ||||||
22 | use strict; | ||||||
23 | use Web::XDO; | ||||||
24 | |||||||
25 | # variables | ||||||
26 | my ($xdo); | ||||||
27 | |||||||
28 | # get XDO object | ||||||
29 | $xdo = Web::XDO->new(); | ||||||
30 | |||||||
31 | # custom configurations here | ||||||
32 | |||||||
33 | # output XDO page | ||||||
34 | $xdo->output(); | ||||||
35 | |||||||
36 | =head1 DESCRIPTION | ||||||
37 | |||||||
38 | XDO ("extensible document objects") is a tool for creating simple static web | ||||||
39 | sites. Full documentation for XDO is in the | ||||||
40 | L |
||||||
41 | on the internals of Web::XDO. | ||||||
42 | |||||||
43 | =head1 INSTALLATION | ||||||
44 | |||||||
45 | The module Web::XDO can be installed with the usual routine: | ||||||
46 | |||||||
47 | perl Makefile.PL | ||||||
48 | make | ||||||
49 | make test | ||||||
50 | make install | ||||||
51 | |||||||
52 | After you install Web::XDO you should check out the | ||||||
53 | L |
||||||
54 | for the remaining steps. | ||||||
55 | |||||||
56 | =head1 OVERVIEW | ||||||
57 | |||||||
58 | Web::XDO is called from a Perl CGI script that you write. The script should | ||||||
59 | look something like this: | ||||||
60 | |||||||
61 | #!/usr/bin/perl -wT | ||||||
62 | use strict; | ||||||
63 | use Web::XDO; | ||||||
64 | |||||||
65 | # variables | ||||||
66 | my ($xdo); | ||||||
67 | |||||||
68 | # get XDO object | ||||||
69 | $xdo = Web::XDO->new(); | ||||||
70 | |||||||
71 | # custom configurations here | ||||||
72 | |||||||
73 | # output XDO page | ||||||
74 | $xdo->output(); | ||||||
75 | |||||||
76 | The $xdo object does all the work or creating a CGI object, parsing and | ||||||
77 | processing the contents of the .xdo page, and outputing the results. This POD | ||||||
78 | page documents thos internals. | ||||||
79 | |||||||
80 | =head1 CLASSES | ||||||
81 | |||||||
82 | =head2 Web::XDO | ||||||
83 | |||||||
84 | =cut | ||||||
85 | |||||||
86 | #------------------------------------------------------------------------------ | ||||||
87 | # new | ||||||
88 | # | ||||||
89 | |||||||
90 | =head3 Web::XDO->new() | ||||||
91 | |||||||
92 | Web::XDO->new() creates a new Web::XDO object. It takes no parameters or | ||||||
93 | options. | ||||||
94 | |||||||
95 | # get XDO object | ||||||
96 | $xdo = Web::XDO->new(); | ||||||
97 | |||||||
98 | =cut | ||||||
99 | |||||||
100 | sub new { | ||||||
101 | 0 | 0 | 1 | my ($class) = @_; | |||
102 | 0 | my $xdo = bless {}, $class; | |||||
103 | |||||||
104 | # TESTING | ||||||
105 | # println $class, '->new()'; ##i | ||||||
106 | |||||||
107 | # build and untaint document root | ||||||
108 | # NOTE: I'm not real satisfied with this technique for getting the document | ||||||
109 | # root. It's based on an environment variable (i.e. external data) and the | ||||||
110 | # only security check is to make sure the directory really exists. If | ||||||
111 | # someone could find a way to change $ENV{'DOCUMENT_ROOT'} to, say, /etc | ||||||
112 | # then they could easily read /etc/passwd. For now using this technique | ||||||
113 | # because I can't think of a better way to get the document root. | ||||||
114 | 0 | $xdo->{'document_root'} = $ENV{'DOCUMENT_ROOT'}; | |||||
115 | |||||||
116 | # make sure document root really exists | ||||||
117 | 0 | 0 | 0 | unless (-r($xdo->{'document_root'}) && -d($xdo->{'document_root'})) { | |||
118 | 0 | die "do not find document root $xdo->{'document_root'}"; | |||||
119 | } | ||||||
120 | |||||||
121 | # clean up document root a little | ||||||
122 | 0 | $xdo->{'document_root'} =~ s|/*$||s; | |||||
123 | |||||||
124 | # initialize some other properties | ||||||
125 | 0 | $xdo->{'nested'} = {}; | |||||
126 | 0 | $xdo->{'cgi'} = CGI->new(); | |||||
127 | 0 | $xdo->{'cgi_params'} = {}; | |||||
128 | |||||||
129 | # root of XDO document set | ||||||
130 | # default to / | ||||||
131 | 0 | $xdo->{'root'} = '/'; | |||||
132 | |||||||
133 | # file name of directory index file | ||||||
134 | # defaults to index.xdo | ||||||
135 | 0 | $xdo->{'directory_index'} = 'index.xdo'; | |||||
136 | |||||||
137 | # set tag definitions | ||||||
138 | 0 | $xdo->initial_tag_defs(); | |||||
139 | |||||||
140 | # TESTING | ||||||
141 | # showcgi($xdo->{'cgi'}); | ||||||
142 | |||||||
143 | # return | ||||||
144 | 0 | return $xdo; | |||||
145 | } | ||||||
146 | # | ||||||
147 | # new | ||||||
148 | #------------------------------------------------------------------------------ | ||||||
149 | |||||||
150 | |||||||
151 | #------------------------------------------------------------------------------ | ||||||
152 | # initial_tag_defs | ||||||
153 | # | ||||||
154 | |||||||
155 | =head3 $xdo->initial_tag_defs() | ||||||
156 | |||||||
157 | initial_tag_defs() is a private method that defines the default behavior of | ||||||
158 | XDO and HTML tags. In subsequent releases the hash of tag definitions will be | ||||||
159 | configurable. | ||||||
160 | |||||||
161 | =cut | ||||||
162 | |||||||
163 | sub initial_tag_defs { | ||||||
164 | 0 | 0 | 1 | my ($xdo) = @_; | |||
165 | 0 | my ($classes, $tags); | |||||
166 | |||||||
167 | # TESTING | ||||||
168 | # println '$xdo->initial_tag_defs()'; ##i | ||||||
169 | |||||||
170 | # initialize tag definitions | ||||||
171 | 0 | $tags = $xdo->{'tags'} = {}; | |||||
172 | |||||||
173 | # convenience: get tag classes hash | ||||||
174 | 0 | $classes = \%Web::XDO::Token::Tag::tag_classes; | |||||
175 | |||||||
176 | # loop through tag definitions | ||||||
177 | TAG_LOOP: | ||||||
178 | 0 | foreach my $tag_name (keys %$classes) { | |||||
179 | 0 | my ($def); | |||||
180 | |||||||
181 | # get definition | ||||||
182 | 0 | $def = $classes->{$tag_name}; | |||||
183 | |||||||
184 | # if definition isn't a hash, make it one | ||||||
185 | 0 | 0 | unless (UNIVERSAL::isa $def, 'HASH') { | ||||
186 | 0 | $def = {class=>$def}; | |||||
187 | } | ||||||
188 | |||||||
189 | # hold on to definition | ||||||
190 | 0 | $tags->{$tag_name} = $def; | |||||
191 | } | ||||||
192 | |||||||
193 | # add some default definitions for adjust root attributes | ||||||
194 | # Yes, these definitions include some pretty ancient tags. Go with it. | ||||||
195 | 0 | $tags->{'img'} = {adjust_for_root => [qw{src lowsrc}] }; | |||||
196 | 0 | $tags->{'link'} = {adjust_for_root => [qw{href}] }; | |||||
197 | 0 | $tags->{'applet'} = {adjust_for_root => [qw{code codebase}] }; | |||||
198 | 0 | $tags->{'base'} = {adjust_for_root => [qw{href}] }; | |||||
199 | 0 | $tags->{'bgsound'} = {adjust_for_root => [qw{href}] }; | |||||
200 | 0 | $tags->{'body'} = {adjust_for_root => [qw{background}] }; | |||||
201 | 0 | $tags->{'embed'} = {adjust_for_root => [qw{src pluginspage pluginurl href}] }; | |||||
202 | 0 | $tags->{'form'} = {adjust_for_root => [qw{action}] }; | |||||
203 | 0 | $tags->{'frame'} = {adjust_for_root => [qw{src}] }; | |||||
204 | 0 | $tags->{'iframe'} = {adjust_for_root => [qw{src}] }; | |||||
205 | 0 | $tags->{'input'} = {adjust_for_root => [qw{src lowsrc}] }; | |||||
206 | 0 | $tags->{'script'} = {adjust_for_root => [qw{src}] }; | |||||
207 | 0 | $tags->{'table'} = {adjust_for_root => [qw{background}] }; | |||||
208 | 0 | $tags->{'tr'} = {adjust_for_root => [qw{background}] }; | |||||
209 | 0 | $tags->{'td'} = {adjust_for_root => [qw{background}] }; | |||||
210 | 0 | $tags->{'th'} = {adjust_for_root => [qw{background}] }; | |||||
211 | } | ||||||
212 | # | ||||||
213 | # initial_tag_defs | ||||||
214 | #------------------------------------------------------------------------------ | ||||||
215 | |||||||
216 | |||||||
217 | #------------------------------------------------------------------------------ | ||||||
218 | # output | ||||||
219 | # | ||||||
220 | |||||||
221 | =head3 $xdo->output() | ||||||
222 | |||||||
223 | output() outputs the requested XDO page. It take no params or options. | ||||||
224 | |||||||
225 | =cut | ||||||
226 | |||||||
227 | sub output { | ||||||
228 | 0 | 0 | 1 | my ($xdo, %opts) = @_; | |||
229 | 0 | my ($cgi, $top, $xdo_class, $request_path, $page_class); | |||||
230 | |||||||
231 | # TESTING | ||||||
232 | # println '$xdo->output()'; ##i | ||||||
233 | |||||||
234 | # get cgi | ||||||
235 | 0 | $cgi = $xdo->{'cgi'}; | |||||
236 | |||||||
237 | # get request path | ||||||
238 | 0 | $request_path = $cgi->param('p'); | |||||
239 | |||||||
240 | # if no cgi param, throw 400 | ||||||
241 | 0 | 0 | if (! hascontent $request_path) { | ||||
242 | 0 | my ($this_page); | |||||
243 | |||||||
244 | # get file name of this page | ||||||
245 | 0 | $this_page = $0; | |||||
246 | 0 | $this_page =~ s|^.*/||s; | |||||
247 | 0 | $this_page = htmlesc($this_page); | |||||
248 | |||||||
249 | # HTTP header | ||||||
250 | 0 | print $cgi->header(-status=>400); | |||||
251 | |||||||
252 | # page | ||||||
253 | 0 | print <<"(HTML)"; | |||||
254 | |||||||
255 | |||||||
256 | |
||||||
257 | |||||||
258 | |||||||
259 | 400 Bad request |
||||||
260 | The XDO script $this_page |
||||||
261 | is working, but the p param was not sent. |
||||||
262 | |||||||
263 | |||||||
264 | (HTML) | ||||||
265 | |||||||
266 | # we're done | ||||||
267 | 0 | exit 0; | |||||
268 | } | ||||||
269 | |||||||
270 | # if $xdo isn't an object, assume it's a class and instantiate that class | ||||||
271 | 0 | 0 | if (ref $xdo) { | ||||
272 | 0 | $xdo_class = ref($xdo); | |||||
273 | } | ||||||
274 | else { | ||||||
275 | 0 | $xdo_class = $xdo; | |||||
276 | 0 | $xdo = $xdo->new(%opts); | |||||
277 | } | ||||||
278 | |||||||
279 | # instantiate top page object | ||||||
280 | 0 | $page_class = $xdo->page_class(); | |||||
281 | 0 | $top = $page_class->new('/', $request_path, $xdo); | |||||
282 | 0 | 0 | $top or $xdo->status_404(); | ||||
283 | |||||||
284 | # note top as top | ||||||
285 | 0 | $top->{'top'} = 1; | |||||
286 | |||||||
287 | # output headers | ||||||
288 | 0 | print "content-type: text/html\n\n"; | |||||
289 | |||||||
290 | # show source if allowed and requested, else output page | ||||||
291 | 0 | 0 | unless ($xdo->show_src($top)) { | ||||
292 | 0 | $top->output(); | |||||
293 | } | ||||||
294 | } | ||||||
295 | # | ||||||
296 | # output | ||||||
297 | #------------------------------------------------------------------------------ | ||||||
298 | |||||||
299 | |||||||
300 | #------------------------------------------------------------------------------ | ||||||
301 | # show_src | ||||||
302 | # | ||||||
303 | |||||||
304 | =head3 $xdo->show_src() | ||||||
305 | |||||||
306 | show_src() is a private method that handles showing the XDO code when the | ||||||
307 | L |
||||||
308 | is sent. | ||||||
309 | |||||||
310 | =cut | ||||||
311 | |||||||
312 | sub show_src { | ||||||
313 | 0 | 0 | 1 | my ($xdo, $top) = @_; | |||
314 | 0 | my ($src_param, $src, $tokens, $file_name, $tags); | |||||
315 | |||||||
316 | # TESTING | ||||||
317 | # println '$xdo->show_src()'; ##i | ||||||
318 | |||||||
319 | # get name of show src param | ||||||
320 | 0 | $src_param = $xdo->{'src'}; | |||||
321 | 0 | 0 | defined($src_param) or return 0; | ||||
322 | |||||||
323 | # get src param | ||||||
324 | 0 | $src = $xdo->{'cgi'}->param($src_param); | |||||
325 | 0 | 0 | $src or return 0; | ||||
326 | |||||||
327 | # get name of requested page | ||||||
328 | 0 | $file_name = $ENV{'REDIRECT_URL'}; | |||||
329 | |||||||
330 | # parse out just file name | ||||||
331 | 0 | 0 | if (defined $file_name) { | ||||
332 | 0 | $file_name =~ s|^.*/||s; | |||||
333 | 0 | $file_name = htmlesc($file_name ); | |||||
334 | } | ||||||
335 | else { | ||||||
336 | 0 | $file_name = 'this page'; | |||||
337 | } | ||||||
338 | |||||||
339 | # get token array | ||||||
340 | 0 | $tokens = $top->{'tokens'}; | |||||
341 | |||||||
342 | # get hash of tag definitions | ||||||
343 | 0 | $tags = $xdo->{'tags'}; | |||||
344 | |||||||
345 | # open page | ||||||
346 | 0 | print <<"(HTML)"; | |||||
347 | |||||||
348 | |||||||
349 | |
||||||
350 | |||||||
368 | |||||||
369 | |||||||
370 | XDO source for $file_name |
||||||
371 | |
||||||
372 | (HTML) | ||||||
373 | |||||||
374 | # loop through tokens | ||||||
375 | 0 | foreach my $token (@$tokens) { | |||||
376 | 0 | my ($em); | |||||
377 | |||||||
378 | # if this is an XDO-significant tag, wrap the output element | ||||||
379 | # in | ||||||
380 | 0 | 0 | if ($xdo->xdo_significant_tag($token)) { | ||||
381 | 0 | print ''; | |||||
382 | 0 | $em = 1; | |||||
383 | } | ||||||
384 | |||||||
385 | # output raw tag code | ||||||
386 | 0 | print htmlesc($token->{'raw'}); | |||||
387 | |||||||
388 | # close if necessary | ||||||
389 | 0 | 0 | $em and print ''; | ||||
390 | } | ||||||
391 | |||||||
392 | 0 | print <<"(HTML)"; | |||||
393 | |||||||
394 | |||||||
395 | |||||||
396 | (HTML) | ||||||
397 | |||||||
398 | 0 | return 1; | |||||
399 | } | ||||||
400 | # | ||||||
401 | # show_src | ||||||
402 | #------------------------------------------------------------------------------ | ||||||
403 | |||||||
404 | |||||||
405 | #------------------------------------------------------------------------------ | ||||||
406 | # xdo_significant_tag | ||||||
407 | # | ||||||
408 | |||||||
409 | =head3 $xdo->xdo_significant_tag($token) | ||||||
410 | |||||||
411 | xdo_significant_tag() is a private method that returns true if the given token | ||||||
412 | is specially processed by XDO, as opposed to output as-is for tags that aren't | ||||||
413 | significant. So, for example, an | ||||||
414 | L |
||||||
415 | E |
||||||
416 | |||||||
417 | =cut | ||||||
418 | |||||||
419 | sub xdo_significant_tag { | ||||||
420 | 0 | 0 | 1 | my ($xdo, $token) = @_; | |||
421 | |||||||
422 | # if not a tag or endtag, we're done | ||||||
423 | 0 | 0 | 0 | unless ( | |||
424 | UNIVERSAL::isa($token, 'Web::XDO::Token::Tag') || | ||||||
425 | UNIVERSAL::isa($token, 'Web::XDO::Token::EndTag') | ||||||
426 | ) { | ||||||
427 | 0 | return 0; | |||||
428 | } | ||||||
429 | |||||||
430 | # if this ia an XDO significant tag | ||||||
431 | 0 | 0 | if (my $def = $xdo->{'tags'}->{$token->{'name'}}) { | ||||
432 | 0 | 0 | if ($def->{'class'}) { | ||||
433 | 0 | 0 | 0 | unless ( | |||
434 | ($def->{'class'} eq 'Web::XDO::Token::Tag') || | ||||||
435 | ($def->{'class'} eq 'Web::XDO::Token::EndTag') | ||||||
436 | ) { | ||||||
437 | 0 | return 1; | |||||
438 | } | ||||||
439 | } | ||||||
440 | } | ||||||
441 | |||||||
442 | # else return 0 | ||||||
443 | 0 | return 0; | |||||
444 | } | ||||||
445 | # | ||||||
446 | # xdo_significant_tag | ||||||
447 | #------------------------------------------------------------------------------ | ||||||
448 | |||||||
449 | |||||||
450 | #------------------------------------------------------------------------------ | ||||||
451 | # page_class | ||||||
452 | # | ||||||
453 | |||||||
454 | =head3 $xdo->page_class() | ||||||
455 | |||||||
456 | page_class() returns the class name for an object representing an XDO page. | ||||||
457 | Right now page_class() always returns Web::XDO::Page. In susequent releases | ||||||
458 | this method will allow coders to create custom classes for different types | ||||||
459 | of pages. I haven't worked out the details on how that's going to work. | ||||||
460 | |||||||
461 | =cut | ||||||
462 | |||||||
463 | sub page_class { | ||||||
464 | 0 | 0 | 1 | return 'Web::XDO::Page'; | |||
465 | } | ||||||
466 | |||||||
467 | # | ||||||
468 | # page_class | ||||||
469 | #------------------------------------------------------------------------------ | ||||||
470 | |||||||
471 | |||||||
472 | #------------------------------------------------------------------------------ | ||||||
473 | # default_tag_class | ||||||
474 | # | ||||||
475 | |||||||
476 | =head3 $xdo->default_tag_class() | ||||||
477 | |||||||
478 | default_tag_class() returns the tag class used for tags that are not recognized | ||||||
479 | by XDO. In subsequent releases programmers will be able to override Web::XDO | ||||||
480 | and have this method return their own custom tag class. | ||||||
481 | |||||||
482 | =cut | ||||||
483 | |||||||
484 | sub default_tag_class { | ||||||
485 | 0 | 0 | 1 | return 'Web::XDO::Token::Tag'; | |||
486 | } | ||||||
487 | # | ||||||
488 | # default_tag_class | ||||||
489 | #------------------------------------------------------------------------------ | ||||||
490 | |||||||
491 | |||||||
492 | #------------------------------------------------------------------------------ | ||||||
493 | # status_404 | ||||||
494 | # | ||||||
495 | |||||||
496 | =head3 $xdo->status_404() | ||||||
497 | |||||||
498 | status_404() outputs a "404 Not Found" page and exits. This method is called | ||||||
499 | when the requested XDO page is not found. | ||||||
500 | |||||||
501 | =cut | ||||||
502 | |||||||
503 | sub status_404 { | ||||||
504 | 0 | 0 | 1 | my ($xdo) = @_; | |||
505 | 0 | my ($cgi); | |||||
506 | |||||||
507 | # TESTING | ||||||
508 | # println ref($page), '->status_404'; ##i | ||||||
509 | |||||||
510 | # get cgi | ||||||
511 | 0 | 0 | 0 | if ($xdo && $xdo->{'cgi'}) | |||
512 | 0 | { $cgi = $xdo->{'cgi'} } | |||||
513 | else | ||||||
514 | 0 | { $cgi = CGI->new } | |||||
515 | |||||||
516 | # 404 header | ||||||
517 | 0 | print $cgi->header(-status=>404); | |||||
518 | |||||||
519 | # message | ||||||
520 | 0 | ||||||
521 | qq|404 Not Found\n|, |
||||||
522 | " The requested URL ", |
||||||
523 | htmlesc($cgi->param('p')), | ||||||
524 | " was not found on this server.\n"; | ||||||
525 | |||||||
526 | # exit | ||||||
527 | 0 | exit 0; | |||||
528 | } | ||||||
529 | # | ||||||
530 | # status_404 | ||||||
531 | #------------------------------------------------------------------------------ | ||||||
532 | |||||||
533 | |||||||
534 | #------------------------------------------------------------------------------ | ||||||
535 | # adjust_url_for_root | ||||||
536 | # | ||||||
537 | |||||||
538 | =head3 $xdo->adjust_url_for_root($url) | ||||||
539 | |||||||
540 | adjust_url_for_root() is an internal method that removes | ||||||
541 | L |
||||||
542 | from the beginning of a URL and substitutes in the value of | ||||||
543 | L<$xdo-E |
||||||
544 | Care is taken in this method to ensure that a single / is put between | ||||||
545 | E |
||||||
546 | |||||||
547 | =cut | ||||||
548 | |||||||
549 | sub adjust_url_for_root { | ||||||
550 | 0 | 0 | 1 | my ($xdo, $url) = @_; | |||
551 | 0 | my ($root); | |||||
552 | |||||||
553 | # TESTING | ||||||
554 | # println ref($xdo), '->adjust_url_for_root(', $url,')'; ##i | ||||||
555 | |||||||
556 | # if url doesn't start with |
||||||
557 | 0 | 0 | unless ($url =~ s|\s*\<\s*xdo\-root\s*\>\s*||si) { | ||||
558 | 0 | return $url; | |||||
559 | } | ||||||
560 | |||||||
561 | # remove leading / in sent url | ||||||
562 | 0 | $url =~ s|^\/+||s; | |||||
563 | |||||||
564 | # remove trailing / from xdo root | ||||||
565 | 0 | $root = $xdo->{'root'}; | |||||
566 | 0 | $root =~ s|\/+$||s; | |||||
567 | |||||||
568 | # set final url | ||||||
569 | 0 | $url = "$root/$url"; | |||||
570 | |||||||
571 | # return | ||||||
572 | 0 | return $url; | |||||
573 | } | ||||||
574 | # | ||||||
575 | # adjust_url_for_root | ||||||
576 | #------------------------------------------------------------------------------ | ||||||
577 | |||||||
578 | |||||||
579 | #------------------------------------------------------------------------------ | ||||||
580 | # tag_class | ||||||
581 | # | ||||||
582 | |||||||
583 | =head3 $xdo->tag_class() | ||||||
584 | |||||||
585 | tag_class() is an internal method for determining the class name for a given | ||||||
586 | tag name. If the tag is defined in | ||||||
587 | L<$xdo-E |
||||||
588 | then that name is returned, | ||||||
589 | otherwise the value of | ||||||
590 | L<$xdo-E |
||||||
591 | is returned. | ||||||
592 | |||||||
593 | In subsequent programmers will be able to superclass Web::XDO and override | ||||||
594 | this method to use their own routines for determining tag class. | ||||||
595 | |||||||
596 | =cut | ||||||
597 | |||||||
598 | sub tag_class { | ||||||
599 | 0 | 0 | 1 | my ($xdo, $tag_name) = @_; | |||
600 | |||||||
601 | # get tag class from tags hash | ||||||
602 | 0 | 0 | 0 | if ($xdo->{'tags'}->{$tag_name} && $xdo->{'tags'}->{$tag_name}->{'class'}) { | |||
603 | 0 | return $xdo->{'tags'}->{$tag_name}->{'class'}; | |||||
604 | } | ||||||
605 | else { | ||||||
606 | 0 | return $xdo->default_tag_class; | |||||
607 | } | ||||||
608 | } | ||||||
609 | # | ||||||
610 | # tag_class | ||||||
611 | #------------------------------------------------------------------------------ | ||||||
612 | |||||||
613 | |||||||
614 | |||||||
615 | ############################################################################### | ||||||
616 | # Web::XDO::Page | ||||||
617 | # | ||||||
618 | package Web::XDO::Page; | ||||||
619 | 1 | 1 | 13 | use strict; | |||
1 | 2 | ||||||
1 | 53 | ||||||
620 | 1 | 1 | 6 | use String::Util ':all'; | |||
1 | 1 | ||||||
1 | 577 | ||||||
621 | 1 | 1 | 2113 | use FileHandle; | |||
1 | 19404 | ||||||
1 | 7 | ||||||
622 | 1 | 1 | 763 | use Carp 'croak'; | |||
1 | 2 | ||||||
1 | 56 | ||||||
623 | |||||||
624 | # subclass HTML::Parser | ||||||
625 | 1 | 1 | 5 | use base 'HTML::Parser'; | |||
1 | 3 | ||||||
1 | 1924 | ||||||
626 | |||||||
627 | # debug tools | ||||||
628 | # use Debug::ShowStuff ':all'; | ||||||
629 | |||||||
630 | =head2 Web::XDO::Page | ||||||
631 | |||||||
632 | A Web::XDO::Page object represents a single XDO file. When an XDO page is | ||||||
633 | requested, the corresponding XDO file is parsed into a Web::XDO::Page | ||||||
634 | object. Each page that object includes is itself parsed into a Web::XDO::Page | ||||||
635 | object. | ||||||
636 | |||||||
637 | Web::XDO::Page superclasses | ||||||
638 | L |
||||||
639 | file is parsed as part of Web::XDO::Page-E |
||||||
640 | |||||||
641 | =cut | ||||||
642 | |||||||
643 | |||||||
644 | #------------------------------------------------------------------------------ | ||||||
645 | # new | ||||||
646 | # | ||||||
647 | |||||||
648 | =head3 Web::XDO::Page->new() | ||||||
649 | |||||||
650 | Web::XDO::Page->new() takes four parameters plus one optional parameter: | ||||||
651 | |||||||
652 | =over 1 | ||||||
653 | |||||||
654 | =item * | ||||||
655 | |||||||
656 | $class: The name of the page class. For this release it's always | ||||||
657 | "Web::XDO::Page". | ||||||
658 | |||||||
659 | =item * | ||||||
660 | |||||||
661 | $url_root: The base page against which an absoulte URL path should be | ||||||
662 | calculated from $url_rel_path. Yes, this variable should actually be called | ||||||
663 | $url_base. That will be fixed in subsequent releases. | ||||||
664 | |||||||
665 | =item * | ||||||
666 | |||||||
667 | $url_rel_path: The relative URL path from $url_root. | ||||||
668 | |||||||
669 | =item * | ||||||
670 | |||||||
671 | $xdo: The Web::XDO object that is handling the entire process. | ||||||
672 | |||||||
673 | =item * | ||||||
674 | |||||||
675 | caller=>$page | ||||||
676 | |||||||
677 | If a page is being included in another page then the included page needs to | ||||||
678 | know its "caller" page. That information is set with the caller option. So, | ||||||
679 | for example, the L |
||||||
680 | creates the included page object with a call like this: | ||||||
681 | |||||||
682 | $included = $xdo->page_class->new($url_base, $atts->{'src'}, $xdo, 'caller'=>$caller); | ||||||
683 | |||||||
684 | If a caller is sent then that object is stored in the included page in the | ||||||
685 | $page->{'caller'} property. | ||||||
686 | |||||||
687 | =back | ||||||
688 | |||||||
689 | =cut | ||||||
690 | |||||||
691 | sub new { | ||||||
692 | 0 | 0 | my ($class, $url_root, $url_rel_path, $xdo, %opts) = @_; | ||||
693 | 0 | my ($tokens, $token_idx, $page); | |||||
694 | |||||||
695 | # TESTING | ||||||
696 | # println $class, '->new()'; ##i | ||||||
697 | |||||||
698 | # create page object | ||||||
699 | 0 | $page = $class->SUPER::new(); | |||||
700 | |||||||
701 | # don't recognize cdata tags | ||||||
702 | 0 | $page->xml_mode(1); | |||||
703 | |||||||
704 | # must either designate a caller or explicitly set as top page | ||||||
705 | 0 | 0 | if (my $caller = $opts{'caller'}) { | ||||
706 | 0 | 0 | if (UNIVERSAL::isa($caller, 'Web::XDO::Page')) { | ||||
707 | 0 | $page->{'caller'} = $caller; | |||||
708 | } | ||||||
709 | else { | ||||||
710 | 0 | croak q|caller is not a page object|; | |||||
711 | } | ||||||
712 | } | ||||||
713 | else { | ||||||
714 | 0 | $page->{'props'} = {}; | |||||
715 | } | ||||||
716 | |||||||
717 | # hold on to xdo object | ||||||
718 | 0 | $page->{'xdo'} = $xdo; | |||||
719 | |||||||
720 | # build path to file | ||||||
721 | 0 | 0 | $page->set_paths($url_root, $url_rel_path) or return 0; | ||||
722 | |||||||
723 | # initialize token array | ||||||
724 | 0 | $tokens = $page->{'tokens'} = []; | |||||
725 | |||||||
726 | # parse | ||||||
727 | 0 | $page->parse_file("$page->{'local_path'}"); | |||||
728 | |||||||
729 | # initialize $token_idx to 0 | ||||||
730 | 0 | $token_idx = 0; | |||||
731 | |||||||
732 | # set page properties | ||||||
733 | # NOTE: This rather odd construction for iterating through the tokens is | ||||||
734 | # based on the fact that set_page_prop tokens are removed from the token | ||||||
735 | # array, and they might remove other tokens after them. Therefore the | ||||||
736 | # length of the array can change during the loop. | ||||||
737 | 0 | while ($token_idx < @$tokens) { | |||||
738 | 0 | my $token = $tokens->[$token_idx]; | |||||
739 | |||||||
740 | 0 | 0 | if (UNIVERSAL::isa($token, 'Web::XDO::Token::Tag')) { | ||||
741 | 0 | 0 | if (UNIVERSAL::can($token, 'set_page_prop')) { | ||||
742 | 0 | $token->set_page_prop($page, $token_idx); | |||||
743 | } | ||||||
744 | } | ||||||
745 | |||||||
746 | # increment to next token | ||||||
747 | 0 | $token_idx++; | |||||
748 | } | ||||||
749 | |||||||
750 | # return | ||||||
751 | 0 | return $page; | |||||
752 | } | ||||||
753 | # | ||||||
754 | # new | ||||||
755 | #------------------------------------------------------------------------------ | ||||||
756 | |||||||
757 | |||||||
758 | #------------------------------------------------------------------------------ | ||||||
759 | # top | ||||||
760 | # | ||||||
761 | |||||||
762 | =head3 $page->top() | ||||||
763 | |||||||
764 | This method returns the top page in the hierarchy of included pages. If a | ||||||
765 | Web::XDO::Page object is created with the 'caller' option (which means the | ||||||
766 | caller page is stored in $page->{'caller'}), then the page's caller's | ||||||
767 | top() method is called and returned. The top() method is called recursively | ||||||
768 | up the hierarchy until the top page (which has no caller) is reached. The top | ||||||
769 | page returns itself and that result is returned back down the hierarchy to page | ||||||
770 | that initiated the routine. | ||||||
771 | |||||||
772 | =cut | ||||||
773 | |||||||
774 | sub top { | ||||||
775 | 0 | 0 | my ($page) = @_; | ||||
776 | |||||||
777 | # if there is a caller, return that page's top() | ||||||
778 | 0 | 0 | if ($page->{'caller'}) | ||||
779 | 0 | { return $page->{'caller'}->top } | |||||
780 | |||||||
781 | # else this page is the top | ||||||
782 | 0 | return $page; | |||||
783 | } | ||||||
784 | # | ||||||
785 | # top | ||||||
786 | #------------------------------------------------------------------------------ | ||||||
787 | |||||||
788 | |||||||
789 | #------------------------------------------------------------------------------ | ||||||
790 | # top_props | ||||||
791 | # | ||||||
792 | |||||||
793 | =head3 $page->top_props() | ||||||
794 | |||||||
795 | Returns the top page's {'props'} hash. Only the top page should have a | ||||||
796 | {'props'} hash and only properties in that hash should be set. | ||||||
797 | |||||||
798 | =cut | ||||||
799 | |||||||
800 | sub top_props { | ||||||
801 | 0 | 0 | my ($page) = @_; | ||||
802 | 0 | return $page->top->{'props'}; | |||||
803 | } | ||||||
804 | # | ||||||
805 | # top_props | ||||||
806 | #------------------------------------------------------------------------------ | ||||||
807 | |||||||
808 | |||||||
809 | #------------------------------------------------------------------------------ | ||||||
810 | # set_paths | ||||||
811 | # | ||||||
812 | |||||||
813 | =head3 $page->set_paths($url_root, $url_rel_path) | ||||||
814 | |||||||
815 | This internal method sets the page's url_path property to an absolute path. | ||||||
816 | The absolute path is calculated using the $url_root and $url_rel_path | ||||||
817 | params. The final result is put into the $page-E |
||||||
818 | |||||||
819 | I |
||||||
820 | the document root. A particular concern is for someone to send a request | ||||||
821 | directly to xdo.pl with something like this: | ||||||
822 | |||||||
823 | xdo.pl?p=../../../../../etc/passwd | ||||||
824 | |||||||
825 | If set_paths() doesn't properly filter the request then such a request could | ||||||
826 | return unauthorized files. | ||||||
827 | |||||||
828 | =cut | ||||||
829 | |||||||
830 | sub set_paths { | ||||||
831 | 0 | 0 | my ($page, $url_root, $url_rel_path) = @_; | ||||
832 | 0 | my ($doc_root_rx); | |||||
833 | |||||||
834 | # TESTING | ||||||
835 | # println ref($page), '->set_paths'; ##i | ||||||
836 | |||||||
837 | # build url path | ||||||
838 | # stringify URI object | ||||||
839 | 0 | $page->{'url_path'} = URI->new_abs($url_rel_path, $url_root); | |||||
840 | |||||||
841 | # return false if we don't get a URI object | ||||||
842 | 0 | 0 | if (! ref($page->{'url_path'})) | ||||
843 | 0 | { return 0 } | |||||
844 | |||||||
845 | # stringify URI object | ||||||
846 | 0 | $page->{'url_path'} .= ''; | |||||
847 | |||||||
848 | # if the path contains .. then it's an invalid path, return 0 | ||||||
849 | # KLUDGE: This check is basically an attempt to filter out the | ||||||
850 | # bad instead of filtering in the good. | ||||||
851 | 0 | 0 | if ($page->{'url_path'} =~ m|\.\.|s) | ||||
852 | 0 | { return 0 } | |||||
853 | |||||||
854 | # build file path | ||||||
855 | 0 | $page->{'local_path'} = $page->{'xdo'}->{'document_root'} . $page->{'url_path'}; | |||||
856 | |||||||
857 | # if path doesn't exist, return 404 | ||||||
858 | 0 | 0 | if (! -r $page->{'local_path'}) | ||||
859 | 0 | { return 0 } | |||||
860 | |||||||
861 | # return success | ||||||
862 | 0 | return 1; | |||||
863 | } | ||||||
864 | # | ||||||
865 | # set_paths | ||||||
866 | #------------------------------------------------------------------------------ | ||||||
867 | |||||||
868 | |||||||
869 | #------------------------------------------------------------------------------ | ||||||
870 | # output | ||||||
871 | # | ||||||
872 | |||||||
873 | =head3 $page->output() | ||||||
874 | |||||||
875 | output() outputs the page. | ||||||
876 | |||||||
877 | =cut | ||||||
878 | |||||||
879 | sub output { | ||||||
880 | 0 | 0 | my ($page) = @_; | ||||
881 | 0 | my ($xdo, $nested, $local_path, $tokens, $token_idx); | |||||
882 | 0 | $token_idx = 0; | |||||
883 | |||||||
884 | # TESTING | ||||||
885 | # println $page->{'url_path'}, '->output'; ##i | ||||||
886 | |||||||
887 | # convenience objects | ||||||
888 | 0 | $xdo = $page->{'xdo'}; | |||||
889 | 0 | $nested = $xdo->{'nested'}; | |||||
890 | 0 | $local_path = $page->{'local_path'}; | |||||
891 | 0 | $tokens = $page->{'tokens'}; | |||||
892 | |||||||
893 | # check if this page has already been output | ||||||
894 | 0 | 0 | if ($nested->{$local_path}) { | ||||
895 | 0 | return 0; | |||||
896 | } | ||||||
897 | |||||||
898 | # note as output | ||||||
899 | 0 | $nested->{$local_path} = 1; | |||||
900 | |||||||
901 | # loop through tokens | ||||||
902 | 0 | while ($token_idx <= $#$tokens) { | |||||
903 | 0 | my $token = $tokens->[$token_idx]; | |||||
904 | |||||||
905 | # if object, call output method | ||||||
906 | # else just print | ||||||
907 | 0 | 0 | if (ref $token) { | ||||
908 | 0 | $token->output($page, $token_idx); | |||||
909 | } | ||||||
910 | else { | ||||||
911 | 0 | print $token; | |||||
912 | } | ||||||
913 | |||||||
914 | # increment | ||||||
915 | 0 | $token_idx++; | |||||
916 | } | ||||||
917 | |||||||
918 | # note not longer output | ||||||
919 | 0 | delete $nested->{$local_path}; | |||||
920 | } | ||||||
921 | # | ||||||
922 | # output | ||||||
923 | #------------------------------------------------------------------------------ | ||||||
924 | |||||||
925 | |||||||
926 | #------------------------------------------------------------------------------ | ||||||
927 | # start | ||||||
928 | # | ||||||
929 | |||||||
930 | =head3 $page->start() | ||||||
931 | |||||||
932 | Web::XDO::Page superclasses | ||||||
933 | L |
||||||
934 | start() handles HTML::Parser's event when a start tag is parsed. | ||||||
935 | |||||||
936 | start() creates a new tag object using the class returned by | ||||||
937 | L<$xdo-E |
||||||
938 | |||||||
939 | =cut | ||||||
940 | |||||||
941 | sub start { | ||||||
942 | 0 | 0 | my ($page, $tag_name, $atts, $att_order, $raw) = @_; | ||||
943 | 0 | my ($self_ender, $def, $token, $xdo); | |||||
944 | 0 | $xdo = $page->{'xdo'}; | |||||
945 | |||||||
946 | # TESTING | ||||||
947 | # println $tag_name, '->start'; ##i | ||||||
948 | |||||||
949 | # normalize tag name | ||||||
950 | # NOTE: We need to normalize here because the parser is in xml_mode. That | ||||||
951 | # mode is on so that content of cdata tags (specificall |
||||||
952 | # parsed. It has the side-effect that tag names are sent as they appear | ||||||
953 | # in the document being parsed. If anybody knows a more global way to send | ||||||
954 | # lowercased tag names I'll be glad to hear about it. - Miko | ||||||
955 | 0 | $tag_name = lc($tag_name); | |||||
956 | |||||||
957 | # if the tag has a trailing slash then it's a self-ender | ||||||
958 | 0 | 0 | if ($raw =~ m|/\s*\>$|s) | ||||
959 | 0 | { $self_ender = 1 } | |||||
960 | |||||||
961 | # NOTE: Funky code ahead. The following few lines take into account several | ||||||
962 | # different possibilities of how the tag definition might be structured. | ||||||
963 | # It might be: | ||||||
964 | # - a hashref with a class name | ||||||
965 | # - a hashref without a class name | ||||||
966 | # - just a class name | ||||||
967 | # | ||||||
968 | # The following code ensures that the definition is a hashref with a | ||||||
969 | # class name. | ||||||
970 | |||||||
971 | # get tag definition | ||||||
972 | 0 | 0 | $def = $page->{'xdo'}->{'tags'}->{$tag_name} || $xdo->default_tag_class(); | ||||
973 | |||||||
974 | # ensure tag definition is a hashref | ||||||
975 | 0 | 0 | ref($def) or $def = {class=>$def}; | ||||
976 | |||||||
977 | # ensure definition has a tag class | ||||||
978 | 0 | 0 | $def->{'class'} ||= $xdo->default_tag_class(); | ||||
979 | |||||||
980 | # create token object | ||||||
981 | 0 | $token = $def->{'class'}->new(); | |||||
982 | 0 | $token->{'type'} = 'tag'; | |||||
983 | 0 | $token->{'name'} = $tag_name; | |||||
984 | 0 | $token->{'atts'} = $atts; | |||||
985 | 0 | $token->{'raw'} = $raw; | |||||
986 | |||||||
987 | # note if self-ender | ||||||
988 | 0 | 0 | if ($self_ender) | ||||
989 | 0 | { $token->{'self_ender'} = 1 } | |||||
990 | |||||||
991 | # hold on to token | ||||||
992 | 0 | push @{$page->{'tokens'}}, $token; | |||||
0 | |||||||
993 | } | ||||||
994 | # | ||||||
995 | # start | ||||||
996 | #------------------------------------------------------------------------------ | ||||||
997 | |||||||
998 | |||||||
999 | |||||||
1000 | #------------------------------------------------------------------------------ | ||||||
1001 | # end | ||||||
1002 | # | ||||||
1003 | |||||||
1004 | =head3 $page->end() | ||||||
1005 | |||||||
1006 | end() handles HTML::Parser's event when an end tag is parsed. | ||||||
1007 | end() creates a new end tag object with the | ||||||
1008 | Web::XDO::Token::EndTag class. | ||||||
1009 | |||||||
1010 | =cut | ||||||
1011 | |||||||
1012 | sub end { | ||||||
1013 | 0 | 0 | my ($page, $tag_name, $raw) = @_; | ||||
1014 | 0 | my ($token); | |||||
1015 | |||||||
1016 | # normalize tag name | ||||||
1017 | # NOTE: We need to normalize here because the parser is in xml_mode. That | ||||||
1018 | # mode is on so that content of cdata tags (specificall |
||||||
1019 | # parsed. It has the side-effect that tag names are sent as they appear | ||||||
1020 | # in the document being parsed. If anybody knows a more global way to send | ||||||
1021 | # lowercased tag names I'll be glad to hear about it. - Miko | ||||||
1022 | 0 | $tag_name = lc($tag_name); | |||||
1023 | |||||||
1024 | # create token object | ||||||
1025 | 0 | $token = Web::XDO::Token::EndTag->new(); | |||||
1026 | 0 | $token->{'type'} = 'end_tag'; | |||||
1027 | 0 | $token->{'name'} = $tag_name; | |||||
1028 | 0 | $token->{'raw'} = $raw; | |||||
1029 | |||||||
1030 | # hold on to token | ||||||
1031 | 0 | push @{$page->{'tokens'}}, $token; | |||||
0 | |||||||
1032 | } | ||||||
1033 | # | ||||||
1034 | # end | ||||||
1035 | #------------------------------------------------------------------------------ | ||||||
1036 | |||||||
1037 | |||||||
1038 | |||||||
1039 | #------------------------------------------------------------------------------ | ||||||
1040 | # text | ||||||
1041 | # | ||||||
1042 | |||||||
1043 | =head3 $page->text() | ||||||
1044 | |||||||
1045 | text() handles HTML::Parser's event when an end tag is parsed. | ||||||
1046 | text() creates a new text object with the | ||||||
1047 | Web::XDO::Token::Text class. | ||||||
1048 | |||||||
1049 | =cut | ||||||
1050 | |||||||
1051 | sub text { | ||||||
1052 | 0 | 0 | my ($page, $raw) = @_; | ||||
1053 | 0 | my ($token); | |||||
1054 | |||||||
1055 | # create text object | ||||||
1056 | 0 | $token = Web::XDO::Token::Text->new(); | |||||
1057 | 0 | $token->{'type'} = 'text'; | |||||
1058 | 0 | $token->{'raw'} = $raw; | |||||
1059 | |||||||
1060 | # hold on to token | ||||||
1061 | 0 | push @{$page->{'tokens'}}, $token; | |||||
0 | |||||||
1062 | } | ||||||
1063 | # | ||||||
1064 | # text | ||||||
1065 | #------------------------------------------------------------------------------ | ||||||
1066 | |||||||
1067 | |||||||
1068 | #------------------------------------------------------------------------------ | ||||||
1069 | # is_directory_index | ||||||
1070 | # | ||||||
1071 | |||||||
1072 | =head3 $page->is_directory_index() | ||||||
1073 | |||||||
1074 | is_directory_index() returns true if the XDO page is a | ||||||
1075 | L |
||||||
1076 | file. Generally you should | ||||||
1077 | L |
||||||
1078 | so that the directory index file is named index.xdo. | ||||||
1079 | |||||||
1080 | =cut | ||||||
1081 | |||||||
1082 | sub is_directory_index { | ||||||
1083 | 0 | 0 | my ($page) = @_; | ||||
1084 | 0 | my ($file_name); | |||||
1085 | |||||||
1086 | # TESTING | ||||||
1087 | # println '$page->is_directory_index()'; ##i | ||||||
1088 | |||||||
1089 | # get file name | ||||||
1090 | 0 | $file_name = $page->{'url_path'}; | |||||
1091 | 0 | $file_name =~ s|^.*/||s; | |||||
1092 | |||||||
1093 | # return | ||||||
1094 | 0 | 0 | if ($file_name eq $page->{'xdo'}->{'directory_index'}) | ||||
1095 | 0 | { return 1 } | |||||
1096 | else | ||||||
1097 | 0 | { return 0 } | |||||
1098 | } | ||||||
1099 | # | ||||||
1100 | # is_directory_index | ||||||
1101 | #------------------------------------------------------------------------------ | ||||||
1102 | |||||||
1103 | |||||||
1104 | #------------------------------------------------------------------------------ | ||||||
1105 | # url_path_sans_directory_index | ||||||
1106 | # | ||||||
1107 | |||||||
1108 | =head3 $page->url_path_sans_directory_index() | ||||||
1109 | |||||||
1110 | This method returns the $page->{'url_path'} property with the name of the | ||||||
1111 | directory index file removed. If the page is not a directory index file then | ||||||
1112 | the path isn't changed. So, for example, this url_path | ||||||
1113 | |||||||
1114 | /mysite/index.xdo | ||||||
1115 | |||||||
1116 | would be return as /mysite/, whereas this url_path | ||||||
1117 | |||||||
1118 | /mysite/resume.xdo | ||||||
1119 | |||||||
1120 | would be returned as /mysite/resume.xdo. | ||||||
1121 | |||||||
1122 | =cut | ||||||
1123 | |||||||
1124 | sub url_path_sans_directory_index { | ||||||
1125 | 0 | 0 | my ($page) = @_; | ||||
1126 | |||||||
1127 | # if this page is a directory page, return url_path without file name | ||||||
1128 | 0 | 0 | if ($page->is_directory_index) { | ||||
1129 | 0 | my $url_path = $page->{'url_path'}; | |||||
1130 | 0 | $url_path =~ s|[^/]+$||s; | |||||
1131 | 0 | return $url_path; | |||||
1132 | } | ||||||
1133 | |||||||
1134 | # else just return url_path | ||||||
1135 | else { | ||||||
1136 | 0 | return $page->{'url_path'}; | |||||
1137 | } | ||||||
1138 | } | ||||||
1139 | # | ||||||
1140 | # url_path_sans_directory_index | ||||||
1141 | #------------------------------------------------------------------------------ | ||||||
1142 | |||||||
1143 | |||||||
1144 | #------------------------------------------------------------------------------ | ||||||
1145 | # title | ||||||
1146 | # | ||||||
1147 | |||||||
1148 | =head3 $page->title() | ||||||
1149 | |||||||
1150 | This method returns the title of the page as set with the | ||||||
1151 | L |
||||||
1152 | have the name attribute set to "title", like this: | ||||||
1153 | |||||||
1154 | |
||||||
1155 | |||||||
1156 | If the path option is sent, and if a property of path-title is set, then | ||||||
1157 | path-title will be returned. The path-title is used with the | ||||||
1158 | L |
||||||
1159 | you want the title of your home page to be "My Home Page" when the page itself | ||||||
1160 | is displayed, but just "Home" for a link to it in the path, then you would set | ||||||
1161 | the E |
||||||
1162 | |||||||
1163 | |
||||||
1164 | |
||||||
1165 | |||||||
1166 | title() would be called like this: | ||||||
1167 | |||||||
1168 | $page->title(path=>1) | ||||||
1169 | |||||||
1170 | =cut | ||||||
1171 | |||||||
1172 | sub title { | ||||||
1173 | 0 | 0 | my ($page, %opts) = @_; | ||||
1174 | 0 | my ($props, $title); | |||||
1175 | 0 | $props = $page->top_props; | |||||
1176 | |||||||
1177 | # if path title is requested and set | ||||||
1178 | 0 | 0 | 0 | if ($opts{'path'} && defined($title = $props->{'path-title'})) { | |||
0 | |||||||
1179 | 0 | return $title; | |||||
1180 | } | ||||||
1181 | |||||||
1182 | # if title property is set, send that | ||||||
1183 | elsif (defined($title = $props->{'title'})) | ||||||
1184 | 0 | { return $title } | |||||
1185 | |||||||
1186 | # else send url path | ||||||
1187 | else { | ||||||
1188 | 0 | return $page->{'url_path'}; | |||||
1189 | } | ||||||
1190 | } | ||||||
1191 | # | ||||||
1192 | # title | ||||||
1193 | #------------------------------------------------------------------------------ | ||||||
1194 | |||||||
1195 | |||||||
1196 | #------------------------------------------------------------------------------ | ||||||
1197 | # parent | ||||||
1198 | # | ||||||
1199 | |||||||
1200 | =head3 $page->parent() | ||||||
1201 | |||||||
1202 | parent() returns the page's parent page. Be careful to avoid confusing the | ||||||
1203 | terms "caller" and "parent". "caller" is the page that is embedding the | ||||||
1204 | page represented by this object. "parent" is the page that is one step up in | ||||||
1205 | the web site hierarchy. The parent page is always going to be either a | ||||||
1206 | directory index file or (for the home page) nothing. | ||||||
1207 | |||||||
1208 | =cut | ||||||
1209 | |||||||
1210 | sub parent { | ||||||
1211 | 0 | 0 | my ($page) = @_; | ||||
1212 | 0 | my ($xdo, $parent, $url_path, $page_class); | |||||
1213 | 0 | $xdo = $page->{'xdo'}; | |||||
1214 | |||||||
1215 | # TESTING | ||||||
1216 | # println '$page->parent()'; ##i | ||||||
1217 | |||||||
1218 | # get parent page url path | ||||||
1219 | 0 | $url_path = $page->{'url_path'}; | |||||
1220 | |||||||
1221 | # if this is the top page, and the request was for the directory index, | ||||||
1222 | # (i.e. the requests ends in a /) then remove the file name (probably | ||||||
1223 | # index.xdo). | ||||||
1224 | 0 | 0 | if ($page->{'top'}) { | ||||
0 | |||||||
1225 | # If a directory index was requested, either there is no parent (because | ||||||
1226 | # it's the xdo-root) or we should go up one directory. | ||||||
1227 | 0 | 0 | if ($ENV{'REQUEST_URI'} =~ m|/$|s) { | ||||
1228 | 0 | $url_path =~ s|[^/]+$||s; | |||||
1229 | } | ||||||
1230 | } | ||||||
1231 | |||||||
1232 | # else if page is directory index | ||||||
1233 | elsif ($page->is_directory_index) { | ||||||
1234 | 0 | $url_path =~ s|[^/]+$||; | |||||
1235 | } | ||||||
1236 | |||||||
1237 | # if the page is the xdo root, there is no parent | ||||||
1238 | 0 | 0 | if ($url_path eq $xdo->{'root'}) { | ||||
1239 | 0 | return 0. | |||||
1240 | } | ||||||
1241 | |||||||
1242 | # if path has trailing / then remove one directory | ||||||
1243 | # else remove the file name | ||||||
1244 | 0 | 0 | unless ($url_path =~ s|[^/]+/$||s) { | ||||
1245 | 0 | $url_path =~ s|[^/]+$||s; | |||||
1246 | } | ||||||
1247 | |||||||
1248 | # parent is always a directory index file | ||||||
1249 | 0 | $url_path .= $xdo->{'directory_index'}; | |||||
1250 | |||||||
1251 | # instantiate top page object | ||||||
1252 | 0 | $page_class = $xdo->page_class(); | |||||
1253 | 0 | $parent = $page_class->new('/', $url_path, $xdo); | |||||
1254 | |||||||
1255 | # return | ||||||
1256 | 0 | 0 | $parent or return 0; | ||||
1257 | 0 | return $parent; | |||||
1258 | } | ||||||
1259 | # | ||||||
1260 | # parent | ||||||
1261 | #------------------------------------------------------------------------------ | ||||||
1262 | |||||||
1263 | |||||||
1264 | #------------------------------------------------------------------------------ | ||||||
1265 | # path_pages | ||||||
1266 | # | ||||||
1267 | |||||||
1268 | =head3 $page->path_pages() | ||||||
1269 | |||||||
1270 | path_pages() returns an array of the pages in the web site hierarcy leading | ||||||
1271 | down to and including the page represented by this object. In array context | ||||||
1272 | this method returns an array. In scalar context it returns an array reference. | ||||||
1273 | |||||||
1274 | =cut | ||||||
1275 | |||||||
1276 | sub path_pages { | ||||||
1277 | 0 | 0 | my ($page) = @_; | ||||
1278 | 0 | my (@rv, $current, $sanity); | |||||
1279 | |||||||
1280 | # I've had problems with an endless loop in this routine, so just to be | ||||||
1281 | # safe I'm assuming nobody will nest pages more than 100 deep. Feel free | ||||||
1282 | # to express disagreement. | ||||||
1283 | 0 | $sanity = 100; | |||||
1284 | |||||||
1285 | # start with this page | ||||||
1286 | 0 | $current = $page; | |||||
1287 | |||||||
1288 | # while we get a parent, add it to the return array | ||||||
1289 | 0 | while ($current) { | |||||
1290 | 0 | unshift @rv, $current; | |||||
1291 | 0 | $current = $current->parent(); | |||||
1292 | |||||||
1293 | # sanity check | ||||||
1294 | 0 | 0 | if ($sanity-- <= 0) | ||||
1295 | 0 | { die 'too many iterations' } | |||||
1296 | } | ||||||
1297 | |||||||
1298 | # return | ||||||
1299 | 0 | 0 | wantarray() and return @rv; | ||||
1300 | 0 | return \@rv; | |||||
1301 | } | ||||||
1302 | # | ||||||
1303 | # path_pages | ||||||
1304 | #------------------------------------------------------------------------------ | ||||||
1305 | |||||||
1306 | |||||||
1307 | #------------------------------------------------------------------------------ | ||||||
1308 | # link_path | ||||||
1309 | # | ||||||
1310 | |||||||
1311 | =head3 $page->link_path() | ||||||
1312 | |||||||
1313 | This method returns the URL path to link to the page represented by this | ||||||
1314 | object. This method always returns an absolute path. | ||||||
1315 | |||||||
1316 | =cut | ||||||
1317 | |||||||
1318 | sub link_path { | ||||||
1319 | 0 | 0 | my ($page) = @_; | ||||
1320 | 0 | my ($index_rx, $path); | |||||
1321 | |||||||
1322 | # TESTING | ||||||
1323 | # println '$page->link_path()'; ##i | ||||||
1324 | |||||||
1325 | # regex for directory index | ||||||
1326 | 0 | $index_rx = $page->{'xdo'}->{'directory_index'}; | |||||
1327 | 0 | $index_rx = quotemeta($index_rx); | |||||
1328 | |||||||
1329 | # build path, removing directory index file name | ||||||
1330 | 0 | $path = $page->{'url_path'}; | |||||
1331 | 0 | $path =~ s|/$index_rx$|/|s; | |||||
1332 | |||||||
1333 | # return | ||||||
1334 | 0 | return $path; | |||||
1335 | } | ||||||
1336 | # | ||||||
1337 | # link_path | ||||||
1338 | #------------------------------------------------------------------------------ | ||||||
1339 | |||||||
1340 | |||||||
1341 | # | ||||||
1342 | # Web::XDO::Page | ||||||
1343 | ############################################################################### | ||||||
1344 | |||||||
1345 | |||||||
1346 | |||||||
1347 | ############################################################################### | ||||||
1348 | # Web::XDO::Token | ||||||
1349 | # | ||||||
1350 | package Web::XDO::Token; | ||||||
1351 | 1 | 1 | 17507 | use strict; | |||
1 | 3 | ||||||
1 | 181 | ||||||
1352 | |||||||
1353 | # debug tools | ||||||
1354 | # use Debug::ShowStuff ':all'; | ||||||
1355 | |||||||
1356 | |||||||
1357 | =head2 Web::XDO::Token | ||||||
1358 | |||||||
1359 | This class represents a generic token in an XDO page. All token classes | ||||||
1360 | superclass this class. | ||||||
1361 | |||||||
1362 | =cut | ||||||
1363 | |||||||
1364 | |||||||
1365 | #------------------------------------------------------------------------------ | ||||||
1366 | # new | ||||||
1367 | # | ||||||
1368 | |||||||
1369 | =head3 $class->new() | ||||||
1370 | |||||||
1371 | Creates a new Web::XDO::Token object and returns it. Doesn't do anything else. | ||||||
1372 | |||||||
1373 | =cut | ||||||
1374 | |||||||
1375 | sub new { | ||||||
1376 | 0 | 0 | my ($class) = @_; | ||||
1377 | 0 | my $token = bless({}, $class); | |||||
1378 | |||||||
1379 | # return | ||||||
1380 | 0 | return $token; | |||||
1381 | } | ||||||
1382 | # | ||||||
1383 | # new | ||||||
1384 | #------------------------------------------------------------------------------ | ||||||
1385 | |||||||
1386 | |||||||
1387 | #------------------------------------------------------------------------------ | ||||||
1388 | # output | ||||||
1389 | # | ||||||
1390 | |||||||
1391 | =head3 $token->output() | ||||||
1392 | |||||||
1393 | Outputs $token->{'raw'} if it is defined. This method is overridden by many | ||||||
1394 | tag classes. | ||||||
1395 | |||||||
1396 | =cut | ||||||
1397 | |||||||
1398 | sub output { | ||||||
1399 | 0 | 0 | my ($token) = @_; | ||||
1400 | 0 | my $raw = $token->{'raw'}; | |||||
1401 | |||||||
1402 | 0 | 0 | if (defined $raw) | ||||
1403 | 0 | { print $raw } | |||||
1404 | } | ||||||
1405 | # | ||||||
1406 | # output | ||||||
1407 | #------------------------------------------------------------------------------ | ||||||
1408 | |||||||
1409 | |||||||
1410 | # | ||||||
1411 | # Web::XDO::Token | ||||||
1412 | ############################################################################### | ||||||
1413 | |||||||
1414 | |||||||
1415 | |||||||
1416 | |||||||
1417 | ############################################################################### | ||||||
1418 | # Web::XDO::Token::Tag | ||||||
1419 | # | ||||||
1420 | package Web::XDO::Token::Tag; | ||||||
1421 | 1 | 1 | 6 | use strict; | |||
1 | 1 | ||||||
1 | 32 | ||||||
1422 | 1 | 1 | 5 | use base 'Web::XDO::Token'; | |||
1 | 2 | ||||||
1 | 969 | ||||||
1423 | 1 | 1 | 7 | use String::Util ':all'; | |||
1 | 2 | ||||||
1 | 1402 | ||||||
1424 | |||||||
1425 | # debug tools | ||||||
1426 | # use Debug::ShowStuff ':all'; | ||||||
1427 | |||||||
1428 | # tag classes | ||||||
1429 | our (%tag_classes); | ||||||
1430 | |||||||
1431 | =head2 Web::XDO::Token::Tag | ||||||
1432 | |||||||
1433 | This class represents a tag. This is the default class for tags that XDO | ||||||
1434 | doesn't recognize. This class superclasses | ||||||
1435 | L |
||||||
1436 | |||||||
1437 | =cut | ||||||
1438 | |||||||
1439 | |||||||
1440 | #------------------------------------------------------------------------------ | ||||||
1441 | # add_class | ||||||
1442 | # | ||||||
1443 | |||||||
1444 | =head3 $tag->add_class() | ||||||
1445 | |||||||
1446 | This method adds a CSS class to the tag's "class" attribute. If such an | ||||||
1447 | attribute doesn't already exist then it is created. If the new CSS class | ||||||
1448 | is already in the "class" attribute then no change is made. | ||||||
1449 | |||||||
1450 | After calling add_class() and before outputting the tag you should call | ||||||
1451 | L<$tag-E |
||||||
1452 | added class. | ||||||
1453 | |||||||
1454 | =cut | ||||||
1455 | |||||||
1456 | sub add_class { | ||||||
1457 | 0 | 0 | my ($tag, $new_class) = @_; | ||||
1458 | 0 | my ($atts); | |||||
1459 | 0 | $atts = $tag->{'atts'}; | |||||
1460 | |||||||
1461 | # if class attribute exists, add class | ||||||
1462 | 0 | 0 | if (defined $atts->{'class'}) { | ||||
1463 | 0 | my @classes = split(' ', crunch($atts->{'class'})); | |||||
1464 | 0 | @classes = grep {$_ eq $new_class} @classes; | |||||
0 | |||||||
1465 | |||||||
1466 | 0 | 0 | unless (@classes) | ||||
1467 | 0 | { $atts->{'class'} .= ' ' . $new_class } | |||||
1468 | } | ||||||
1469 | |||||||
1470 | # else just add class attribute | ||||||
1471 | else { | ||||||
1472 | 0 | $atts->{'class'} = $new_class; | |||||
1473 | } | ||||||
1474 | } | ||||||
1475 | # | ||||||
1476 | # add_class | ||||||
1477 | #------------------------------------------------------------------------------ | ||||||
1478 | |||||||
1479 | |||||||
1480 | #------------------------------------------------------------------------------ | ||||||
1481 | # rebuild | ||||||
1482 | # | ||||||
1483 | |||||||
1484 | =head3 $tag->rebuild() | ||||||
1485 | |||||||
1486 | rebuild() rebuilds the $tag->{'raw'} attribute. 'raw' is the string that is | ||||||
1487 | output by L<$token-E |
||||||
1488 | |||||||
1489 | =cut | ||||||
1490 | |||||||
1491 | sub rebuild { | ||||||
1492 | 0 | 0 | my ($tag) = @_; | ||||
1493 | 0 | my ($raw, $atts); | |||||
1494 | 0 | $atts = $tag->{'atts'}; | |||||
1495 | |||||||
1496 | # open tag | ||||||
1497 | 0 | $raw = '<' . $tag->{'name'}; | |||||
1498 | |||||||
1499 | # add attributes | ||||||
1500 | 0 | foreach my $key (keys %$atts) { | |||||
1501 | 0 | $raw .= ' ' . $key . '="' . htmlesc($atts->{$key}) . '"'; | |||||
1502 | } | ||||||
1503 | |||||||
1504 | # close tag | ||||||
1505 | 0 | $raw .= '>'; | |||||
1506 | |||||||
1507 | # save raw | ||||||
1508 | 0 | $tag->{'raw'} = $raw; | |||||
1509 | } | ||||||
1510 | # | ||||||
1511 | # rebuild | ||||||
1512 | #------------------------------------------------------------------------------ | ||||||
1513 | |||||||
1514 | |||||||
1515 | #------------------------------------------------------------------------------ | ||||||
1516 | # adjust_atts_for_root | ||||||
1517 | # | ||||||
1518 | |||||||
1519 | =head3 $tag->adjust_atts_for_root() | ||||||
1520 | |||||||
1521 | adjust_atts_for_root() modifies the given tag attributes if they have the | ||||||
1522 | L |
||||||
1523 | tag. | ||||||
1524 | |||||||
1525 | =cut | ||||||
1526 | |||||||
1527 | sub adjust_atts_for_root { | ||||||
1528 | 0 | 0 | my ($tag, $page, @att_names) = @_; | ||||
1529 | 0 | my ($xdo, $atts); | |||||
1530 | 0 | $xdo = $page->{'xdo'}; | |||||
1531 | 0 | $atts = $tag->{'atts'}; | |||||
1532 | |||||||
1533 | # TESTING | ||||||
1534 | # println ref($tag), '->adjust_atts_for_root()'; | ||||||
1535 | |||||||
1536 | # loop through attributes adjusting for |
||||||
1537 | 0 | foreach my $att_name (@att_names) { | |||||
1538 | 0 | 0 | if (defined $atts->{$att_name} ) { | ||||
1539 | 0 | $atts->{$att_name} = $xdo->adjust_url_for_root($atts->{$att_name}); | |||||
1540 | } | ||||||
1541 | } | ||||||
1542 | } | ||||||
1543 | # | ||||||
1544 | # adjust_atts_for_root | ||||||
1545 | #------------------------------------------------------------------------------ | ||||||
1546 | |||||||
1547 | |||||||
1548 | #------------------------------------------------------------------------------ | ||||||
1549 | # content | ||||||
1550 | # | ||||||
1551 | |||||||
1552 | =head3 $tag->content() | ||||||
1553 | |||||||
1554 | Returns the elements contained within the tag represented by this object. The | ||||||
1555 | elements are removed from the page's tokens array. The end tag is removed from | ||||||
1556 | the tokens array but is not returned by this method. | ||||||
1557 | |||||||
1558 | $tag->contents() is an alias for $tag->content(). | ||||||
1559 | |||||||
1560 | =cut | ||||||
1561 | |||||||
1562 | 0 | 0 | sub contents {return shift->content(@_)} | ||||
1563 | |||||||
1564 | sub content { | ||||||
1565 | 0 | 0 | my ($tag, $page, $idx) = @_; | ||||
1566 | 0 | my ($next_idx, $tokens, @rv, $nested); | |||||
1567 | 0 | $next_idx = $idx + 1; | |||||
1568 | 0 | $tokens = $page->{'tokens'}; | |||||
1569 | 0 | $nested = 0; | |||||
1570 | |||||||
1571 | # TESTING | ||||||
1572 | # println ref($tag), '->content()'; ##i | ||||||
1573 | |||||||
1574 | # get next tokens until we get to the end tag | ||||||
1575 | NEXT_LOOP: | ||||||
1576 | 0 | while (my $next = splice(@$tokens, $next_idx, 1)) { | |||||
1577 | # if end tag for this element, we're done | ||||||
1578 | 0 | 0 | if (UNIVERSAL::isa $next, 'Web::XDO::Token::EndTag') { | ||||
0 | |||||||
1579 | 0 | 0 | if ($next->{'name'} eq $tag->{'name'}) { | ||||
1580 | 0 | 0 | if ($nested) | ||||
1581 | 0 | { $nested-- } | |||||
1582 | else | ||||||
1583 | 0 | { last NEXT_LOOP } | |||||
1584 | } | ||||||
1585 | } | ||||||
1586 | |||||||
1587 | # else if this is another tag with the same name, note as nested | ||||||
1588 | elsif (UNIVERSAL::isa $next, 'Web::XDO::Token::Tag') { | ||||||
1589 | 0 | 0 | if ($next->{'name'} eq $tag->{'name'}) { | ||||
1590 | 0 | $nested++; | |||||
1591 | } | ||||||
1592 | } | ||||||
1593 | |||||||
1594 | # add token to return array | ||||||
1595 | 0 | push @rv, $next; | |||||
1596 | } | ||||||
1597 | |||||||
1598 | # return | ||||||
1599 | 0 | 0 | wantarray and return @rv; | ||||
1600 | 0 | return \@rv; | |||||
1601 | } | ||||||
1602 | # | ||||||
1603 | # content | ||||||
1604 | #------------------------------------------------------------------------------ | ||||||
1605 | |||||||
1606 | |||||||
1607 | #------------------------------------------------------------------------------ | ||||||
1608 | # included_page | ||||||
1609 | # | ||||||
1610 | |||||||
1611 | =head3 $tag->included_page() | ||||||
1612 | |||||||
1613 | This method returns a page object representing the page referenced in a tag. | ||||||
1614 | Most commonly this method is used by | ||||||
1615 | L |
||||||
1616 | to retrieve the included page. | ||||||
1617 | |||||||
1618 | =cut | ||||||
1619 | |||||||
1620 | sub included_page { | ||||||
1621 | 0 | 0 | my ($tag, $caller) = @_; | ||||
1622 | 0 | my ($atts, $xdo, $included, $url_base); | |||||
1623 | 0 | $atts = $tag->{'atts'}; | |||||
1624 | 0 | $xdo = $caller->{'xdo'}; | |||||
1625 | |||||||
1626 | # TESTING | ||||||
1627 | # println ref($tag), '->included_page()'; ##i | ||||||
1628 | |||||||
1629 | # start with url_path of page | ||||||
1630 | 0 | $url_base = $caller->{'url_path'}; | |||||
1631 | |||||||
1632 | # if page is a plain file, remove file name | ||||||
1633 | 0 | 0 | if (-f $caller->{'local_path'}) | ||||
1634 | 0 | { $url_base =~ s|[^/]*$||s } | |||||
1635 | |||||||
1636 | # adjust urls for xdo-root | ||||||
1637 | 0 | $tag->adjust_atts_for_root($caller, 'src'); | |||||
1638 | |||||||
1639 | # instantiate page object | ||||||
1640 | 0 | $included = $xdo->page_class->new($url_base, $atts->{'src'}, $xdo, 'caller'=>$caller); | |||||
1641 | |||||||
1642 | # return | ||||||
1643 | 0 | return $included; | |||||
1644 | } | ||||||
1645 | # | ||||||
1646 | # included_page | ||||||
1647 | #------------------------------------------------------------------------------ | ||||||
1648 | |||||||
1649 | |||||||
1650 | #------------------------------------------------------------------------------ | ||||||
1651 | # output | ||||||
1652 | # | ||||||
1653 | |||||||
1654 | =head3 $tag->output() | ||||||
1655 | |||||||
1656 | Outputs the tag. | ||||||
1657 | L<$tag-E |
||||||
1658 | is called before the tag is output. | ||||||
1659 | |||||||
1660 | =cut | ||||||
1661 | |||||||
1662 | sub output { | ||||||
1663 | 0 | 0 | my ($tag, $page, $idx) = @_; | ||||
1664 | |||||||
1665 | # TESTING | ||||||
1666 | # println $tag->{'name'}, '->output'; ##i | ||||||
1667 | |||||||
1668 | # get definition | ||||||
1669 | 0 | 0 | if (my $def = $page->{'xdo'}->{'tags'}->{$tag->{'name'}}) { | ||||
1670 | 0 | 0 | if ($def->{'adjust_for_root'}) { | ||||
1671 | 0 | $tag->adjust_atts_for_root($page, @{$def->{'adjust_for_root'}}); | |||||
0 | |||||||
1672 | 0 | $tag->rebuild(); | |||||
1673 | } | ||||||
1674 | } | ||||||
1675 | |||||||
1676 | # output raw | ||||||
1677 | 0 | print $tag->{'raw'}; | |||||
1678 | } | ||||||
1679 | # | ||||||
1680 | # output | ||||||
1681 | #------------------------------------------------------------------------------ | ||||||
1682 | |||||||
1683 | |||||||
1684 | # | ||||||
1685 | # Web::XDO::Token::Tag | ||||||
1686 | ############################################################################### | ||||||
1687 | |||||||
1688 | |||||||
1689 | ############################################################################### | ||||||
1690 | # Web::XDO::Token::EndTag | ||||||
1691 | # | ||||||
1692 | package Web::XDO::Token::EndTag; | ||||||
1693 | 1 | 1 | 18 | use strict; | |||
1 | 2 | ||||||
1 | 50 | ||||||
1694 | 1 | 1 | 5 | use base 'Web::XDO::Token'; | |||
1 | 2 | ||||||
1 | 596 | ||||||
1695 | |||||||
1696 | # | ||||||
1697 | # Web::XDO::Token::EndTag | ||||||
1698 | ############################################################################### | ||||||
1699 | |||||||
1700 | |||||||
1701 | ############################################################################### | ||||||
1702 | # Web::XDO::Token::Text | ||||||
1703 | # | ||||||
1704 | package Web::XDO::Token::Text; | ||||||
1705 | 1 | 1 | 5 | use strict; | |||
1 | 2 | ||||||
1 | 42 | ||||||
1706 | 1 | 1 | 5 | use base 'Web::XDO::Token'; | |||
1 | 1 | ||||||
1 | 518 | ||||||
1707 | |||||||
1708 | # | ||||||
1709 | # Web::XDO::Token::Text | ||||||
1710 | ############################################################################### | ||||||
1711 | |||||||
1712 | |||||||
1713 | ############################################################################### | ||||||
1714 | # Web::XDO::Token::Tag::Include | ||||||
1715 | # | ||||||
1716 | package Web::XDO::Token::Tag::Include; | ||||||
1717 | 1 | 1 | 5 | use strict; | |||
1 | 2 | ||||||
1 | 26 | ||||||
1718 | 1 | 1 | 4 | use base 'Web::XDO::Token::Tag'; | |||
1 | 3 | ||||||
1 | 514 | ||||||
1719 | 1 | 1 | 5 | use String::Util ':all'; | |||
1 | 2 | ||||||
1 | 330 | ||||||
1720 | 1 | 1 | 6 | use Carp 'croak'; | |||
1 | 1 | ||||||
1 | 174 | ||||||
1721 | |||||||
1722 | # debug tools | ||||||
1723 | # use Debug::ShowStuff ':all'; | ||||||
1724 | |||||||
1725 | # note tag class | ||||||
1726 | $Web::XDO::Token::Tag::tag_classes{'include'} = __PACKAGE__; | ||||||
1727 | |||||||
1728 | |||||||
1729 | =head2 Web::XDO::Token::Tag::Include | ||||||
1730 | |||||||
1731 | This class represents an E |
||||||
1732 | page in the current page. | ||||||
1733 | |||||||
1734 | =cut | ||||||
1735 | |||||||
1736 | |||||||
1737 | #------------------------------------------------------------------------------ | ||||||
1738 | # output | ||||||
1739 | # | ||||||
1740 | sub output { | ||||||
1741 | 0 | 0 | my ($tag, $page, $idx) = @_; | ||||
1742 | 0 | my ($included); | |||||
1743 | |||||||
1744 | # TESTING | ||||||
1745 | # println ref($tag), '->output'; ##i | ||||||
1746 | |||||||
1747 | # get included page | ||||||
1748 | 0 | $included = $tag->included_page($page); | |||||
1749 | |||||||
1750 | # output included page | ||||||
1751 | 0 | 0 | if ($included) | ||||
1752 | 0 | { $included->output() } | |||||
1753 | } | ||||||
1754 | # | ||||||
1755 | # output | ||||||
1756 | #------------------------------------------------------------------------------ | ||||||
1757 | |||||||
1758 | |||||||
1759 | # | ||||||
1760 | # Web::XDO::Token::Tag::Include | ||||||
1761 | ############################################################################### | ||||||
1762 | |||||||
1763 | |||||||
1764 | ############################################################################### | ||||||
1765 | # Web::XDO::Token::Tag::Property | ||||||
1766 | # | ||||||
1767 | package Web::XDO::Token::Tag::Property; | ||||||
1768 | 1 | 1 | 4 | use strict; | |||
1 | 2 | ||||||
1 | 26 | ||||||
1769 | 1 | 1 | 4 | use Carp 'croak'; | |||
1 | 2 | ||||||
1 | 40 | ||||||
1770 | 1 | 1 | 4 | use base 'Web::XDO::Token::Tag'; | |||
1 | 2 | ||||||
1 | 804 | ||||||
1771 | |||||||
1772 | # debug tools | ||||||
1773 | # use Debug::ShowStuff ':all'; | ||||||
1774 | |||||||
1775 | # note tag class | ||||||
1776 | $Web::XDO::Token::Tag::tag_classes{'property'} = __PACKAGE__; | ||||||
1777 | |||||||
1778 | =head2 Web::XDO::Token::Tag::Property | ||||||
1779 | |||||||
1780 | This class represents a E |
||||||
1781 | It does not output anything. | ||||||
1782 | |||||||
1783 | =cut | ||||||
1784 | |||||||
1785 | |||||||
1786 | #------------------------------------------------------------------------------ | ||||||
1787 | # set_page_prop | ||||||
1788 | # | ||||||
1789 | |||||||
1790 | =head3 $property->set_page_prop() | ||||||
1791 | |||||||
1792 | This method sets a property of the L |
||||||
1793 | |||||||
1794 | =cut | ||||||
1795 | |||||||
1796 | sub set_page_prop { | ||||||
1797 | 0 | 0 | my ($tag, $page, $token_idx) = @_; | ||||
1798 | 0 | my ($atts, $name, $value, $props, $tokens); | |||||
1799 | 0 | $atts = $tag->{'atts'}; | |||||
1800 | 0 | $props = $page->top_props(); | |||||
1801 | 0 | $tokens = $page->{'tokens'}; | |||||
1802 | |||||||
1803 | # TESTING | ||||||
1804 | # println ref($tag), '->set_page_prop'; ##i | ||||||
1805 | |||||||
1806 | # name of property | ||||||
1807 | 0 | 0 | unless (defined($name = $atts->{'name'})) | ||||
1808 | 0 | { return 0 } | |||||
1809 | |||||||
1810 | # get value from attribute | ||||||
1811 | 0 | 0 | if (exists $atts->{'value'}) { | ||||
1812 | 0 | $value = $atts->{'value'}; | |||||
1813 | } | ||||||
1814 | |||||||
1815 | # set property | ||||||
1816 | 0 | $props->{$name} = $value; | |||||
1817 | } | ||||||
1818 | # | ||||||
1819 | # set_page_prop | ||||||
1820 | #------------------------------------------------------------------------------ | ||||||
1821 | |||||||
1822 | |||||||
1823 | #------------------------------------------------------------------------------ | ||||||
1824 | # output | ||||||
1825 | # | ||||||
1826 | |||||||
1827 | =head3 $property->output() | ||||||
1828 | |||||||
1829 | This method sets a property of the L |
||||||
1830 | XDO page is loaded the properties of the page are set as the page is parsed. | ||||||
1831 | Because properties can be changed between parsing and output, the | ||||||
1832 | E |
||||||
1833 | |||||||
1834 | =cut | ||||||
1835 | |||||||
1836 | sub output { | ||||||
1837 | 0 | 0 | my ($tag, $page, $idx) = @_; | ||||
1838 | 0 | $tag->set_page_prop($page); | |||||
1839 | } | ||||||
1840 | # | ||||||
1841 | # output | ||||||
1842 | #------------------------------------------------------------------------------ | ||||||
1843 | |||||||
1844 | |||||||
1845 | |||||||
1846 | # | ||||||
1847 | # Web::XDO::Token::Tag::Property | ||||||
1848 | ############################################################################### | ||||||
1849 | |||||||
1850 | |||||||
1851 | |||||||
1852 | ############################################################################### | ||||||
1853 | # Web::XDO::Token::Tag::ShowProperty | ||||||
1854 | # | ||||||
1855 | package Web::XDO::Token::Tag::ShowProperty; | ||||||
1856 | 1 | 1 | 7 | use strict; | |||
1 | 7 | ||||||
1 | 30 | ||||||
1857 | 1 | 1 | 4 | use Carp 'croak'; | |||
1 | 2 | ||||||
1 | 53 | ||||||
1858 | 1 | 1 | 4 | use base 'Web::XDO::Token::Tag'; | |||
1 | 2 | ||||||
1 | 722 | ||||||
1859 | |||||||
1860 | # debug tools | ||||||
1861 | # use Debug::ShowStuff ':all'; | ||||||
1862 | |||||||
1863 | # note tag class | ||||||
1864 | $Web::XDO::Token::Tag::tag_classes{'show-property'} = __PACKAGE__; | ||||||
1865 | |||||||
1866 | |||||||
1867 | =head2 Web::XDO::Token::Tag::ShowProperty | ||||||
1868 | |||||||
1869 | This class represents a E |
||||||
1870 | property of the L |
||||||
1871 | attribute. Note that the value of the property is not HTML-escaped. | ||||||
1872 | |||||||
1873 | =cut | ||||||
1874 | |||||||
1875 | #------------------------------------------------------------------------------ | ||||||
1876 | # output | ||||||
1877 | # | ||||||
1878 | sub output { | ||||||
1879 | 0 | 0 | my ($tag, $page, $idx) = @_; | ||||
1880 | 0 | my ($atts, $xdo, $props); | |||||
1881 | 0 | $atts = $tag->{'atts'}; | |||||
1882 | 0 | $props = $page->top_props(); | |||||
1883 | |||||||
1884 | # must have name attribute | ||||||
1885 | 0 | 0 | unless (defined $atts->{'name'}) { | ||||
1886 | 0 | return 0; | |||||
1887 | } | ||||||
1888 | |||||||
1889 | # output value if there is one | ||||||
1890 | 0 | 0 | if (defined $props->{$atts->{'name'}}) { | ||||
1891 | 0 | print $props->{$atts->{'name'}} | |||||
1892 | } | ||||||
1893 | } | ||||||
1894 | # | ||||||
1895 | # output | ||||||
1896 | #------------------------------------------------------------------------------ | ||||||
1897 | |||||||
1898 | |||||||
1899 | # | ||||||
1900 | # Web::XDO::Token::Tag::ShowProperty | ||||||
1901 | ############################################################################### | ||||||
1902 | |||||||
1903 | |||||||
1904 | |||||||
1905 | ############################################################################### | ||||||
1906 | # Web::XDO::Token::Tag::XdoRoot | ||||||
1907 | # | ||||||
1908 | package Web::XDO::Token::Tag::XdoRoot; | ||||||
1909 | 1 | 1 | 6 | use strict; | |||
1 | 2 | ||||||
1 | 29 | ||||||
1910 | 1 | 1 | 5 | use base 'Web::XDO::Token::Tag'; | |||
1 | 2 | ||||||
1 | 646 | ||||||
1911 | |||||||
1912 | # debug tools | ||||||
1913 | # use Debug::ShowStuff ':all'; | ||||||
1914 | |||||||
1915 | # note tag class | ||||||
1916 | $Web::XDO::Token::Tag::tag_classes{'xdo-root'} = __PACKAGE__; | ||||||
1917 | |||||||
1918 | |||||||
1919 | =head2 Web::XDO::Token::Tag::XdoRoot | ||||||
1920 | |||||||
1921 | This class represents an | ||||||
1922 | L |
||||||
1923 | tag. This tag outputs the L<$xdo object's|/Web::XDO> {'root'} property. | ||||||
1924 | |||||||
1925 | =cut | ||||||
1926 | |||||||
1927 | |||||||
1928 | #------------------------------------------------------------------------------ | ||||||
1929 | # output | ||||||
1930 | # | ||||||
1931 | sub output { | ||||||
1932 | 0 | 0 | my ($tag, $page, $idx) = @_; | ||||
1933 | 0 | my ($xdo); | |||||
1934 | 0 | $xdo = $page->{'xdo'}; | |||||
1935 | |||||||
1936 | # TESTING | ||||||
1937 | # println ref($tag), '->output()'; ##i | ||||||
1938 | |||||||
1939 | # output xdo root | ||||||
1940 | 0 | print $xdo->{'root'}; | |||||
1941 | } | ||||||
1942 | # | ||||||
1943 | # output | ||||||
1944 | #------------------------------------------------------------------------------ | ||||||
1945 | |||||||
1946 | |||||||
1947 | # | ||||||
1948 | # Web::XDO::Token::Tag::XdoRoot | ||||||
1949 | ############################################################################### | ||||||
1950 | |||||||
1951 | |||||||
1952 | |||||||
1953 | ############################################################################### | ||||||
1954 | # Web::XDO::Token::Tag::Wrapper | ||||||
1955 | # | ||||||
1956 | package Web::XDO::Token::Tag::Wrapper; | ||||||
1957 | 1 | 1 | 6 | use strict; | |||
1 | 2 | ||||||
1 | 56 | ||||||
1958 | 1 | 1 | 5 | use base 'Web::XDO::Token::Tag'; | |||
1 | 1 | ||||||
1 | 818 | ||||||
1959 | |||||||
1960 | # debug tools | ||||||
1961 | # use Debug::ShowStuff ':all'; | ||||||
1962 | |||||||
1963 | # note tag class | ||||||
1964 | $Web::XDO::Token::Tag::tag_classes{'wrapper'} = __PACKAGE__; | ||||||
1965 | |||||||
1966 | |||||||
1967 | =head2 Web::XDO::Token::Tag::Wrapper | ||||||
1968 | |||||||
1969 | This class represents a | ||||||
1970 | L |
||||||
1971 | tag. The contents of the E |
||||||
1972 | included page's | ||||||
1973 | L |
||||||
1974 | |||||||
1975 | =cut | ||||||
1976 | |||||||
1977 | #------------------------------------------------------------------------------ | ||||||
1978 | # output | ||||||
1979 | # | ||||||
1980 | sub output { | ||||||
1981 | 0 | 0 | my ($tag, $page, $idx) = @_; | ||||
1982 | 0 | my ($xdo, $atts, @contents, $wrapper, $included, $inc_tokens, $inc_idx); | |||||
1983 | 0 | $xdo = $page->{'xdo'}; | |||||
1984 | 0 | $atts = $tag->{'atts'}; | |||||
1985 | 0 | $inc_idx = 0; | |||||
1986 | |||||||
1987 | # TESTING | ||||||
1988 | # println ref($tag), '->output()'; ##i | ||||||
1989 | |||||||
1990 | # adjust attributes for root | ||||||
1991 | 0 | $tag->adjust_atts_for_root($page, 'src'); | |||||
1992 | |||||||
1993 | # get contents of tag | ||||||
1994 | 0 | @contents = $tag->contents($page, $idx); | |||||
1995 | |||||||
1996 | # create wrapper page object | ||||||
1997 | 0 | $included = $tag->included_page($page); | |||||
1998 | 0 | 0 | $included or return 0; | ||||
1999 | |||||||
2000 | # get included page tokens | ||||||
2001 | 0 | $inc_tokens = $included->{'tokens'}; | |||||
2002 | |||||||
2003 | # loop through include's tokens looking for |
||||||
2004 | 0 | while ($inc_idx <= $#$inc_tokens) { | |||||
2005 | 0 | my $token = $inc_tokens->[$inc_idx]; | |||||
2006 | |||||||
2007 | # If token is is |
||||||
2008 | # of the |
||||||
2009 | 0 | 0 | if (UNIVERSAL::isa $token, 'Web::XDO::Token::Tag::WrapperContent') { | ||||
2010 | # remove |
||||||
2011 | 0 | splice @$inc_tokens, $inc_idx, 1, @contents; | |||||
2012 | |||||||
2013 | # increase index to after contents tags | ||||||
2014 | 0 | $inc_idx += @contents; | |||||
2015 | } | ||||||
2016 | |||||||
2017 | # else increment $inc_idx | ||||||
2018 | else { | ||||||
2019 | 0 | $inc_idx++; | |||||
2020 | } | ||||||
2021 | } | ||||||
2022 | |||||||
2023 | # output included page | ||||||
2024 | 0 | $included->output(); | |||||
2025 | } | ||||||
2026 | # | ||||||
2027 | # output | ||||||
2028 | #------------------------------------------------------------------------------ | ||||||
2029 | |||||||
2030 | |||||||
2031 | # | ||||||
2032 | # Web::XDO::Token::Tag::Wrapper | ||||||
2033 | ############################################################################### | ||||||
2034 | |||||||
2035 | |||||||
2036 | |||||||
2037 | ############################################################################### | ||||||
2038 | # Web::XDO::Token::Tag::WrapperContent | ||||||
2039 | # | ||||||
2040 | package Web::XDO::Token::Tag::WrapperContent; | ||||||
2041 | 1 | 1 | 13 | use strict; | |||
1 | 2 | ||||||
1 | 35 | ||||||
2042 | 1 | 1 | 5 | use Carp 'croak'; | |||
1 | 2 | ||||||
1 | 57 | ||||||
2043 | 1 | 1 | 5 | use base 'Web::XDO::Token::Tag'; | |||
1 | 2 | ||||||
1 | 608 | ||||||
2044 | |||||||
2045 | # note tag class | ||||||
2046 | $Web::XDO::Token::Tag::tag_classes{'wrapper-content'} = __PACKAGE__; | ||||||
2047 | |||||||
2048 | =head2 Web::XDO::Token::Tag::WrapperContent | ||||||
2049 | |||||||
2050 | This class represents a | ||||||
2051 | L |
||||||
2052 | tag. | ||||||
2053 | |||||||
2054 | This tag itself does not output anything. The E |
||||||
2055 | placeholder. When a L |
||||||
2056 | tag is output it removes the |
||||||
2057 | its own contents. | ||||||
2058 | |||||||
2059 | |||||||
2060 | =cut | ||||||
2061 | |||||||
2062 | |||||||
2063 | #------------------------------------------------------------------------------ | ||||||
2064 | # output | ||||||
2065 | # don't output anything | ||||||
2066 | # | ||||||
2067 | 0 | 0 | sub output { | ||||
2068 | } | ||||||
2069 | # | ||||||
2070 | # output | ||||||
2071 | #------------------------------------------------------------------------------ | ||||||
2072 | |||||||
2073 | |||||||
2074 | # | ||||||
2075 | # Web::XDO::Token::Tag::WrapperContent | ||||||
2076 | ############################################################################### | ||||||
2077 | |||||||
2078 | |||||||
2079 | |||||||
2080 | ############################################################################### | ||||||
2081 | # Web::XDO::Token::Tag::XdoTest | ||||||
2082 | # | ||||||
2083 | package Web::XDO::Token::Tag::XdoTest; | ||||||
2084 | 1 | 1 | 6 | use strict; | |||
1 | 24 | ||||||
1 | 31 | ||||||
2085 | 1 | 1 | 5 | use Carp 'croak'; | |||
1 | 2 | ||||||
1 | 120 | ||||||
2086 | 1 | 1 | 17 | use base 'Web::XDO::Token::Tag'; | |||
1 | 2 | ||||||
1 | 813 | ||||||
2087 | |||||||
2088 | # note tag class | ||||||
2089 | $Web::XDO::Token::Tag::tag_classes{'xdo-test'} = __PACKAGE__; | ||||||
2090 | |||||||
2091 | =head2 Web::XDO::Token::Tag::XdoTest | ||||||
2092 | |||||||
2093 | This class represents an | ||||||
2094 | L |
||||||
2095 | tag. | ||||||
2096 | |||||||
2097 | =cut | ||||||
2098 | |||||||
2099 | # output | ||||||
2100 | sub output { | ||||||
2101 | 0 | 0 | print qq| XDO is installed \n|; |
||||
2102 | } | ||||||
2103 | |||||||
2104 | # | ||||||
2105 | # Web::XDO::Token::Tag::XdoTest | ||||||
2106 | ############################################################################### | ||||||
2107 | |||||||
2108 | |||||||
2109 | ############################################################################### | ||||||
2110 | # Web::XDO::Token::Tag::Parent | ||||||
2111 | # | ||||||
2112 | package Web::XDO::Token::Tag::Parent; | ||||||
2113 | 1 | 1 | 6 | use strict; | |||
1 | 1 | ||||||
1 | 36 | ||||||
2114 | 1 | 1 | 5 | use Carp 'croak'; | |||
1 | 2 | ||||||
1 | 42 | ||||||
2115 | 1 | 1 | 6 | use String::Util ':all'; | |||
1 | 1 | ||||||
1 | 277 | ||||||
2116 | 1 | 1 | 6 | use base 'Web::XDO::Token::Tag'; | |||
1 | 2 | ||||||
1 | 784 | ||||||
2117 | |||||||
2118 | # debug tools | ||||||
2119 | # use Debug::ShowStuff ':all'; | ||||||
2120 | |||||||
2121 | # note tag class | ||||||
2122 | $Web::XDO::Token::Tag::tag_classes{'parent'} = __PACKAGE__; | ||||||
2123 | |||||||
2124 | =head2 Web::XDO::Token::Tag::Parent | ||||||
2125 | |||||||
2126 | This class represents a | ||||||
2127 | L |
||||||
2128 | tag. | ||||||
2129 | |||||||
2130 | =cut | ||||||
2131 | |||||||
2132 | |||||||
2133 | #------------------------------------------------------------------------------ | ||||||
2134 | # output | ||||||
2135 | # | ||||||
2136 | sub output { | ||||||
2137 | 0 | 0 | my ($tag, $page, $idx) = @_; | ||||
2138 | 0 | my ($parent); | |||||
2139 | |||||||
2140 | # TESTING | ||||||
2141 | # println ' |
||||||
2142 | |||||||
2143 | # get parent, return false of there is none | ||||||
2144 | 0 | $parent = $page->parent(); | |||||
2145 | 0 | 0 | $parent or return 0; | ||||
2146 | |||||||
2147 | # output link to parent | ||||||
2148 | 0 | 0 | if ($page->is_directory_index) | ||||
2149 | 0 | { print '' } | |||||
2150 | else | ||||||
2151 | 0 | { print '' } | |||||
2152 | |||||||
2153 | # if self-ender, output title of parent and close tag | ||||||
2154 | 0 | 0 | if ($tag->{'self_ender'}) { | ||||
2155 | 0 | print $parent->title(), ''; | |||||
2156 | } | ||||||
2157 | |||||||
2158 | # else change trailing to | ||||||
2159 | else { | ||||||
2160 | 0 | my ($tokens, $next_idx); | |||||
2161 | 0 | $tokens = $page->{'tokens'}; | |||||
2162 | |||||||
2163 | # loop through tokens looking for the next (or whatever the | ||||||
2164 | # tag name is). | ||||||
2165 | TOKEN_LOOP: | ||||||
2166 | 0 | for (my $next_idx=$idx+1; $next_idx <= $#$tokens; $next_idx++) { | |||||
2167 | 0 | my $next = $tokens->[$next_idx]; | |||||
2168 | |||||||
2169 | 0 | 0 | if (UNIVERSAL::isa $next, 'Web::XDO::Token::EndTag') { | ||||
2170 | # Note that we don't assume the tag's name is "parent" because | ||||||
2171 | # XDO tags can be configured to have names other than the | ||||||
2172 | # default. | ||||||
2173 | 0 | 0 | if ($next->{'name'} eq $tag->{'name'}) { | ||||
2174 | 0 | $next->{'raw'} = ''; | |||||
2175 | 0 | $next->{'name'} = 'a'; | |||||
2176 | 0 | last TOKEN_LOOP; | |||||
2177 | } | ||||||
2178 | } | ||||||
2179 | } | ||||||
2180 | } | ||||||
2181 | } | ||||||
2182 | # | ||||||
2183 | # output | ||||||
2184 | #------------------------------------------------------------------------------ | ||||||
2185 | |||||||
2186 | |||||||
2187 | # | ||||||
2188 | # Web::XDO::Token::Tag::Parent | ||||||
2189 | ############################################################################### | ||||||
2190 | |||||||
2191 | |||||||
2192 | ############################################################################### | ||||||
2193 | # Web::XDO::Token::Tag::Path | ||||||
2194 | # | ||||||
2195 | package Web::XDO::Token::Tag::Path; | ||||||
2196 | 1 | 1 | 5 | use strict; | |||
1 | 2 | ||||||
1 | 38 | ||||||
2197 | 1 | 1 | 5 | use Carp 'croak'; | |||
1 | 1 | ||||||
1 | 57 | ||||||
2198 | 1 | 1 | 5 | use String::Util ':all'; | |||
1 | 1 | ||||||
1 | 243 | ||||||
2199 | 1 | 1 | 6 | use base 'Web::XDO::Token::Tag'; | |||
1 | 1 | ||||||
1 | 911 | ||||||
2200 | |||||||
2201 | # debug tools | ||||||
2202 | # use Debug::ShowStuff ':all'; | ||||||
2203 | |||||||
2204 | # note tag class | ||||||
2205 | $Web::XDO::Token::Tag::tag_classes{'path'} = __PACKAGE__; | ||||||
2206 | |||||||
2207 | |||||||
2208 | =head2 Web::XDO::Token::Tag::Path | ||||||
2209 | |||||||
2210 | This class represents a | ||||||
2211 | L |
||||||
2212 | tag. | ||||||
2213 | |||||||
2214 | =cut | ||||||
2215 | |||||||
2216 | |||||||
2217 | #------------------------------------------------------------------------------ | ||||||
2218 | # output | ||||||
2219 | # | ||||||
2220 | sub output { | ||||||
2221 | 0 | 0 | my ($tag, $page, $idx) = @_; | ||||
2222 | 0 | my ($top, $xdo, $atts, @path, $a_class, @tokens, $separator, $first_done); | |||||
2223 | 0 | $xdo = $page->{'xdo'}; | |||||
2224 | 0 | $atts = $tag->{'atts'}; | |||||
2225 | |||||||
2226 | # TESTING | ||||||
2227 | # println '<', $tag->{'name'}, '>'; ##i | ||||||
2228 | |||||||
2229 | # get top page | ||||||
2230 | 0 | $top = $page->top; | |||||
2231 | 0 | 0 | $top or return 0; | ||||
2232 | |||||||
2233 | # get path pages | ||||||
2234 | 0 | @path = $top->path_pages(); | |||||
2235 | |||||||
2236 | # get class for tag | ||||||
2237 | 0 | $a_class = $xdo->tag_class('a'); | |||||
2238 | |||||||
2239 | # determine separator | ||||||
2240 | 0 | 0 | if (defined $atts->{'separator'}) | ||||
2241 | 0 | { $separator = $atts->{'separator'} } | |||||
2242 | else | ||||||
2243 | 0 | { $separator = " >\n" } | |||||
2244 | |||||||
2245 | # create tag objects | ||||||
2246 | 0 | foreach my $ancestor (@path) { | |||||
2247 | 0 | my ($a, $text, $end_tag); | |||||
2248 | |||||||
2249 | # add separator if necessary | ||||||
2250 | 0 | 0 | if ($first_done) | ||||
2251 | 0 | { push @tokens, $separator } | |||||
2252 | else | ||||||
2253 | 0 | { $first_done = 1 } | |||||
2254 | |||||||
2255 | # add object to tokens array | ||||||
2256 | 0 | $a = $a_class->new(); | |||||
2257 | 0 | $a->{'type'} = 'tag'; | |||||
2258 | 0 | $a->{'name'} = 'a'; | |||||
2259 | 0 | $a->{'atts'} = {href=>$ancestor->link_path}; | |||||
2260 | 0 | $a->{'raw'} = ''; | |||||
2261 | 0 | push @tokens, $a; | |||||
2262 | |||||||
2263 | # add text object | ||||||
2264 | 0 | $text = Web::XDO::Token::Text->new(); | |||||
2265 | 0 | $text->{'type'} = 'text'; | |||||
2266 | 0 | $text->{'raw'} = $ancestor->title(path=>1); | |||||
2267 | 0 | push @tokens, $text; | |||||
2268 | |||||||
2269 | # add object | ||||||
2270 | 0 | $end_tag = Web::XDO::Token::EndTag->new(); | |||||
2271 | 0 | $end_tag->{'type'} = 'end_tag'; | |||||
2272 | 0 | $end_tag->{'name'} = 'a'; | |||||
2273 | 0 | $end_tag->{'raw'} = ''; | |||||
2274 | 0 | push @tokens, $end_tag; | |||||
2275 | } | ||||||
2276 | |||||||
2277 | # add tokens to page tokens | ||||||
2278 | 0 | 0 | if (@tokens) { | ||||
2279 | # add elements before and after token array | ||||||
2280 | 0 | unshift @tokens, ''; | |||||
2281 | 0 | push @tokens, ''; | |||||
2282 | |||||||
2283 | # add tokens to page's tokens array | ||||||
2284 | 0 | splice @{$page->{'tokens'}}, $idx+1, 0, @tokens; | |||||
0 | |||||||
2285 | } | ||||||
2286 | } | ||||||
2287 | # | ||||||
2288 | # output | ||||||
2289 | #------------------------------------------------------------------------------ | ||||||
2290 | |||||||
2291 | |||||||
2292 | # | ||||||
2293 | # Web::XDO::Token::Tag::Path | ||||||
2294 | ############################################################################### | ||||||
2295 | |||||||
2296 | |||||||
2297 | ############################################################################### | ||||||
2298 | # Web::XDO::Token::Tag::A | ||||||
2299 | # | ||||||
2300 | package Web::XDO::Token::Tag::A; | ||||||
2301 | 1 | 1 | 6 | use strict; | |||
1 | 2 | ||||||
1 | 37 | ||||||
2302 | 1 | 1 | 5 | use base 'Web::XDO::Token::Tag'; | |||
1 | 1 | ||||||
1 | 511 | ||||||
2303 | 1 | 1 | 6 | use String::Util ':all'; | |||
1 | 1 | ||||||
1 | 241 | ||||||
2304 | 1 | 1 | 6 | use Carp 'croak'; | |||
1 | 2 | ||||||
1 | 441 | ||||||
2305 | |||||||
2306 | # debug tools | ||||||
2307 | # use Debug::ShowStuff ':all'; | ||||||
2308 | |||||||
2309 | # note tag class | ||||||
2310 | $Web::XDO::Token::Tag::tag_classes{'a'} = __PACKAGE__; | ||||||
2311 | |||||||
2312 | =head2 Web::XDO::Token::Tag::A | ||||||
2313 | |||||||
2314 | This class represents an | ||||||
2315 | L |
||||||
2316 | tag. | ||||||
2317 | |||||||
2318 | =cut | ||||||
2319 | |||||||
2320 | |||||||
2321 | #------------------------------------------------------------------------------ | ||||||
2322 | # output | ||||||
2323 | # | ||||||
2324 | sub output { | ||||||
2325 | 0 | 0 | my ($tag, $page, $idx) = @_; | ||||
2326 | 0 | my ($top, $atts, $url_path, $abs_href); | |||||
2327 | 0 | $top = $page->top; | |||||
2328 | 0 | $atts = $tag->{'atts'}; | |||||
2329 | |||||||
2330 | # TESTING | ||||||
2331 | # println '<', $tag->{'name'}, '>'; ##i | ||||||
2332 | |||||||
2333 | # adjust href for root | ||||||
2334 | 0 | $tag->adjust_atts_for_root($page, 'href'); | |||||
2335 | 0 | $tag->rebuild(); | |||||
2336 | |||||||
2337 | # get absolute href path | ||||||
2338 | 0 | $abs_href = $atts->{'href'}; | |||||
2339 | 0 | 0 | defined($abs_href) or return $tag->SUPER::output($page, $idx); | ||||
2340 | 0 | $abs_href = URI->new_abs($abs_href, $top->{'url_path'}); | |||||
2341 | |||||||
2342 | # if href contains any backticks, return super method | ||||||
2343 | 0 | 0 | if ($abs_href =~ m|\.\.|s) | ||||
2344 | 0 | { return $tag->SUPER::output($page, $idx) } | |||||
2345 | |||||||
2346 | # if absolute href is the same as this page, change from to | ||||||
2347 | 0 | 0 | if ($abs_href eq $top->url_path_sans_directory_index()) { | ||||
2348 | 0 | my ($span_class, $tokens); | |||||
2349 | |||||||
2350 | # change tag name to span | ||||||
2351 | 0 | $tag->{'name'} = 'span'; | |||||
2352 | |||||||
2353 | # rebless as tag | ||||||
2354 | 0 | bless $tag, $page->{'xdo'}->tag_class('span'); | |||||
2355 | |||||||
2356 | # add current-page class | ||||||
2357 | 0 | $tag->add_class('current-page'); | |||||
2358 | |||||||
2359 | # remove href attribute | ||||||
2360 | 0 | delete $atts->{'href'}; | |||||
2361 | |||||||
2362 | # rebuild tag | ||||||
2363 | 0 | $tag->rebuild(); | |||||
2364 | |||||||
2365 | # output | ||||||
2366 | 0 | print $tag->{'raw'}; | |||||
2367 | |||||||
2368 | # get array of page's tokens | ||||||
2369 | 0 | $tokens = $page->{'tokens'}; | |||||
2370 | |||||||
2371 | # loop for closing tag and change it to | ||||||
2372 | TOKEN_LOOP: | ||||||
2373 | 0 | for (my $next_idx=$idx+1; $next_idx < @$tokens; $next_idx++) { | |||||
2374 | 0 | my $next = $tokens->[$next_idx]; | |||||
2375 | |||||||
2376 | # if end tag for this tag, change to | ||||||
2377 | 0 | 0 | if (UNIVERSAL::isa $next, 'Web::XDO::Token::EndTag') { | ||||
2378 | 0 | 0 | if ($next->{'name'} eq $tag->{'name'}) { | ||||
2379 | 0 | $next->{'name'} = 'span'; | |||||
2380 | 0 | $next->{'raw'} = ''; | |||||
2381 | 0 | last TOKEN_LOOP; | |||||
2382 | } | ||||||
2383 | } | ||||||
2384 | } | ||||||
2385 | } | ||||||
2386 | |||||||
2387 | # else output tag like normal | ||||||
2388 | else { | ||||||
2389 | 0 | return $tag->SUPER::output($page, $idx); | |||||
2390 | } | ||||||
2391 | } | ||||||
2392 | # | ||||||
2393 | # output | ||||||
2394 | #------------------------------------------------------------------------------ | ||||||
2395 | |||||||
2396 | |||||||
2397 | # | ||||||
2398 | # Web::XDO::Token::Tag::A | ||||||
2399 | ############################################################################### | ||||||
2400 | |||||||
2401 | |||||||
2402 | |||||||
2403 | # return true | ||||||
2404 | 1; | ||||||
2405 | |||||||
2406 | __END__ |