API tools faq
paste
Guest User

Untitled

a guest
Dec 18th, 2018
91
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 12.62 KB | None | 0 0
raw download clone embed print report
  1. package Text::PostTemplate;
  2. use strict;
  3. use warnings;
  4. use Carp;
  5. use Encode;
  6. use Scalar::Util qw(looks_like_number);
  7.  
  8. our $VERSION = '0.006';
  9.  
  10. my %XML_SPECIAL = (
  11. q(&) => q(&), q(<) => q(<), q(>) => q(>),
  12. q(") => q("), q(') => q(&#39;), q(\\) => q(&#92;),
  13. );
  14.  
  15. my $ALPHA = q(A-Za-z);
  16. my $DIGIT = q(0-9);
  17. my $ALNUM = q(A-Za-z0-9);
  18.  
  19. my %EMPTY_ELEMENT = map { $_ => 1 } qw(
  20. meta img link br hr input area param col base
  21. );
  22.  
  23. my %ATTRIBUTE_TYPE = (
  24. (map { $_ => 'uri' } qw(href src action)),
  25. (map { $_ => 'htmlall' } qw(value)),
  26. (map { $_ => 'bool' } qw(
  27. compact nowrap ismap declare noshade checked disabled readonly
  28. multiple selected noresize defer
  29. )),
  30. );
  31.  
  32. my %OPERATOR = (
  33. # SPECIAL OPERATOR ($op & 0xc0) == 0x00
  34. '% LIT' => [0x00, sub{}],
  35. '% VAR' => [0x01, sub{}],
  36. 'index' => [0x02, \&_op_index],
  37. 'var' => [0x03, \&_op_var],
  38. 'def' => [0x04, \&_op_def],
  39. 'put' => [0x05, \&_op_put],
  40. 'if' => [0x06, \&_op_if],
  41. 'ifelse' => [0x07, \&_op_ifelse],
  42. 'for' => [0x08, \&_op_for],
  43. 'with' => [0x09, \&_op_forall],
  44. 'forall' => [0x09, \&_op_forall],
  45. 'br' => [0x0a, \&_op_br],
  46. 'sp' => [0x0b, \&_op_sp],
  47. '% ELEM' => [0x0c, \&_op_element],
  48. '% ATTR' => [0x0d, \&_op_attribute],
  49.  
  50. # BINARY OPERATOR ($op & 0xc0) == 0x40
  51. 'exch' => [0x40, sub { ($_[1], $_[0]) }],
  52. 'add' => [0x41, sub { $_[0] + $_[1] }],
  53. 'sub' => [0x42, sub { $_[0] - $_[1] }],
  54. 'mul' => [0x43, sub { $_[0] * $_[1] }],
  55. 'div' => [0x44, sub { $_[0] / $_[1] }],
  56. 'mod' => [0x45, sub { $_[0] % $_[1] }],
  57. 'eq' => [0x46, sub { _compare(@_) == 0 ? 1 : 0 }],
  58. 'ne' => [0x47, sub { _compare(@_) != 0 ? 1 : 0 }],
  59. 'lt' => [0x48, sub { _compare(@_) < 0 ? 1 : 0 }],
  60. 'le' => [0x49, sub { _compare(@_) <= 0 ? 1 : 0 }],
  61. 'gt' => [0x4a, sub { _compare(@_) > 0 ? 1 : 0 }],
  62. 'ge' => [0x4b, sub { _compare(@_) >= 0 ? 1 : 0 }],
  63. 'get!' => [0x4c, sub { _fetch(@_, \&_escape_raw) }],
  64. 'raw_get!' => [0x4c, sub { _fetch(@_, \&_escape_raw) }],
  65. 'get' => [0x4d, sub { _fetch(@_, \&_escape_html) }],
  66. 'html_get' => [0x4d, sub { _fetch(@_, \&_escape_html) }],
  67. 'htmlall_get' => [0x4e, sub { _fetch(@_, \&_escape_htmlall) }],
  68. 'uri_get' => [0x4f, sub { _fetch(@_, \&_escape_uri) }],
  69. 'uriall_get' => [0x50, sub { _fetch(@_, \&_escape_uriall) }],
  70.  
  71. # UNARY OPERATOR ($op & 0xc0) == 0x80
  72. 'not' => [0x80, sub { ! $_[0] ? 1 : 0 }],
  73. 'neg' => [0x81, sub { -$_[0] }],
  74. 'dup' => [0x82, sub { ($_[0], $_[0]) }],
  75. 'pop' => [0x83, sub { () }],
  76. 'length' => [0x84, \&_op_length],
  77. 'int' => [0x85, sub { int $_[0] }],
  78. 'even' => [0x86, sub { $_[0] % 2 == 0 ? 1 : 0 }],
  79. 'odd' => [0x87, sub { $_[0] % 2 != 0 ? 1 : 0 }],
  80. );
  81.  
  82. my @INSTRUCTION;
  83. for my $code (values %OPERATOR) {
  84. $INSTRUCTION[$code->[0]] = $code->[1];
  85. }
  86.  
  87. sub compile {
  88. my($class, $source) = @_;
  89. my @block = ([]);
  90. my $lit = $OPERATOR{'% LIT'}[0];
  91. my $var = $OPERATOR{'% VAR'}[0];
  92. while ($source =~ m{\G(.*?)\[\%\s*(.*?)\s*\%\]\n?}gcmsx) {
  93. my($data, $word_list) = ($1, $2);
  94. if ($data ne q()) {
  95. push @{$block[-1]}, $lit, $data;
  96. }
  97. for my $word (split /\s+/msx, $word_list) {
  98. if ($word eq '{') {
  99. push @block, [];
  100. next;
  101. }
  102. if ($word eq '}') {
  103. my $a = pop @block;
  104. push @{$block[-1]}, $a;
  105. next;
  106. }
  107. if (looks_like_number($word)) {
  108. push @{$block[-1]}, $lit, $word;
  109. next;
  110. }
  111. if (length $word > 1) {
  112. if (q(/) eq (substr $word, 0, 1)) {
  113. push @{$block[-1]}, $lit, (substr $word, 1);
  114. next;
  115. }
  116. if ($word =~ m{\A%([$ALPHA][$ALNUM:_-]*)(/|!?=)?\z}mosx) {
  117. my($tag, $mode) = ($1, $2 || q());
  118. if ($mode ne q(/) && $EMPTY_ELEMENT{$tag}) {
  119. $mode = q(/);
  120. }
  121. push @{$block[-1]}, $OPERATOR{'% ELEM'}[0], $tag, $mode;
  122. next;
  123. }
  124. if (q(=) eq (substr $word, -1)
  125. && $word =~ m{\A([$ALNUM:_-]+)=\z}mosx
  126. ) {
  127. push @{$block[-1]}, $OPERATOR{'% ATTR'}[0], $1;
  128. next;
  129. }
  130. }
  131. if (exists $OPERATOR{$word}) {
  132. push @{$block[-1]}, $OPERATOR{$word}[0];
  133. }
  134. else {
  135. push @{$block[-1]}, $var, $word;
  136. }
  137. }
  138. }
  139. if (@block != 1) {
  140. croak 'Template Syntax Error';
  141. }
  142. if (pos $source) {
  143. $source = substr $source, pos $source;
  144. }
  145. if ($source ne q()) {
  146. push @{$block[-1]}, $lit, $source;
  147. }
  148. return $block[0];
  149. }
  150.  
  151. sub apply {
  152. my($class, $template, $param) = @_;
  153. my $result = _execute([q()], $template, $param);
  154. return join q(), @{$result};
  155. }
  156.  
  157. sub _execute {
  158. my($data, $block, $param) = @_;
  159. my $pc = 0;
  160. while ($pc <= $#{$block}) {
  161. my $op = $block->[$pc++];
  162. next if ref $op; # BLOCK
  163. my $code = $INSTRUCTION[$op]
  164. or croak sprintf "Template Error : undefined opcode 0x%02x", $op;
  165. if ($op == 0x00) { # LIT
  166. push @{$data}, $block->[$pc++];
  167. }
  168. elsif ($op == 0x01) { # VAR
  169. push @{$data}, _fetch($param, $block->[$pc++], \&_escape_html);
  170. }
  171. elsif (($op & 0xc0) == 0x40) { # BINARY OPERATORS
  172. my($a, $b) = splice @{$data}, -2;
  173. push @{$data}, $code->($a, $b);
  174. }
  175. elsif (($op & 0xc0) == 0x80) { # UNARY OPERATORS
  176. my $a = pop @{$data};
  177. push @{$data}, $code->($a);
  178. }
  179. else { # SPECIAL OPERATORS
  180. $code->($data, $block, $param, \$pc);
  181. }
  182. }
  183. return $data;
  184. }
  185.  
  186. sub _opland {
  187. my($block, $param, $refpc) = @_;
  188. my $opland = $block->[${$refpc}++];
  189. if (ref $opland) {
  190. my $a = _execute([], $opland, $param);
  191. return join q(), @{$a};
  192. }
  193. elsif ($opland == 0x00) {
  194. return $block->[${$refpc}++];
  195. }
  196. elsif ($opland == 0x01) {
  197. return $param->{$block->[${$refpc}++]};
  198. }
  199. return q();
  200. }
  201.  
  202. sub _op_index {
  203. my($data, $block, $param, $refpc) = @_;
  204. my $i = pop @{$data};
  205. my $r = $data->[-1 - $i];
  206. push @{$data}, $r;
  207. return;
  208. }
  209.  
  210. sub _op_var {
  211. my($data, $block, $param, $refpc) = @_;
  212. push @{$data}, $param;
  213. return;
  214. }
  215.  
  216. sub _op_def {
  217. my($data, $block, $param, $refpc) = @_;
  218. my($key, $value) = splice @{$data}, -2;
  219. _store($param, $key, $value);
  220. return;
  221. }
  222.  
  223. sub _op_put {
  224. my($data, $block, $param, $refpc) = @_;
  225. my($value, $obj, $key) = splice @{$data}, -3;
  226. _store($obj, $key, $value);
  227. return;
  228. }
  229.  
  230. sub _op_if {
  231. my($data, $block, $param, $refpc) = @_;
  232. my $cond = pop @{$data};
  233. if ($cond) {
  234. _execute($data, $block->[${$refpc} - 2], $param);
  235. }
  236. return;
  237. }
  238.  
  239. sub _op_ifelse {
  240. my($data, $block, $param, $refpc) = @_;
  241. my $cond = pop @{$data};
  242. if ($cond) {
  243. _execute($data, $block->[${$refpc} - 3], $param);
  244. }
  245. else {
  246. _execute($data, $block->[${$refpc} - 2], $param);
  247. }
  248. return;
  249. }
  250.  
  251. sub _op_for {
  252. my($data, $block, $param, $refpc) = @_;
  253. my($i, $d, $limit) = splice @{$data}, -3;
  254. while (($d > 0 && $i <= $limit) || ($d < 0 && $i >= $limit)) {
  255. push @{$data}, $i;
  256. _execute($data, $block->[${$refpc} - 2], $param);
  257. $i += $d;
  258. }
  259. return;
  260. }
  261.  
  262. sub _op_forall {
  263. my($data, $block, $param, $refpc) = @_;
  264. my $list = pop @{$data};
  265. if (ref $list ne 'ARRAY') {
  266. $list = [$list];
  267. }
  268. for my $i (0 .. $#{$list}) {
  269. my $item = $list->[$i];
  270. _execute($data, $block->[${$refpc} - 2], {
  271. %{$param},
  272. 'i' => $i,
  273. ref $item eq 'HASH' ? %{$item} : ('item' => $item),
  274. });
  275. }
  276. return;
  277. }
  278.  
  279. sub _op_br {
  280. my($data, $block, $param, $refpc) = @_;
  281. push @{$data}, "\n";
  282. return;
  283. }
  284.  
  285. sub _op_sp {
  286. my($data, $block, $param, $refpc) = @_;
  287. push @{$data}, q( );
  288. return;
  289. }
  290.  
  291. sub _op_element {
  292. my($data, $block, $param, $refpc) = @_;
  293. my $attr = [];
  294. if (${$refpc} >= 2 && ref $block->[${$refpc} - 2]) {
  295. $attr = _execute([], $block->[${$refpc} - 2], $param);
  296. }
  297. my $attrstr = join q( ), q(), @{$attr};
  298. my $tag = $block->[${$refpc}++];
  299. my $mode = $block->[${$refpc}++];
  300. if ($mode eq q(/)) {
  301. my $br = $tag eq 'br' || $tag eq 'hr' ? "\n" : q();
  302. push @{$data}, "<$tag$attrstr />$br";
  303. return;
  304. }
  305. push @{$data}, qq(<$tag$attrstr>);
  306. if (ref $block->[${$refpc}] && ! $mode) {
  307. _execute($data, $block->[${$refpc}++], $param);
  308. }
  309. else {
  310. $mode ||= q(=);
  311. my $value = _opland($block, $param, $refpc);
  312. push @{$data},
  313. $mode eq q(!=) ? _escape_raw($value)
  314. : $tag eq 'textarea' ? _escape_htmlall($value)
  315. : _escape_html($value);
  316. }
  317. push @{$data}, qq(</$tag>);
  318. return;
  319. }
  320.  
  321. sub _op_attribute {
  322. my($data, $block, $param, $refpc) = @_;
  323. my $attribute = $block->[${$refpc}++];
  324. my $value = _opland($block, $param, $refpc);
  325. my $type = $ATTRIBUTE_TYPE{$attribute} || 'html';
  326. if ($type eq 'uri') {
  327. push @{$data}, qq($attribute=") . _escape_uri($value) . q(");
  328. }
  329. elsif ($type eq 'htmlall') {
  330. push @{$data}, qq($attribute=") . _escape_htmlall($value) . q(");
  331. }
  332. elsif ($type eq 'bool') {
  333. if ($value) {
  334. push @{$data}, qq($attribute="$attribute");
  335. }
  336. }
  337. else {
  338. push @{$data}, qq($attribute=") . _escape_html($value) . q(");
  339. }
  340. return;
  341. }
  342.  
  343. sub _op_length {
  344. my($a) = @_;
  345. return ref $a eq 'ARRAY' ? $#{$a} + 1 : length $a;
  346. }
  347.  
  348. sub _compare {
  349. my($a, $b) = @_;
  350. if (looks_like_number($a) && looks_like_number($b)) {
  351. return $a <=> $b;
  352. }
  353. else {
  354. return $a cmp $b;
  355. }
  356. }
  357.  
  358. sub _fetch {
  359. my($obj, $key, $filter) = @_;
  360. $filter ||= \&_escape_html;
  361. my $value = ref $obj eq 'HASH' ? $obj->{$key}
  362. : ref $obj eq 'ARRAY' ? $obj->[$key]
  363. : eval{ $obj->can($key) } ? $obj->$key
  364. : q();
  365. return q() if ! defined $value;
  366. return $value if ref $value || looks_like_number($value);
  367. return $filter->($value);
  368. }
  369.  
  370. sub _store {
  371. my($obj, $key, $value) = @_;
  372. if (ref $obj eq 'HASH') {
  373. $obj->{$key} = $value;
  374. }
  375. elsif (ref $obj eq 'ARRAY') {
  376. $obj->[$key] = $value;
  377. }
  378. elsif (eval{ $obj->can($key) }) {
  379. $obj->$key($value);
  380. }
  381. return;
  382. }
  383.  
  384. sub _escape_htmlall {
  385. my($t) = @_;
  386. $t = defined $t ? $t : q();
  387. $t =~ s{([&<>"'\\])}{ $XML_SPECIAL{$1} }egmosx;
  388. return $t;
  389. }
  390.  
  391. sub _escape_html {
  392. my($t) = @_;
  393. $t =~ s{
  394. (?:([<>"'\\])
  395. |\&(?:([_$ALPHA][_$ALNUM]*|\#(?:[$DIGIT]{1,5}|x[[:xdigit:]]{2,4}));)?
  396. )
  397. }{
  398. $1 ? $XML_SPECIAL{$1} : $2 ? qq(\&$2;) : q(&)
  399. }egmosx;
  400. return $t;
  401. }
  402.  
  403. sub _escape_uriall {
  404. my($t) = @_;
  405. if (utf8::is_utf8($t)) {
  406. $t = Encode::encode('UTF-8', $t);
  407. }
  408. $t =~ s{([^$ALNUM\-_~/.,;:])}{ sprintf '%%%02X', ord $1 }egmosx;
  409. return $t;
  410. }
  411.  
  412. sub _escape_uri {
  413. my($t) = @_;
  414. if (utf8::is_utf8($t)) {
  415. $t = Encode::encode('UTF-8', $t);
  416. }
  417. $t =~ s{
  418. (%([[:xdigit:]]{2})?)|(&(?:amp;)?)|([^$ALNUM\-_~*+=/.!,;:\@?\#])
  419. }{
  420. $2 ? $1 : $1 ? q(%25) : $3 ? q(&) : sprintf '%%%02X', ord $4
  421. }egmosx;
  422. return $t;
  423. }
  424.  
  425. sub _escape_raw { return $_[0] }
  426.  
  427. 1;
  428.  
  429. __END__
  430.  
  431. =pod
  432.  
  433. =head1 NAME
  434.  
  435. Text::PostTemplate - One of template processors
  436.  
  437. =head1 VERSION
  438.  
  439. 0.006
  440.  
  441. =head1 SYNOPSYS
  442.  
  443. use Encode;
  444. use Text::PostTemplate;
  445.  
  446. my $template = Text::PostTemplate->compile(<<'EOS');
  447. <!DOCTYPE html>
  448. <html>
  449. <head><title>Example</title></head>
  450. <body>
  451. [%
  452. { id= /preview } %div!= entry.body br
  453.  
  454. { action= entry.postlink method= /post } %form { br
  455. { name= /token type= /hidden value= session.token } %input/ br
  456. { name= /body } %textarea= entry.body br
  457. %]<input type="submit" value=" POST " />[% br
  458. } br
  459. %]
  460. </body>
  461. </html>
  462. EOS
  463.  
  464. my $output = Text::PostTemplate->apply($template, {
  465. 'entry.postlink' => 'post.cgi',
  466. 'session.token' => 'ateEdC39ag2kng9',
  467. 'entry.body' => '<p>Hello,&nbsp;world!</p>',
  468. });
  469. print encode('UTF-8', $output);
  470.  
  471. =head1 DESCRIPTION
  472.  
  473. =head1 METHODS
  474.  
  475. =over
  476.  
  477. =item1 C<compile>
  478.  
  479. =item1 C<apply>
  480.  
  481. =back
  482.  
  483. =head1 DEPENDENCIES
  484.  
  485. L<Scalar::Util>
  486. L<Encode>
  487.  
  488. =head1 AUTHOR
  489.  
  490. MIZUTANI Tociyuki C<< <tociyuki@gmail.com> >>
  491.  
  492. =head1 LICENSE AND COPYRIGHT
  493.  
  494. Copyright (c) 2012, MIZUTANI Tociyuki C<< <tociyuki@gmail.com> >>.
  495. All rights reserved.
  496.  
  497. This module is free software; you can redistribute it and/or
  498. modify it under the same terms as Perl itself.
  499.  
  500. =cut
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!