Parse-BBCode-0.15000755001750001750 012361234004 12631 5ustar00tinatina000000000000README100644001750001750 60412361234004 13552 0ustar00tinatina000000000000Parse-BBCode-0.15 This archive contains the distribution Parse-BBCode, version 0.15: Module to parse BBCode and render it as HTML or text This software is copyright (c) 2014 by Tina Müller. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. This README file was generated by Dist::Zilla::Plugin::Readme v5.019. Changes100644001750001750 753012361234004 14212 0ustar00tinatina000000000000Parse-BBCode-0.15Revision history for Perl module Parse::BBCode 0.15 2014-07-15 16:16:00 CEST - POD, minimum perl, consistent version numbers 0.14_001 2014-07-12 23:00:00 CEST - Bugfix: multiple quoted attributes were not parsed correctly (TLoD-Snake, github #3) 0.14 Sun May 13 16:56:03 CEST 2012 - See changes from the develop versions - Make single quoting of attributes optional (see option attribute_quote) 0.13_004 Sat May 12 01:21:52 CEST 2012 - Bugfix/Change: Allow whitespaces after attributes - Change: Allow underscores in attribute names - Change: Allow single quotes in attributes (all RT#76137) 0.13_003 Mon Oct 3 13:50:16 CEST 2011 - Bugfix: closing noparse tags - new option: strip linebreaks before/after block tags is now configurable 0.13_002 Wed Sep 28 18:08:21 CEST 2011 - make attribute parsing inheritable 0.13_001 Sun Sep 25 17:03:51 CEST 2011 - Bugfix: another bugfix with short tags - Bugfix: closing tags did not happen always (RT 71018) - Bugfix: closing unclosed noparse tag (RT 71018) - Bugfix: case insensitive search for closing noparse tags (RT 70964) - Documentation Fix: default values (RT 70929) 0.13 Fri Aug 19 14:04:10 CEST 2011 - Bugfix: short tags broke tag before 0.12_005 Fri May 20 14:05:38 CEST 2011 New Feature: short tags like [cpan://Module|link title] (experimental) 0.12_004 Mon May 16 18:02:34 CEST 2011 New Feature: smiley processor 0.12_003 Mon May 16 13:16:46 CEST 2011 - New Feature: numbered lists [list=1][*]... [list=a]... - New Features: url_finder, text_processor, linebreaks 0.12_002 Tue May 10 18:17:23 CEST 2011 - New Feature: pass your own information to the rendering subroutines. See render() 0.12_001 Mon May 9 20:08:05 CEST 2011 - New Feature: Parse::BBCode::Tag: new accessors 'num' and 'level', new method 'walk' 0.12 Sat May 7 22:50:28 CEST 2011 - Security: allow only http://... and /... links (some old and some strange (MSIE) browsers interpret javascript:) - Change: [color]: allow uppercase hex colors, and allow only the 17 standard html colors - New feature: supply info hash with information on tags outside the currently processed - Change: In block tags the first and last linebreak is removed 0.11 Sun Sep 19 13:36:47 CEST 2010 - Security: change img tag to use "link" escape (filtering javascript:) - Added Parse::BBCode::Text - Added AUBBC to compare.html and bench.pl 0.10 Mon Jun 14 19:34:12 CEST 2010 - Bugfix: memleak https://rt.cpan.org/Ticket/Display.html?id=54815 - Feature: new option direct_attribute https://rt.cpan.org/Ticket/Display.html?id=53353 - Partly Bugfix: ignoring line breaks at list start/end https://rt.cpan.org/Ticket/Display.html?id=55732 0.09 Thu May 21 13:41:03 CEST 2009 - Change: Leave tags unparsed where the escape function returns undef http://rt.cpan.org/Public/Bug/Display.html?id=43845 - Don't change parameter hash http://rt.cpan.org/Public/Bug/Display.html?id=45718 - remove warning for [] - Bugfix: nested lists 0.08 Sun Mar 8 23:05:45 CET 2009 - Bugfix: two url tags following each other remained the second one unparsed - New feature: Access to attributes like [img=url align=left] through %{align}attr 0.07 Thu Feb 19 12:03:23 CET 2009 - Bugfix: Missing dependency declaration http://rt.cpan.org/Public/Bug/Display.html?id=43365 - Bugfix: Case insensitive for closing tags http://rt.cpan.org/Public/Bug/Display.html?id=42781 - Bugfix: Syntax error in output-HTML http://rt.cpan.org/Public/Bug/Display.html?id=42780 - Bugfix: Test::NoWarnings removed in test 0.06 Sun Jun 29 21:49:13 CEST 2008 - New Feature: Added single-tags like [hr], like Viacheslav Tikhanovskii suggested - New Feature: Added url-class for tags 0.05 Mon Jun 2 19:58:26 CEST 2008 - Fixed test - Changed plaintext subroutine calling arguments 0.04 Sun May 18 19:32:11 CEST 2008 - Several bugfixes, some syntax changes, added escapes 0.03 Mon May 5 21:50:39 CEST 2008 - Initial Version LICENSE100644001750001750 4365512361234004 13754 0ustar00tinatina000000000000Parse-BBCode-0.15This software is copyright (c) 2014 by Tina Müller. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2014 by Tina Müller. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2014 by Tina Müller. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End dist.ini100644001750001750 67112361234004 14342 0ustar00tinatina000000000000Parse-BBCode-0.15name = Parse-BBCode author = Tina Mueller license = Perl_5 version = 0.15 [@Basic] [PkgVersion] [AutoPrereqs] skip = ^Email::Valid skip = ^URI::Find [Prereqs] -relationship = recommends Email::Valid = 0 URI::Find = 0 perl = 5.8.0 [MetaProvides::Package] [MetaResources] repository.web = https://github.com/perlpunk/Parse-BBCode repository.url = git://github.com/perlpunk/Parse-BBCode.git repository.type = git META.yml100644001750001750 225512361234004 14167 0ustar00tinatina000000000000Parse-BBCode-0.15--- abstract: 'Module to parse BBCode and render it as HTML or text' author: - 'Tina Mueller ' build_requires: Test::More: '0' Test::NoWarnings: '0' configure_requires: ExtUtils::MakeMaker: '6.30' dynamic_config: 0 generated_by: 'Dist::Zilla version 5.019, CPAN::Meta::Converter version 2.141520' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Parse-BBCode provides: Parse::BBCode: file: lib/Parse/BBCode.pm version: '0.15' Parse::BBCode::HTML: file: lib/Parse/BBCode/HTML.pm version: '0.15' Parse::BBCode::Markdown: file: lib/Parse/BBCode/Markdown.pm version: '0.15' Parse::BBCode::Tag: file: lib/Parse/BBCode/Tag.pm version: '0.15' Parse::BBCode::Text: file: lib/Parse/BBCode/Text.pm version: '0.15' Parse::BBCode::XHTML: file: lib/Parse/BBCode/XHTML.pm version: '0.15' recommends: Email::Valid: '0' URI::Find: '0' perl: v5.8.0 requires: Carp: '0' Class::Accessor::Fast: '0' Exporter: '0' URI::Escape: '0' base: '0' strict: '0' warnings: '0' resources: repository: git://github.com/perlpunk/Parse-BBCode.git version: '0.15' MANIFEST100644001750001750 121312361234004 14040 0ustar00tinatina000000000000Parse-BBCode-0.15# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.019. Changes LICENSE MANIFEST META.yml Makefile.PL README dist.ini examples/bench.pl examples/code_download.pl examples/compare.html examples/compare.pl examples/example.pl lib/Parse/BBCode.pm lib/Parse/BBCode/HTML.pm lib/Parse/BBCode/Markdown.pm lib/Parse/BBCode/Tag.pm lib/Parse/BBCode/Text.pm lib/Parse/BBCode/XHTML.pm t/01_load.t t/02_pod.t t/03_pod_cover.t t/04_parse.t t/05_balanced.t t/06_unbalanced.t t/07_invalid.t t/08_various_tags.t t/09_close_tags.t t/10_xhtml.t t/11_markdown.t t/12_direct_attribute.t t/13_plaintext.t t/14_info.t t/15_short.t t/16_attributes.t t000755001750001750 012361234004 13015 5ustar00tinatina000000000000Parse-BBCode-0.1502_pod.t100644001750001750 36512361234004 14411 0ustar00tinatina000000000000Parse-BBCode-0.15/t# $Id: 22_pod.t 326 2006-05-30 18:20:05Z tinita $ use strict; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; my @poddirs = qw( blib ); all_pod_files_ok( all_pod_files( @poddirs ) ); 01_load.t100644001750001750 13312361234004 14536 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 2; use Test::NoWarnings; BEGIN { use_ok('Parse::BBCode'); } 14_info.t100644001750001750 1533712361234004 14632 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 16; use Parse::BBCode; use strict; use warnings; eval { require URI::Find; }; my $uri_find = $@ ? 0 : 1; SKIP: { skip "no URI::Find", 9 unless $uri_find; my $url_finder_1 = { max_length => 10, format => '%s', }; # really really simple url finder just for PoC my $url_finder_2 = sub { my ($ref_content, $post, $info) = @_; my $out = ''; while ($$ref_content =~ s{(.*)?\b(http://[^<>'" ]+)}{}g) { $out .= $post->("$1") . "<$2>"; } $out .= $post->($$ref_content); $$ref_content = $out; }; my $post = sub { my ($text, $info) = @_; my $out = ''; while ($text =~ s/(.*)( |^)(:\))(?= |$)//mgs) { my ($pre, $sp, $smiley) = ($1, $2, $3); $out .= Parse::BBCode::escape_html($pre) . $sp . '*smile*'; } $out .= Parse::BBCode::escape_html($text); return $out; }; my @tests = ( [ q#[url]http://foo/[/url]#, q#http://foo/#, $url_finder_1 ], [ q#[url=http://foo/]
[/url]#, q#<hr>#, $url_finder_1 ], [ qq#http://foo/\ntest#, qq#http://foo/\ntest#, 1, undef, 0], [ q#
http://foo/#, qq#<hr> #, $url_finder_2], [ q#http://foo/#, qq#http://foo...#, $url_finder_1 ], [ q#[url=http://foo/] :) [/url] :)#, q# *smile* *smile*#, $url_finder_1, $post ], [ q#[url=http://foo/] :) [/url] :)#, q# *smile* *smile*#, 0, $post ], [ qq#[url=http://foo/] :) [/url]\n :)#, qq# *smile* \n *smile*#, 0, $post, 0 ], [ qq#[url=http://foo/] :) [/url]\n :)#, qq# *smile*
\n *smile*#, 0, $post, 1 ], ); for my $test (@tests) { my ($text, $exp, $url_finder, $post, $linebreaks) = @$test; unless (defined $linebreaks) { $linebreaks = 1; } my $p = Parse::BBCode->new({ url_finder => $url_finder, text_processor => $post, linebreaks => $linebreaks, tags => { 'url' => 'url:%s', }, } ); my $title = ref $url_finder ? 'http://foo...' : 'http://foo/'; my $parsed = $p->render($text); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; #s/[\r\n]//g for ($exp, $parsed); $text =~ s/\r/\\r/g; $text =~ s/\n/\\n/g; cmp_ok($parsed, 'eq', $exp, "parse '$text'"); } } my $p = Parse::BBCode->new({ tags => { 'list' => { parse => 1, class => 'block', code => sub { my ($parser, $attr, $content, $attribute_fallback, $tag, $info) = @_; $$content =~ s/^\n+//; $$content =~ s/\n+\z//; return "
    $$content
"; }, }, '*' => { parse => 1, code => sub { my ($parser, $attr, $content, $attribute_fallback, $tag, $info) = @_; $$content =~ s/\n+\z//; $$content = "
  • $$content
    • "; unless ($info->{stack}->[-2] eq 'list') { return $tag->raw_text; } return $$content; }, close => 0, class => 'block', }, 'quote' => 'block:
    %{html}a:%s
    ', }, } ); my @tests = ( [ qq#[list]\n[*]1\n[*]2\n[/list]#, q#
    • 1
    • 2
    # ], [ q#[quote][*]1[*]2[/quote]#, q#
    :[*]1[*]2
    # ], ); for my $test (@tests) { my ($text, $exp, $forbid, $parser) = @$test; $parser ||= $p; if ($forbid) { $parser->forbid($forbid); } my $parsed = $parser->render($text); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; s/[\r\n]//g for ($exp, $parsed); $text =~ s/[\r\n]//g; cmp_ok($parsed, 'eq', $exp, "parse '$text'"); } $p = Parse::BBCode->new(); my $bbcode = q#start [b]1[/b][b]2[b]3[/b][b]4[/b] [b]5 [b]6[/b] [/b] [/b]#; my $tree = $p->parse($bbcode); my $tag = $tree->get_content->[3]->get_content->[1]; my $num = $tag->get_num; my $level = $tag->get_level; cmp_ok($num, '==', 3, "get_num"); cmp_ok($level, '==', 2, "get_level"); $p = Parse::BBCode->new({ tags => { code => { code => sub { my ($parser, $attr, $content, $attribute_fallback, $tag, $info) = @_; my $title = Parse::BBCode::escape_html($attr); my $code = Parse::BBCode::escape_html($$content); my $aid = $parser->get_params->{article_id}; my $cid = $tag->get_num; return <<"EOM"; Download $code EOM }, }, }, }); $bbcode = "[code=1]test[/code]"; my $rendered = $p->render($bbcode, { article_id => 23 }); cmp_ok($rendered, '=~', 'code\?article_id=23;code_id=1', "params"); $p = Parse::BBCode->new({ smileys => { icons => {qw/ :-) smile.png :-( sad.png :-P tongue.gif :-'| cold.png /}, base_url => '/icons/', # sprintf format format => '%2$s', }, text_processor => sub { my ($text) = @_; $text = uc $text; return Parse::BBCode::escape_html($text); }, }); @tests = ( [ qq#:-)[b]bold
    :-)[/b] :-(\n:-P :-'|\ntest:-P end#, qq#:-)BOLD<HR> :-) :-(
    \n:-P :-&\#39;|
    \nTEST:-P END# ], [q#:-) :-)#, q#:-) :-)#], ); for my $test (@tests) { my ($text, $exp) = @$test; my $parsed = $p->render($text); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; $text =~ s/\r/\\r/g; $text =~ s/\n/\\n/g; cmp_ok($parsed, 'eq', $exp, "parse '$text'"); } Makefile.PL100644001750001750 250512361234004 14666 0ustar00tinatina000000000000Parse-BBCode-0.15 # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.019. use strict; use warnings; use ExtUtils::MakeMaker 6.30; my %WriteMakefileArgs = ( "ABSTRACT" => "Module to parse BBCode and render it as HTML or text", "AUTHOR" => "Tina Mueller ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.30" }, "DISTNAME" => "Parse-BBCode", "EXE_FILES" => [], "LICENSE" => "perl", "NAME" => "Parse::BBCode", "PREREQ_PM" => { "Carp" => 0, "Class::Accessor::Fast" => 0, "Exporter" => 0, "URI::Escape" => 0, "base" => 0, "strict" => 0, "warnings" => 0 }, "TEST_REQUIRES" => { "Test::More" => 0, "Test::NoWarnings" => 0 }, "VERSION" => "0.15", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Carp" => 0, "Class::Accessor::Fast" => 0, "Exporter" => 0, "Test::More" => 0, "Test::NoWarnings" => 0, "URI::Escape" => 0, "base" => 0, "strict" => 0, "warnings" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); 15_short.t100644001750001750 454712361234004 15020 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 10; use Parse::BBCode; use strict; use warnings; my $p = Parse::BBCode->new({ tags => { Parse::BBCode::HTML->defaults, wikipedia => { short => 1, output => '%{parse}s', class => 'url', classic => 0, }, thread => { class => 'url', output => 'Thread: %s (%A)', short => 1, classic => 1, }, doc => { class => 'url', output => qq{%{uri}A.html:%s}, short => 1, classic => 1, }, }, } ); my @tests = ( [ qq#test [wikipedia://Harold & Maude|Movie] end#, q#test Movie end# ], [ qq#[b]test [wikipedia://Harold & Maude|Movie] end[/b]#, q#test Movie end# ], [ qq#[url=http://perl.org/]test [wikipedia://Harold & Maude|Movie] end[/url]#, q#test [wikipedia://Harold & Maude|Movie] end# ], [ qq#test [wikipedia://Harold & Maude end#, q#test [wikipedia://Harold & Maude end# ], [ qq#test [thread://1] test [thread]1[/thread] end#, q#test Thread: 1 (1) test Thread: 1 (1) end# ], [ qq#test [thread://1|title
    ] test [thread=1]title
    [/thread] end#, q#test Thread: title <hr> (1) test Thread: title <hr> (1) end# ], [ qq#test [thread://] end#, q#test [thread://] end# ], [ qq#[b]test[/b] [thread://1] [i]end[/i]#, q#test Thread: 1 (1) end# ], [ qq#[b]test[/b] [thread=1]test[/thread] [thread://1] [i]end[/i]#, q#test Thread: test (1) Thread: 1 (1) end# ], [ qq#[doc=perlipc]ipc[/doc] [doc://perlipc]#, q#perlipc.html:ipc perlipc.html:perlipc# ], ); for my $test (@tests) { my ($text, $exp, $forbid, $parser) = @$test; $parser ||= $p; if ($forbid) { $parser->forbid($forbid); } my $parsed = $parser->render($text); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; s/[\r\n]//g for ($exp, $parsed); $text =~ s/[\r\n]//g; cmp_ok($parsed, 'eq', $exp, "parse '$text'"); } 04_parse.t100644001750001750 1707012361234004 15004 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 86; use Test::NoWarnings; use Parse::BBCode; use strict; use warnings; my %tag_def_html = ( perlmonks => '%{parse}s', ); eval { require Email::Valid; }; my $email_valid = $@ ? 0 : 1; #$email_valid = 0; my $bbc2html = Parse::BBCode->new({ tags => { Parse::BBCode::HTML->defaults, %tag_def_html, 'img' => '[%{html}s]', }, } ); my $bbc2html_sq = Parse::BBCode->new({ tags => { Parse::BBCode::HTML->defaults, %tag_def_html, 'img' => '[%{html}s]', }, attribute_quote => q/'/, } ); my $bbc2html_sdq = Parse::BBCode->new({ tags => { Parse::BBCode::HTML->defaults, %tag_def_html, 'img' => '[%{html}s]', }, attribute_quote => q/'"/, } ); my $bbc2html2 = Parse::BBCode->new({ close_open_tags => 1, escapes => { Parse::BBCode::HTML->default_escapes, }, }); my $bbc2html_block = Parse::BBCode->new({ tags => { Parse::BBCode::HTML->defaults, %tag_def_html, '' => sub { my $outer = $_[1]; my $block = $outer->get_class eq 'block' ? 1 : 0; my $text = Parse::BBCode::escape_html($_[2]); if ($block) { $text =~ s[ (\r?\n|\r) (\r?\n|\r)* ] [if ($2) { "

    " } else { "
    \n" } ]exg; } else { $text =~ s[ (\r?\n|\r) ][
    ]xg; } $text; }, }, } ); my $pns = Parse::BBCode->new({ tags => { b => '%s', }, strict_attributes => 0, } ); my @tests = ( [ q#[img://23]#, q#[img://23]# ], [ q#[img=foo align=center]test[/img]#, q#[test]# ], [ q#[img=foo align='center']test[/img]#, q#[test]#, undef, $bbc2html_sq ], [ q#[img=foo align='center']test[/img]#, q#[test]#, undef, $bbc2html_sdq ], [ q#[img=foo align="center" ]test[/img]#, q#[test]# ], [ q#[url=/test]foo[/url] bla [url=/test2]foo2[/url]#, q#foo bla foo2#], [ q#[B]bold? [test#, q#[B]bold? [test# ], [ q#[B]bold[/B]#, q#bold# ], [ q#[b]bold[/B]#, q#bold# ], [ q#[b foo bar]bold[/B]#, q#bold#, undef, $pns], [ q#[i=23]italic [b]bold italic [/b][/i]# . "$/$/", q#italic bold italic <html>
    # ], [ q#[U][noparse][u][c][/noparse][/u]# . "$/$/", q#<html>[u][c]
    # ], [ q#[img=foo.jpg]desc [/img]#, q#[desc <html>]# ], [ q#[url=javascript:alert(123)]foo [i]italic[/i][/url]#, q#[url=javascript:alert(123)]foo <html>italic[/url]# ], [ q#[url=http://foo]foo [i]italic[/i][/url]#, q#foo <html>italic# ], [ q#[email=no"mail]mail [i]me[/i][/email]#, $email_valid ? q#mail me# : q#mail me# ], [ q#[email="test "]mail [i]me[/i][/email]#, $email_valid ? q#mail me# : q#mail me#], [ q#[email]test [/email]#, $email_valid ? q#test <foo@example.org># : q#test <foo@example.org>#], [ q#[size=7]big[/size]#, q#big# ], [ q#[size=huge!]big[/size]#, q#big# ], [ q{[color=#0000FF]blue[/color]}, q{blue} ], [ q{[color="red"]blue[/color]}, q{blue} ], [ q{[color="no color!"]blue[/color]}, q{blue} ], [ q#[list][*]first[*]second[*]third[/list]#, q#

    • first
    • second
    • third
    # ], [ q#[quote=who]cite <>[/quote]#, q#
    who:
    cite <>
    # ], [ q#[code]use strict;[/code]#, q#
    Code:
    use strict;
    # ], [ q#[perlmonks=123]foo [i]italic[/i][/perlmonks]# . "$/$/", q#foo <html>italic
    # ], [ q#[noparse]foo[b][/noparse]#, q#foo[b]# ], [ q#[noparse]foo[b][/NOPARSE]#, q#foo[b]# ], [ q#[code]foo[code]bar[/code][/code]#, q#
    Code:
    foo[code]bar<html>
    [/code]# ], [ q#[i]italic [b]bold italic [/i][/b]#, q#italic [b]bold italic <html>[/b]#, undef, undef, 1 ], [ q#[i]italic [b]bold italic [/i][/b]#, q#[i]italic bold italic <html>[/i]#, 'i' ], [ "outer\n\nnewline\n" . qq# [i]inner\n\nnewline[/i]#, q#outer

    newline
    inner

    newline    #, undef, $bbc2html_block ], [ qq#[url=http://foo/][url=http://bar/]test[/url][/url]#, q#[url=http://bar/]test[/url]#, ], [ q#[url=relative]test[/url]#, q#[url=relative]test[/url]#, ], [ q#0#, q#0#, ], [ q# [] #, q# [] #, ], [ q#[b]test[/i]#, q#test[/i]#, undef, $bbc2html2, 1], [ q#[noparse="bar"]test[/noparse]#, q#test#], [ q#[noparse="bar" baz="boo"]test[/noparse]#, q#test#], [ q#[noparse="bar" bar="baz" baz="boo"]test[/noparse]#, q#test#], ); for my $test (@tests) { my ($text, $exp, $forbid, $parser, $error) = @$test; $error = 0 unless defined $error; $parser ||= $bbc2html; if ($forbid) { $parser->forbid($forbid); } my $parsed = $parser->render($text); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; s/[\r\n]//g for ($exp, $parsed); $text =~ s/[\r\n]//g; cmp_ok($parser->get_error ? 1 : 0, '==', $error, "error $text"); cmp_ok($parsed, 'eq', $exp, "parse '$text'"); if ($forbid) { $parser->permit($forbid); } } eval { my $parsed = $bbc2html->render(); }; my $error = $@; #warn __PACKAGE__.':'.__LINE__.": <<$@>>\n"; cmp_ok($error, '=~', 'Missing input', "Missing input for render()"); $bbc2html->permit('foobar'); my $allowed = $bbc2html->get_allowed; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$allowed], ['allowed']); ok( (!grep { $_ eq 'foobar' } @$allowed), "permit() an unsupported tag"); my %tags = Parse::BBCode->defaults; my $bb1 = Parse::BBCode->new({ tags => \%tags }); my $bb2 = Parse::BBCode->new({ tags => \%tags }); my $render1 = $bb1->render("\n"); my $render2 = $bb2->render("\n"); cmp_ok($render2, 'eq', $render1, "don't change parameter hash"); 10_xhtml.t100644001750001750 625412361234004 15005 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 22; use Test::NoWarnings; use Parse::BBCode::XHTML; use strict; use warnings; eval { require Email::Valid; }; my $email_valid = $@ ? 0 : 1; #$email_valid = 0; my $parser = Parse::BBCode::XHTML->new(); my @tests = ( [ q#[B]bold? [test#, q#[B]bold? [test# ], [ q#[i=23]italic [b]bold italic [/b][/i]# . "$/$/", q#italic bold italic <html>
    # ], [ q#[U][noparse][u][c][/noparse][/u]# . "$/$/", q#<html>[u][c]
    # ], [ q#[img=/foo.jpg]desc [/img]#, q#[desc <html>]# ], [ q#[url=javascript:alert(123)]foo [i]italic[/i][/url]#, q#[url=javascript:alert(123)]foo <html>italic[/url]# ], [ q#[url=http://foo]foo [i]italic[/i][/url]#, q#foo <html>italic# ], [ q#[email=no"mail]mail [i]me[/i][/email]#, $email_valid ? q#mail me# : q#mail me# ], [ q#[email="test "]mail [i]me[/i][/email]#, $email_valid ? q#mail me# : q#mail me#], [ q#[email]test [/email]#, $email_valid ? q#test <foo@example.org># : q#test <foo@example.org>#], [ q#[size=7]big[/size]#, q#big# ], [ q#[size=huge!]big[/size]#, q#big# ], [ q{[color=#0000FF]blue[/color]}, q{blue} ], [ q{[color="red"]blue[/color]}, q{blue} ], [ q{[color="no color!"]blue[/color]}, q{blue} ], [ q#[list][*]first[*]second[*]third[/list]#, q#

    • first
    • second
    • third
    # ], [ q#[quote=who]cite[/quote]#, q#
    who:
    cite
    # ], [ q#[code]use strict;[/code]#, q#
    Code:
    use strict;
    # ], [ q#[noparse]foo[b][/noparse]#, q#foo[b]# ], [ q#[code]foo[code]bar[/code][/code]#, q#
    Code:
    foo[code]bar<html>
    [/code]# ], [ q#[i]italic [b]bold italic [/i][/b]#, q#italic [b]bold italic <html>[/b]# ], [ q#[i]italic [b]bold italic [/i][/b]#, q#[i]italic bold italic <html>[/i]#, 'i' ], ); for my $test (@tests) { my ($text, $exp, $forbid) = @$test; if ($forbid) { $parser->forbid($forbid); } my $parsed = $parser->render($text); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; s/[\r\n]//g for ($exp, $parsed); $text =~ s/[\r\n]//g; cmp_ok($parsed, 'eq', $exp, "parse '$text'"); if ($forbid) { $parser->permit($forbid); } } 07_invalid.t100644001750001750 303312361234004 15275 0ustar00tinatina000000000000Parse-BBCode-0.15/t#!/usr/bin/perl use Test::More tests => 9; use Test::NoWarnings; use Parse::BBCode; use strict; use warnings; my %tag_def_html = ( code => { parse => 0, code => sub { "%{}s" }, }, pre => { code => sub { "" }, }, a => '%{parse}s', b => '%{parse}s', c => '%{parse}s', ); my $p = Parse::BBCode->new({ tags => { %tag_def_html, }, } ); my @tests = ( [ q#test [c=invalid bar]foo[b]inner[/b][/c][b]valid[/b]#, q#test fooinnervalid#, q#test [c=invalid bar]fooinner[/c]valid#, ], [ q#test [c=]foo[b]inner[/b][/c][b]valid[/b]#, q#test fooinnervalid#, q#test [c=]fooinner[/c]valid#, ], [ q#test [c]foo[b]inner[/b][/c][b]valid[/b]#, q#test fooinnervalid#, q#test fooinnervalid#, ], [ q#test [c!invalid bar]foo[b]inner[/b][/c][b]valid[/b]#, q#test [c!invalid bar]fooinner[/c]valid#, q#test [c!invalid bar]fooinner[/c]valid#, ], ); for my $strict (0 .. 1) { $p->set_strict_attributes($strict); for (@tests) { my ($in) = @$_; my $exp = $strict ? $_->[2] : $_->[1]; my $parsed = $p->render($in); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; cmp_ok($parsed, 'eq', $exp, "$in"); } } 05_balanced.t100644001750001750 235312361234004 15402 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 8; use Test::NoWarnings; use Parse::BBCode; use strict; use warnings; my %tag_def_html = ( code => { parse => 0, code => sub { "" }, }, pre => { code => sub { "" }, }, a => '%{parse}s', b => '%{parse}s', c => '%{parse}s', ); my $bbc2html = Parse::BBCode->new({ tags => { %tag_def_html, }, } ); sub contains_untranslated { my $str = shift; $str =~ m/\[\w+\]/; } my @tests = ( [q{[a][b][/b][/a]}, q{}], [q{[a][b][a][b][/b][/a][/b][/a]}, q{}], [q{[a][a][a][/a][a][/a][/a][a][/a][/a]},q{}], [q{[code][a][c][/code]}, q{}], [q{[a][code][a][c][/code][/a]}, q{}], [q{[a][code][/a][/code][/a]}, q{}], [q{[a][b][code][/a][/b][c][/code][/b][/a]},q{}], ); for (@tests){ my $parsed = $bbc2html->render($_->[0]); is $parsed, $_->[1], $_->[0]; } 11_markdown.t100644001750001750 443312361234004 15471 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 12; use Test::NoWarnings; use_ok('Parse::BBCode::Markdown'); use strict; use warnings; my $p = Parse::BBCode::Markdown->new({ }); my @tests = ( [ q#[size=7]big [b]bold[/b] text[/size]#, q#big *bold* text# ], [ q#[url=http://foo/]interesting [b]bold[/b] link[/url]#, q#[interesting *bold* link](http://foo/)# ], [ q#[url="http://foo/"]interesting [b]bold[/b] link[/url]#, q#[interesting *bold* link](http://foo/)# ], [ q#[url=/foo]interesting [b]bold[/b] link[/url]#, q#[interesting *bold* link](/foo)# ], [ q#[code=perl]say "foo";[/code]#, qq#Code perl:\n--------------------\n| say "foo";\n--------------------# ], # TODO # [ q#[list=1][*]first[*]second[*]third[/list]#, # q#
    • first
    • second
    • third
    # ], # [ q#[list=1][*]first with [url]foo[/url][*]second[*]third[/list]#, # q#
    • first with foo
    • second
    • third
    # ], # [ q#[list=1][*]first[*]second with [url]foo[/url][*]third[/list]#, # q#
    • first
    • second with foo
    • third
    # ], # [ q#[list=1][*]first[*]second with [url]foo[*]third[/list]#, # q#
    • first
    • second with [url]foo
    • third
    # ], # [ q#[list=1][*]first[*]second with [url]foo and [b]bold[/b][*]third[/list]#, # q#
    • first
    • second with [url]foo and bold
    • third
    # ], [ q#[img]/path/to/image.png[/img]#, q#![/path/to/image.png](/path/to/image.png)# ], [ q#[img=/path/to/image.png]description[/img]#, q#![description](/path/to/image.png)# ], [ q#[img=/path/to/image.png]description [b]with bold[/b][/img]#, q#![description *with bold*](/path/to/image.png)# ], [ qq#text [quote="foo"][quote="bar"]inner quote[/quote]outer quote[/quote]#, qq#text foo:\n> bar:\n>> inner quote\n> outer quote\n# ], [ q#[quote="admin@2008-06-27 19:00:25"][quote="foo@2007-08-13 22:12:32"]test[/quote]test[/quote]#, qq#admin\@2008-06-27 19:00:25:\n> foo\@2007-08-13 22:12:32:\n>> test\n> test\n# ], ); for (@tests) { my ($in, $exp) = @$_; my $parsed = $p->render($in); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; cmp_ok($parsed, 'eq', $exp, "$in"); } 03_pod_cover.t100644001750001750 64312361234004 15607 0ustar00tinatina000000000000Parse-BBCode-0.15/t# $Id: 24_pod_cover.t 668 2006-10-02 16:09:19Z tinita $ use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage required for testing pod coverage" if $@; plan tests => 3; pod_coverage_ok( "Parse::BBCode", "Parse::BBCode is covered"); pod_coverage_ok( "Parse::BBCode::Tag", "Parse::BBCode::Tag is covered"); pod_coverage_ok( "Parse::BBCode::HTML", "Parse::BBCode::HTML is covered"); 13_plaintext.t100644001750001750 356112361234004 15662 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 16; use Test::NoWarnings; use_ok('Parse::BBCode::Text'); use strict; use warnings; my $p = Parse::BBCode::Text->new(); my @tests = ( [ q#[size=7]big [b]bold[/b] text[/size]#, q#big bold text# ], [ q#[url=http://foo/]interesting [b]bold[/b] link[/url]#, q#interesting bold link# ], [ q#[url="http://foo/"]interesting [b]bold[/b] link[/url]#, q#interesting bold link# ], [ q#[url=/foo]interesting [b]bold[/b] link[/url]#, q#interesting bold link# ], [ q#[list=1][*]first[*]second[*]third[/list]#, qq#* first\n* second\n* third\n# ], [ q#[list=1][*]first with [url]foo[/url][*]second[*]third[/list]#, qq#* first with foo\n* second\n* third\n# ], [ q#[list=1][*]first[*]second with [url]foo[/url][*]third[/list]#, qq#* first\n* second with foo\n* third\n# ], [ q#[list=1][*]first[*]second with [url]foo[*]third[/list]#, qq#* first\n* second with [url]foo\n* third\n# ], [ q#[list=1][*]first[*]second with [url]foo and [b]bold[/b][*]third[/list]#, qq#* first\n* second with [url]foo and bold\n* third\n# ], [ q#[img]/path/to/image.png[/img]#, q#/path/to/image.png# ], [ q#[img=/path/to/image.png]description[/img]#, q#description# ], [ q#[img=/path/to/image.png]description [b]with bold[/b][/img]#, q#description with bold# ], [ qq#text [quote="foo"][quote="bar"]inner quote[/quote]outer quote[/quote]#, qq#text foo:\n> bar:\n>> inner quote\n> outer quote\n# ], [ q#[quote="admin@2008-06-27 19:00:25"][quote="foo@2007-08-13 22:12:32"]test[/quote]test[/quote]#, qq#admin\@2008-06-27 19:00:25:\n> foo\@2007-08-13 22:12:32:\n>> test\n> test\n# ], ); for (@tests) { my ($in, $exp) = @$_; my $parsed = $p->render($in); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; cmp_ok($parsed, 'eq', $exp, "$in"); } examples000755001750001750 012361234004 14370 5ustar00tinatina000000000000Parse-BBCode-0.15bench.pl100644001750001750 517712361234004 16156 0ustar00tinatina000000000000Parse-BBCode-0.15/examples#!/usr/bin/perl use strict; use warnings; use Carp qw(carp croak); use Data::Dumper; use Benchmark; my %loaded; for (qw/ BBCode::Parser Parse::BBCode HTML::BBCode HTML::BBReverse AUBBC /) { eval "use $_"; unless ($@) { $loaded{$_} = $_->VERSION; } } print "Benchmarking...\n"; for my $key (sort keys %loaded) { print "$key\t$loaded{$key}\n"; } my $code = <<'EOM'; [b]bold [i]italic[/i] test[/b] [code]some [perl] code[/code] [url=http://foo.example.org/]a link![/url] EOM my ($count, $multiply) = @ARGV; $multiply ||= 1; $code = $code x $multiply; sub create_au { my $pb = AUBBC->new(); return $pb; } sub create_pb { my $pb = Parse::BBCode->new({ tags => { b => '%s', i => '%s', url => '%s', code =>'block:
    Code:
    %{noparse}s
    ', }, }); return $pb; } sub create_hb { my $bbc = HTML::BBCode->new(); return $bbc; } sub create_bp { my $parser = BBCode::Parser->new(follow_links => 1); return $parser; } sub create_bbr { my $bbr = HTML::BBReverse->new(); return $bbr; } my ($pb, $bp, $hb, $bbr, $au); if ($loaded{'Parse::BBCode'}) { $pb = create_pb(); my $rendered1 = $pb->render($code); #print "$rendered1\n"; } if ($loaded{'BBCode::Parser'}) { $bp = create_bp(); my $tree = $bp->parse($code); my $rendered2 = $tree->toHTML(); #print "$rendered2\n"; } if ($loaded{'HTML::BBCode'}) { $hb = create_hb(); my $rendered3 = $hb->parse($code); #print "$rendered3\n"; } if ($loaded{'HTML::BBReverse'}) { $bbr = create_bbr(); my $rendered4 = $bbr->parse($code); #print "$rendered4\n"; } if ($loaded{'AUBBC'}) { $au = create_au(); my $rendered5 = $au->do_all_ubbc($code); #print "$rendered4\n"; } timethese($count || -1, { $loaded{'Parse::BBCode'} ? ( 'P::B::new' => \&create_pb, 'P::B' => sub { my $out = $pb->render($code) }, ) : (), $loaded{'HTML::BBCode'} ? ( 'H::B::new' => \&create_hb, 'H::B' => sub { my $out = $hb->parse($code) }, ) : (), $loaded{'BBCode::Parser'} ? ( 'B::P::new' => \&create_bp, 'B::P' => sub { my $tree = $bp->parse($code); my $out = $tree->toHTML(); }, ) : (), $loaded{'HTML::BBReverse'} ? ( 'BBR::new' => \&create_bbr, 'BBR' => sub { my $out = $bbr->parse($code); }, ) : (), $loaded{'AUBBC'} ? ( 'AUBBC::new' => \&create_bbr, 'AUBBC' => sub { my $out = $au->do_all_ubbc($code); }, ) : (), }); 16_attributes.t100644001750001750 775612361234004 16055 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 6; use Parse::BBCode; use strict; use warnings; package Parse::BBCode::MyAttr; use base 'Parse::BBCode'; sub parse_attributes { my ($self, %args) = @_; my $text = $args{text}; my $tagname = $args{tag}; if ($tagname eq 'b') { my $attr_string = ''; my $end = ''; my @array = ['']; my $i = 0; while ($$text =~ s/( )([^\]\s]+)//) { $i++; my $val = $2; $attr_string .= "$1$2"; push @array, [$i, $val]; } if ($$text =~ s/^\]//) { $end = ']'; } else { return (0, [], $attr_string, $end); } return (1, [@array], $attr_string, $end); } elsif ($tagname eq 'quote') { my $attr_string = ''; my $end = ''; my @array; if ($$text =~ s/=([^,]+),(\d{2}\.\d{2}\.\d{4}, \d{2}:\d{2})\]//) { my $nick = $1; my $date = $2; $attr_string = "=$nick,$date"; $end = ']'; @array = ["$nick, $date"]; return (1, [@array], $attr_string, $end); } else { return (0, [], $attr_string, $end); } } else { return shift->SUPER::parse_attributes(@_); } } package main; my $parse_attributes = \&Parse::BBCode::MyAttr::parse_attributes; my $p = Parse::BBCode::MyAttr->new({ tags => { Parse::BBCode::HTML->defaults, 'quote' => { code => sub { my ($parser, $attr, $content) = @_; my $title = 'Quote'; if ($attr) { $title = Parse::BBCode::escape_html($attr); } return <<"EOM";
    $title:
    $$content
    EOM }, parse => 1, class => 'block', }, test_attr => { code => sub { my ($parser, $attr, $content, undef, $tag) = @_; return $tag->get_attr_raw; }, }, }, } ); my $sr = Parse::BBCode->new({ tags => { Parse::BBCode::HTML->defaults, 'quote' => { code => sub { my ($parser, $attr, $content) = @_; my $title = 'Quote'; if ($attr) { $title = Parse::BBCode::escape_html($attr); } return <<"EOM";
    $title:
    $$content
    EOM }, parse => 1, class => 'block', }, test_attr => { code => sub { my ($parser, $attr, $content, undef, $tag) = @_; return $tag->get_attr_raw; }, }, }, attribute_parser => $parse_attributes, } ); my @tests = ( [ qq#test [b foo bar]bold[/b]#, q#test bold# ], [ qq#test [quote=username,27.09.2011, 18:30]quoted[/quote]#, q#test
    username, 27.09.2011, 18:30:
    quoted
    # ], [ qq#test [test_attr=foo_bar]boo[/test_attr]#, q#test =foo_bar# ], [ qq#test [b foo bar]bold[/b]#, q#test bold#, $sr ], [ qq#test [quote=username,27.09.2011, 18:30]quoted[/quote]#, q#test
    username, 27.09.2011, 18:30:
    quoted
    #, $sr ], [ qq#test [test_attr=foo_bar]boo[/test_attr]#, q#test =foo_bar#, $sr ], ); for my $test (@tests) { my ($text, $exp, $parser) = @$test; $parser ||= $p; my $parsed = $parser->render($text); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; s/[\r\n]//g for ($exp, $parsed); $text =~ s/[\r\n]//g; cmp_ok($parsed, 'eq', $exp, "parse '$text'"); } 09_close_tags.t100644001750001750 550312361234004 16000 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 20; use Test::NoWarnings; use Parse::BBCode; use strict; use warnings; my $p = Parse::BBCode->new({ tags => { '' => sub { Parse::BBCode::escape_html($_[2]) }, i => '%s', b => '%{parse}s', size => '%{parse}s', url => '%{parse}s', quote => 'block:%{parse}s', noparse => '%{html}s', }, close_open_tags => 1, } ); my @tests = ( [ 1, q#[i]italic[b]bold [quote]this is invalid[/quote] bold[/b][/i]#, q#italicbold this is invalid bold[/b][/i]#, q#[i]italic[b]bold [/b][/i][quote]this is invalid[/quote] bold[/b][/i]#, ], [ 0, q#[i]italic[b]bold [quote]this is invalid[/quote] bold[/b][/i]#, q#[i]italic[b]bold this is invalid bold[/b][/i]#, q#[i]italic[b]bold [quote]this is invalid[/quote] bold[/b][/i]#, ], [ 0, q#[i]italic[b]bold[/b] [quote]this is invalid[/quote] [/i]#, q#[i]italicbold this is invalid [/i]#, q#[i]italic[b]bold[/b] [quote]this is invalid[/quote] [/i]#, ], [ 1, q#[i]italic[b]bold [url]/foo[/url]#, q#italicbold /foo#, q#[i]italic[b]bold [url]/foo[/url][/b][/i]#, ], [ 1, q#[b][i]italic#, q#italic#, q#[b][i]italic[/i][/b]#, ], [ 1, q#[b][i]italic[/b]#, q#italic#, q#[b][i]italic[/i][/b]#, ], [ 0, q#[noparse][b][i]italic[/i][/b]#, q#[noparse]italic#, q#[noparse][b][i]italic[/i][/b]#, ], [ 1, q#[noparse][b][i]italic[/i][/b]#, q#[b][i]italic[/i][/b]#, q#[noparse][b][i]italic[/i][/b][/noparse]#, ], [ 1, q#[noparse][i]italic#, q#[i]italic#, q#[noparse][i]italic[/noparse]#, ], [ 1, q#[quote][noparse][i]italic#, q#[i]italic#, q#[quote][noparse][i]italic[/noparse][/quote]#, ], ); for (@tests) { my ($close, $in, $exp, $exp_raw) = @$_; $p->set_close_open_tags($close); my $parsed = $p->render($in); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; my $close_string = $close ? 'yes' : 'no'; cmp_ok($parsed, 'eq', $exp, "invalid (close? $close_string) $in"); my $err = $p->error('block_inline') || $p->error('unclosed'); if ($err) { #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$err], ['err']); my $tree = $p->get_tree; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$tree], ['tree']); my $raw = $tree->raw_text; #warn __PACKAGE__.':'.__LINE__.": $raw\n"; cmp_ok($raw, 'eq', $exp_raw, "raw text (close? $close_string) $in"); } } 06_unbalanced.t100644001750001750 241312361234004 15743 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 9; use Test::NoWarnings; use Parse::BBCode; use strict; use warnings; my %tag_def_html = ( code => { parse => 0, code => sub { my ($self, $attr, $content) = @_; "$$content" }, }, pre => { code => sub { "" }, }, a => '%{parse}s', b => '%{parse}s', c => '%{parse}s', ); my $bbc2html = Parse::BBCode->new({ tags => { %tag_def_html, }, } ); sub contains_untranslated { my $str = shift; return $str =~ m{\[/?\w+\]} ? 1 : 0; } my @tests = ( [ q#[c][a][/b]test#, q#[c][a][/b]test# ], [ q#[a][/b]#, q#[a][/b]# ], [ q#[a][b][/a][/b]#, q#[b][/b]# ], [ q#[code]foo#, q#[code]foo# ], [ q#[code#, q#[code# ], [ q#[code foo bar#, q#[code foo bar# ], [ q#[a][code][/a][/code]#, q#[a][/a]# ], [ q#[b][a][code][/a][/code]#, q#[b][a][/a]# ], ); for (@tests){ my ($in, $exp) = @$_; my $parsed = $bbc2html->render($in); #warn __PACKAGE__.':'.__LINE__.": $in => $parsed\n"; is($parsed, $exp, "unbalanced $in"); } Parse000755001750001750 012361234004 14372 5ustar00tinatina000000000000Parse-BBCode-0.15/libBBCode.pm100644001750001750 16325612361234004 16223 0ustar00tinatina000000000000Parse-BBCode-0.15/lib/Parsepackage Parse::BBCode; $Parse::BBCode::VERSION = '0.15'; use strict; use warnings; use Parse::BBCode::Tag; use Parse::BBCode::HTML qw/ &defaults &default_escapes &optional /; use base 'Class::Accessor::Fast'; __PACKAGE__->follow_best_practice; __PACKAGE__->mk_accessors(qw/ tags allowed compiled plain strict_attributes close_open_tags error tree escapes direct_attribute params url_finder text_processor linebreaks smileys attribute_parser strip_linebreaks attribute_quote /); #use Data::Dumper; use Carp; my $scalar_util = eval "require Scalar::Util; 1"; my %defaults = ( strict_attributes => 1, direct_attribute => 1, linebreaks => 1, smileys => 0, url_finder => 0, strip_linebreaks => 1, attribute_quote => '"', ); sub new { my ($class, $args) = @_; $args ||= {}; my %args = %$args; unless ($args{tags}) { $args{tags} = { $class->defaults }; } else { $args{tags} = { %{ $args{tags} } }; } unless ($args{escapes}) { $args{escapes} = {$class->default_escapes }; } else { $args{escapes} = { %{ $args{escapes} } } } my $self = $class->SUPER::new({ %defaults, %args }); $self->set_allowed([ grep { length } keys %{ $self->get_tags } ]); $self->_compile_tags; return $self; } my $re_split = qr{ % (?:\{ (?:[a-zA-Z\|]+) \})? (?:attr|[Aas]) }x; my $re_cmp = qr{ % (?:\{ ([a-zA-Z\|]+) \})? (attr|[Aas]) }x; sub forbid { my ($self, @tags) = @_; my $allowed = $self->get_allowed; my $re = join '|', map { quotemeta } @tags; @$allowed = grep { ! m/^(?:$re)\z/ } @$allowed; } sub permit { my ($self, @tags) = @_; my $allowed = $self->get_allowed; my %seen; @$allowed = grep { !$seen{$_}++ && $self->get_tags->{$_}; } (@$allowed, @tags); } sub _compile_tags { my ($self) = @_; # unless ($self->get_compiled) { { my $defs = $self->get_tags; # get definition for how text should be rendered which is not in tags my $plain; if (exists $defs->{""}) { $plain = delete $defs->{""}; if (ref $plain eq 'CODE') { $self->set_plain($plain); } } else { my $url_finder = $self->get_url_finder; my $linebreaks = $self->get_linebreaks; my $smileys = $self->get_smileys; if ($url_finder) { my $result = eval { require URI::Find; 1 }; unless ($result) { undef $url_finder; } } my $escape = \&Parse::BBCode::escape_html; my $post_processor_1 = $escape; my $post_processor; my $text_processor = $self->get_text_processor; if ($text_processor) { $post_processor_1 = $text_processor; } if ($smileys and ref($smileys->{icons}) eq 'HASH') { $smileys = { icons => $smileys->{icons}, base_url => $smileys->{base_url} || '/smileys/', format => $smileys->{format} || '%s', }; my $re = join '|', map { quotemeta $_ } sort { length $b <=> length $a } keys %{ $smileys->{icons} }; my $code = sub { my ($text, $post_processor) = @_; my $out = ''; while ($text =~ s/\A (^|.*?[\s]) ($re) (?=[\s]|$)//xsm) { my ($pre, $emo) = ($1, $2); my $url = "$smileys->{base_url}$smileys->{icons}->{$emo}"; my $emo_escaped = Parse::BBCode::escape_html($emo); my $image_tag = sprintf $smileys->{format}, $url, $emo_escaped; $out .= $post_processor_1->($pre) . $image_tag; } $out .= $post_processor_1->($text); return $out; }; $post_processor = $code; } else { $post_processor = $post_processor_1; } if ($url_finder) { my $url_find_sub; if (ref($url_finder) eq 'CODE') { $url_find_sub = $url_finder; } else { unless (ref($url_finder) eq 'HASH') { $url_finder = { max_length => 50, format => '%s', }; } my $max_url = $url_finder->{max_length} || 0; my $format = $url_finder->{format}; my $finder = URI::Find->new(sub { my ($url) = @_; my $title = $url; if ($max_url and length($title) > $max_url) { $title = substr($title, 0, $max_url) . "..."; } my $escaped = Parse::BBCode::escape_html($url); my $escaped_title = Parse::BBCode::escape_html($title); my $href = sprintf $format, $escaped, $title; return $href; }); $url_find_sub = sub { my ($ref_content, $post, $info) = @_; $finder->find($ref_content, sub { $post->($_[0], $info) }); }; } $plain = sub { my ($parser, $attr, $content, $info) = @_; unless ($info->{classes}->{url}) { $url_find_sub->(\$content, $post_processor, $info); } else { $content = $post_processor->($content); } $content =~ s/\r?\n|\r/
    \n/g if $linebreaks; $content; }; } else { $plain = sub { my ($parser, $attr, $content, $info) = @_; my $text = $post_processor->($content, $info); $text =~ s/\r?\n|\r/
    \n/g if $linebreaks; $text; }; } $self->set_plain($plain); } # now compile the rest of definitions for my $key (keys %$defs) { my $def = $defs->{$key}; #warn __PACKAGE__.':'.__LINE__.": $key: $def\n"; if (not ref $def) { my $new_def = $self->_compile_def($def); $defs->{$key} = $new_def; } elsif (not exists $def->{code} and exists $def->{output}) { my $new_def = $self->_compile_def($def); $defs->{$key} = $new_def; } $defs->{$key}->{class} ||= 'inline'; $defs->{$key}->{classic} = 1 unless defined $defs->{$key}->{classic}; $defs->{$key}->{close} = 1 unless defined $defs->{$key}->{close}; } $self->set_compiled(1); } } sub _compile_def { my ($self, $def) = @_; my $esc = $self->get_escapes; my $parse = 0; my $new_def = {}; my $output = $def; my $close = 1; my $class = 'inline'; if (ref $def eq 'HASH') { $new_def = { %$def }; $output = delete $new_def->{output}; $parse = $new_def->{parse}; $close = $new_def->{close} if exists $new_def->{close}; $class = $new_def->{class} if exists $new_def->{class}; } else { } # we have a string, compile #warn __PACKAGE__.':'.__LINE__.": $key => $output\n"; if ($output =~ s/^(inline|block|url)://) { $class = $1; } my @parts = split m!($re_split)!, $output; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@parts], ['parts']); my @compiled; for my $p (@parts) { if ($p =~ m/$re_cmp/) { my ($escape, $type) = ($1, $2); $escape ||= 'parse'; my @escapes = split /\|/, $escape; if (grep { $_ eq 'parse' } @escapes) { $parse = 1; } push @compiled, [\@escapes, $type]; } else { push @compiled, $p; } #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@compiled], ['compiled']); } my $code = sub { my ($self, $attr, $string, $fallback, $tag) = @_; my $out = ''; for my $c (@compiled) { # just text unless (ref $c) { $out .= $c; } # tag attribute or content else { my ($escapes, $type) = @$c; my @escapes = @$escapes; my $var = ''; my $attributes = $tag->get_attr; if ($type eq 'attr' and @$attributes > 1) { my $name = shift @escapes; for my $item (@$attributes[1 .. $#$attributes]) { if ($item->[0] eq $name) { $var = $item->[1]; last; } } } elsif ($type eq 'a') { $var = $attr; } elsif ($type eq 'A') { $var = $fallback; } elsif ($type eq 's') { if (ref $string eq 'SCALAR') { # this text is already finished and escaped $string = $$string; } $var = $string; } for my $e (@escapes) { my $sub = $esc->{$e}; if ($sub) { $var = $sub->($self, $c, $var); unless (defined $var) { # if escape returns undef, we return it unparsed return $tag->get_start . (join '', map { $self->_render_tree($_); } @{ $tag->get_content }) . $tag->get_end; } } } $out .= $var; } } return $out; }; $new_def->{parse} = $parse; $new_def->{code} = $code; $new_def->{close} = $close; $new_def->{class} = $class; return $new_def; } sub _render_text { my ($self, $tag, $text, $info) = @_; #warn __PACKAGE__.':'.__LINE__.": text '$text'\n"; defined (my $code = $self->get_plain) or return $text; return $code->($self, $tag, $text, $info); } sub parse { my ($self, $text, $params) = @_; my $parse_attributes = $self->get_attribute_parser ? $self->get_attribute_parser : $self->can('parse_attributes'); $self->set_error(undef); my $defs = $self->get_tags; my $tags = $self->get_allowed || [keys %$defs]; my @classic_tags = grep { $defs->{$_}->{classic} } @$tags; my @short_tags = grep { $defs->{$_}->{short} } @$tags; my $re_classic = join '|', map { quotemeta } sort {length $b <=> length $a } @classic_tags; #$re_classic = qr/$re_classic/i; my $re_short = join '|', map { quotemeta } sort {length $b <=> length $a } @short_tags; #$re_short = qr/$re_short/i; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$re], ['re']); my @tags; my $out = ''; my @opened; my $current_open_re = ''; my $callback_found_text = sub { my ($text) = @_; if (@opened) { my $o = $opened[-1]; $o->add_content($text); } else { if (@tags and !ref $tags[-1]) { # text tag, concatenate $tags[-1] .= $text; } else { push @tags, $text; } } #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']); }; my $callback_found_tag; my $in_url = 0; $callback_found_tag = sub { my ($tag) = @_; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$tag], ['tag']); #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']); if (@opened) { my $o = $opened[-1]; my $class = $o->get_class; #warn __PACKAGE__.':'.__LINE__.": tag $tag\n"; if (ref $tag and $class =~ m/inline|url/ and $tag->get_class eq 'block') { $self->_add_error('block_inline', $tag); pop @opened; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$o], ['o']); if ($self->get_close_open_tags) { # we close the tag for you $self->_finish_tag($o, '[/' . $o->get_name . ']', 1); $callback_found_tag->($o); $callback_found_tag->($tag); } else { # nope, no automatic closing, invalidate all # open inline tags before my @red = $o->_reduce; $callback_found_tag->($_) for @red; $callback_found_tag->($tag); } } elsif (ref $tag) { my $def = $defs->{lc $tag->get_name}; my $parse = $def->{parse}; if ($parse) { $o->add_content($tag); } else { my $content = $tag->get_content; my $string = ''; for my $c (@$content) { if (ref $c) { $string .= $c->raw_text( auto_close => 0 ); } else { $string .= $c; } } $tag->set_content([$string]); $o->add_content($tag); } } else { $o->add_content($tag); } } elsif (ref $tag) { my $def = $defs->{lc $tag->get_name}; my $parse = $def->{parse}; if ($parse) { push @tags, $tag; } else { my $content = $tag->get_content; my $string = ''; for my $c (@$content) { if (ref $c) { $string .= $c->raw_text( auto_close => 0 ); } else { $string .= $c; } } $tag->set_content([$string]); push @tags, $tag; } } else { push @tags, $tag; } $current_open_re = join '|', map { quotemeta $_->get_name } @opened; }; my @class = 'block'; while (defined $text and length $text) { $in_url = grep { $_->get_class eq 'url' } @opened; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$in_url], ['in_url']); #warn __PACKAGE__.':'.__LINE__.": ============= match $text\n"; my $tag; my ($before, $tag1, $tag2, $after); if ($re_classic and $re_short) { ($before, $tag1, $tag2, $after) = split m{ (?: \[ ($re_short) (?=://) | \[ ($re_classic) (?=\b|\]|\=) ) }ix, $text, 2; } elsif (! $re_classic and $re_short) { ($before, $tag1, $after) = split m{ \[ ($re_short) (?=://) }ix, $text, 2; } elsif ($re_classic and !$re_short) { ($before, $tag2, $after) = split m{ \[ ($re_classic) (?=\b|\]|\=) }ix, $text, 2; } { no warnings; # warn __PACKAGE__.':'.__LINE__.": $before, $tag1, $tag2, $after)\n"; #warn __PACKAGE__.':'.__LINE__.": RE: $current_open_re\n"; } #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']); if (length $before) { # look if it contains a closing tag #warn __PACKAGE__.':'.__LINE__.": BEFORE $before\n"; while (length $current_open_re and $before =~ s# (.*?) (\[ / ($current_open_re) \]) ##ixs) { # found closing tag my ($content, $end, $name) = ($1, $2, $3); #warn __PACKAGE__.':'.__LINE__.": found closing tag $name!\n"; my $f; # try to find the matching opening tag my @not_close; while (@opened) { my $try = pop @opened; $current_open_re = join '|', map { quotemeta $_->get_name } @opened; if ($try->get_name eq lc $name) { $f = $try; last; } elsif (!$try->get_close) { $self->_finish_tag($try, ''); unshift @not_close, $try; } else { # unbalanced $self->_add_error('unclosed', $try); if ($self->get_close_open_tags) { # close $f = $try; unshift @not_close, $try; if (@opened) { $opened[-1]->add_content(''); } $self->_finish_tag($try, '[/'. $try->get_name() .']', 1); } else { # just add unparsed text $callback_found_tag->($_) for $try->_reduce; } } } if (@not_close) { $not_close[-1]->add_content($content); } for my $n (@not_close) { $f->add_content($n); #$callback_found_tag->($n); } # add text before closing tag as content to the current open tag if ($f) { unless (@not_close) { #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$f], ['f']); $f->add_content( $content ); } # TODO $self->_finish_tag($f, $end); #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$f], ['f']); $callback_found_tag->($f); } } # warn __PACKAGE__." === before='$before' ($tag)\n"; $callback_found_text->($before); } if (defined $tag1) { $in_url = grep { $_->get_class eq 'url' } @opened; # short tag # $callback_found_text->($before) if length $before; if ($after =~ s{ :// ([^\[]+) \] }{}x) { my $content = $1; my ($attr, $title) = split /\|/, $content, 2; my $tag = $self->new_tag({ name => lc $tag1, attr => [[$attr]], attr_raw => $attr, content => [(defined $title and length $title) ? $title : ()], start => "[$tag1://$content]", close => 0, class => $defs->{lc $tag1}->{class}, single => $defs->{lc $tag1}->{single}, in_url => $in_url, type => 'short', }); if ($in_url and $tag->get_class eq 'url') { $callback_found_text->($tag->get_start); } else { $callback_found_tag->($tag); } } else { $callback_found_text->("[$tag1"); } $text = $after; next; } $tag = $tag2; $in_url = grep { $_->get_class eq 'url' } @opened; if ($after) { # found start of a tag #warn __PACKAGE__.':'.__LINE__.": find attribute for $tag\n"; my ($ok, $attributes, $attr_string, $end) = $self->$parse_attributes( text => \$after, tag => lc $tag, ); if ($ok) { my $attr = $attr_string; $attr = '' unless defined $attr; #warn __PACKAGE__.':'.__LINE__.": found attribute for $tag: $attr\n"; my $close = $defs->{lc $tag}->{close}; my $def = $defs->{lc $tag}; my $open = $self->new_tag({ name => lc $tag, attr => $attributes, attr_raw => $attr_string, content => [], start => "[$tag$attr]", close => $close, class => $defs->{lc $tag}->{class}, single => $defs->{lc $tag}->{single}, in_url => $in_url, type => 'classic', }); my $success = 1; my $nested_url = $in_url && $open->get_class eq 'url'; { my $last = $opened[-1]; if ($last and not $last->get_close and not $close) { $self->_finish_tag($last, ''); # tag which should not have closing tag pop @opened; $callback_found_tag->($last); } } if ($open->get_single && !$nested_url) { $self->_finish_tag($open, ''); $callback_found_tag->($open); } elsif (!$nested_url) { push @opened, $open; my $def = $defs->{lc $tag}; #warn __PACKAGE__.':'.__LINE__.": $tag $def\n"; my $parse = $def->{parse}; if ($parse) { $current_open_re = join '|', map { quotemeta $_->get_name } @opened; } else { #warn __PACKAGE__.':'.__LINE__.": noparse, find content\n"; # just search for closing tag if ($after =~ s# (.*?) (\[ / $tag \]) ##ixs) { my $content = $1; my $end = $2; #warn __PACKAGE__.':'.__LINE__.": CONTENT $content\n"; my $finished = pop @opened; $finished->set_content([$content]); $self->_finish_tag($finished, $end); $callback_found_tag->($finished); } else { #warn __PACKAGE__.':'.__LINE__.": nope '$after'\n"; } } } else { $callback_found_text->($open->get_start); } } else { # unclosed tag $callback_found_text->("[$tag$attr_string$end"); } } elsif ($tag) { #warn __PACKAGE__.':'.__LINE__.": end\n"; $callback_found_text->("[$tag"); } $text = $after; #sleep 1; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@tags], ['tags']); } # warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']); if ($self->get_close_open_tags) { while (my $opened = pop @opened) { $self->_add_error('unclosed', $opened); $self->_finish_tag($opened, '[/' . $opened->get_name . ']', 1); $callback_found_tag->($opened); } } else { while (my $opened = shift @opened) { my @text = $opened->_reduce; push @tags, @text; } } if ($scalar_util) { Scalar::Util::weaken($callback_found_tag); } else { # just to make sure no memleak if there's no Scalar::Util undef $callback_found_tag; } #warn __PACKAGE__.':'.__LINE__.": !!!!!!!!!!!! left text: '$text'\n"; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@tags], ['tags']); my $tree = $self->new_tag({ name => '', content => [@tags], start => '', class => 'block', attr => [[]], }); $tree->_init_info({}); return $tree; } sub new_tag { my $self = shift; Parse::BBCode::Tag->new(@_) } sub _add_error { my ($self, $error, $tag) = @_; my $errors = $self->get_error || {}; push @{ $errors->{$error} }, $tag; $self->set_error($errors); } sub error { my ($self, $type) = @_; my $errors = $self->get_error || {}; if ($type and $errors->{$type}) { return $errors->{$type}; } elsif (keys %$errors) { return $errors; } return 0; } sub render { my ($self, $text, $params) = @_; if (@_ < 2) { croak ("Missing input - Usage: \$parser->render(\$text)"); } #warn __PACKAGE__.':'.__LINE__.": @_\n"; #sleep 2; my $tree = $self->parse($text, $params); my $out = $self->render_tree($tree, $params); if ($self->get_error) { $self->set_tree($tree); } return $out; } sub render_tree { my ($self, $tree, $params) = @_; $params ||= {}; $self->set_params($params); my $rendered = $self->_render_tree($tree); $self->set_params(undef); return $rendered; } sub _render_tree { my ($self, $tree, $outer, $info) = @_; my $out = ''; $info ||= { stack => [], tags => {}, classes => {}, }; my $defs = $self->get_tags; if (ref $tree) { my $name = $tree->get_name; my %tags = %{ $info->{tags} }; $tags{$name}++; my @stack = @{ $info->{stack} }; push @stack, $name; my %classes = %{ $info->{classes} }; $classes{ $tree->get_class || '' }++; my %info = ( tags => \%tags, stack => [@stack], classes => \%classes, ); my $code = $defs->{$name}->{code}; my $parse = $defs->{$name}->{parse}; my $attr = $tree->get_attr || []; $attr = $attr->[0]->[0]; my $content = $tree->get_content; my $fallback; my $string = ''; if (($tree->get_type || 'classic') eq 'classic') { $fallback = (defined $attr and length $attr) ? $attr : $content; } else { $fallback = $attr; $string = @$content ? '' : $attr; } if (ref $fallback) { # we have recursive content, we don't want that in # an attribute $fallback = join '', grep { not ref $_ } @$fallback; } if ($self->get_strip_linebreaks and ($tree->get_class || '') eq 'block') { if (@$content == 1 and not ref $content->[0] and defined $content->[0]) { $content->[0] =~ s/^\r?\n//; $content->[0] =~ s/\r?\n\z//; } elsif (@$content > 1) { if (not ref $content->[0] and defined $content->[0]) { $content->[0] =~ s/^\r?\n//; } if (not ref $content->[-1] and defined $content->[-1]) { $content->[-1] =~ s/\r?\n\z//; } } } if (not exists $defs->{$name}->{parse} or $parse) { for my $c (@$content) { $string .= $self->_render_tree($c, $tree, \%info); } } else { $string = join '', @$content; } if ($code) { my $o = $code->($self, $attr, \$string, $fallback, $tree, \%info); $out .= $o; } else { $out .= $string; } } else { #warn __PACKAGE__.':'.__LINE__.": ==== $tree\n"; $out .= $self->_render_text($outer, $tree, $info); } return $out; } sub escape_html { my ($str) = @_; return '' unless defined $str; $str =~ s/&/&/g; $str =~ s/"/"/g; $str =~ s/'/'/g; $str =~ s/>/>/g; $str =~ s/get_attribute_quote; my $attr_string = ''; my $attributes = []; if ( ($self->get_direct_attribute and $$text =~ s/^(=[^\]]*)?]//) or ($$text =~ s/^( [^\]]*)?\]//) ) { my $attr = $1; my $end = ']'; $attr = '' unless defined $attr; $attr_string = $attr; unless (length $attr) { return (1, [], $attr_string, $end); } if ($self->get_direct_attribute) { $attr =~ s/^=//; } if ($self->get_strict_attributes and not length $attr) { return (0, [], $attr_string, $end); } my @array; if (length($attribute_quote) == 1) { if ($attr =~ s/^(?:$attribute_quote(.+?)$attribute_quote(?:\s+|$)|(.*?)(?:\s+|$))//) { my $val = defined $1 ? $1 : $2; push @array, [$val]; } while ($attr =~ s/^([a-zA-Z0-9_]+)=(?:$attribute_quote(.+?)$attribute_quote(?:\s+|$)|(.*?)(?:\s+|$))//) { my $name = $1; my $val = defined $2 ? $2 : $3; push @array, [$name, $val]; } } else { if ($attr =~ s/^(?:(["'])(.+?)\1|(.*?)(?:\s+|$))//) { my $val = defined $2 ? $2 : $3; push @array, [$val]; } while ($attr =~ s/^([a-zA-Z0-9_]+)=(?:(["'])(.+?)\2|(.*?)(?:\s+|$))//) { my $name = $1; my $val = defined $3 ? $3 : $4; push @array, [$name, $val]; } } if ($self->get_strict_attributes and length $attr and $attr =~ tr/ //c) { return (0, [], $attr_string, $end); } $attributes = [@array]; return (1, $attributes, $attr_string, $end); } return (0, $attributes, $attr_string, ''); } # TODO add callbacks sub _finish_tag { my ($self, $tag, $end, $auto_closed) = @_; #warn __PACKAGE__.':'.__LINE__.": _finish_tag(@_)\n"; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$tag], ['tag']); unless ($tag->get_finished) { $tag->set_end($end); $tag->set_finished(1); $tag->set_auto_closed($auto_closed || 0); } return 1; } __END__ =pod =head1 NAME Parse::BBCode - Module to parse BBCode and render it as HTML or text =head1 SYNOPSIS Parse::BBCode parses common bbcode like [b]bold[/b] [size=10]big[/size] short tags like [foo://test] and custom bbcode tags. For the documentation of short tags, see L<"SHORT TAGS">. To parse a bbcode string, set up a parser with the default HTML defintions of L: # render bbcode to HTML use Parse::BBCode; my $p = Parse::BBCode->new(); my $code = 'some [b]b code[/b]'; my $rendered = $p->render($code); # parse bbcode, manipulate tree and render use Parse::BBCode; my $p = Parse::BBCode->new(); my $code = 'some [b]b code[/b]'; my $tree = $p->parse($code); # do something with $tree my $rendered = $p->render_tree($tree); Or if you want to define your own tags: my $p = Parse::BBCode->new({ tags => { # load the default tags Parse::BBCode::HTML->defaults, # add/override tags url => 'url:%{parse}s', i => '%{parse}s', b => '%{parse}s', noparse => '
    %{html}s
    ', code => sub { my ($parser, $attr, $content, $attribute_fallback) = @_; if ($attr eq 'perl') { # use some syntax highlighter $content = highlight_perl($content); } else { $content = Parse::BBCode::escape_html($$content); } "$content" }, test => 'this is klingon: %{klingon}s', }, escapes => { klingon => sub { my ($parser, $tag, $text) = @_; return translate_into_klingon($text); }, }, } ); my $code = 'some [b]b code[/b]'; my $parsed = $p->render($code); =head1 DESCRIPTION If you set up the Parse::BBCode object without arguments, the default tags are loaded, and any text outside or inside of parseable tags will go through a default subroutine which escapes HTML and replaces newlines with
    tags. If you need to change this you can set the options 'url_finder', 'text_processor' and 'linebreaks'. =head2 METHODS =over 4 =item new Constructor. Takes a hash reference with options as an argument. my $parser = Parse::BBCode->new({ tags => { url => ..., i => ..., }, escapes => { link => ..., }, close_open_tags => 1, # default 0 strict_attributes => 0, # default 1 direct_attributes => 1, # default 1 url_finder => 1, # default 0 smileys => 0, # default 0 linebreaks => 1, # default 1 ); =over 4 =item tags See L<"TAG DEFINITIONS"> =item escapes See L<"ESCAPES"> =item url_finder See L<"URL FINDER"> =item smileys If you want to replace smileys with an icon: my $parser = Parse::BBCode->new({ smileys => { base_url => '/your/url/to/icons/', icons => { qw/ :-) smile.png :-( sad.png / }, # sprintf format: # first argument url # second argument original text smiley (HTML escaped) format => '%s', # if you need the url and text in a different order # see perldoc -f sprintf, e.g. # format => '%2$s', }, }); This subroutine will be applied during the url_finder (or first, if url_finder is 0), and the rest will get processed by the text procesor (default escaping html and replacing linebreaks). Smileys are only replaced if surrounded by whitespace or start/end of line/text. [b]bold
    :-)[/b] :-( In this example both smileys will be replaced. The first smiley is at the end of the text because the text inside [b][/b] is processed on its own. Open to any suggestions here. =item linebreaks The default text processor replaces linebreaks with
    \n. If you don't want this, set 'linebreaks' to 0. =item text_processor If you need to add any customized text processing (like smiley parsing, for example), you can pass a subroutine here. Note that this subroutine also needs to do HTML escaping itself! See L<"TEXT PROCESSORS"> =item close_open_tags Default: 0 If set to true (1), it will close open tags at the end or before block tags. =item strict_attributes Default: 1 If set to true (1), tags with invalid attributes are left unparsed. If set to false (0), the attribute for this tags will be empty. An invalid attribute: [foo=bar far boo]...[/foo] I might add an option to define your own attribute validation. Contact me if you'd like to have this. =item direct_attributes Default: 1 Normal tag syntax is: [tag=val1 attr2=val2 ...] If set to 0, tag syntax is [tag attr2=val2 ...] =item attribute_quote You can change how the attribute values shuold be quoted. Default is a double quote (which is still optional): my $parser = Parse::BBCode->new( attribute_quote => '"', ... ); [tag="foo" attr="bar" attr2=baz]...[/tag] If you set it to single quote: my $parser = Parse::BBCode->new( attribute_quote => "'", ... ); [tag='foo' attr=bar attr2='baz']...[/tag] You can also set it to both: C<'">. Then both quoting types are allowed: my $parser = Parse::BBCode->new( attribute_quote => q/'"/, ... ); [tag='foo' attr="bar" attr2=baz]...[/tag] =item attribute_parser You can pass a subref that overrides the default attribute parsing. See L<"ATTRIBUTE PARSING"> =item strip_linebreaks Default: 1 Strips linebreaks at start/end of block tags =back =item render Input: The text to parse, optional hashref Returns: the rendered text my $rendered = $parser->render($bbcode); You can pass an optional hashref with information you need inside of your self-defined rendering subs. For example if you want to display code in a codebox with a link to download the code you need the id of the article (in a forum) and the number of the code tag. my $parsed = $parser->render($bbcode, { article_id => 23 }); # in the rendering sub: my ($parser, $attr, $content, $attribute_fallback, $tag, $info) = @_; my $article_id = $parser->get_params->{article_id}; my $code_id = $tag->get_num; # write downloadlink like # download.pl?article_id=$article_id;code_id=$code_id # in front of the displayed code See examples/code_download.pl for a complete example of how to set up the rendering and how to extract the code from the tree. If run as a CGI skript it will give you a dialogue to save the code into a file, including a reasonable default filename. =item parse Input: The text to parse. Returns: the parsed tree (a L object) my $tree = $parser->parse($bbcode); =item render_tree Input: the parse tree Returns: The rendered text my $parsed = $parser->render_tree($tree); You can pass an optional hashref, for explanation see L<"render"> =item forbid $parser->forbid(qw/ img url /); Disables the given tags. =item permit $parser->permit(qw/ img url /); Enables the given tags if they are in the tag definitions. =item escape_html Utility to substitute <>&"' with their HTML entities. my $escaped = Parse::BBCode::escape_html($text); =item error If the given bbcode is invalid (unbalanced or wrongly nested classes), currently Parse::BBCode::render() will either leave the invalid tags unparsed, or, if you set the option C, try to add closing tags. If this happened C will return the invalid tag(s), otherwise false. To get the corrected bbcode (if you set C) you can get the tree and return the raw text from it: if ($parser->error) { my $tree = $parser->get_tree; my $corrected = $tree->raw_text; } =item parse_attributes You can inherit from Parse::BBCode and define your own attribute parsing. See L<"ATTRIBUTE PARSING">. =item new_tag Returns a L object. It just does: shift; Parse::BBCode::Tag->new(@_); If you want your own tag class, inherit from Parse::BBCode and let it return Parse::BBCode::YourTag->new =back =head2 TAG DEFINITIONS Here is an example of all the current definition possibilities: my $p = Parse::BBCode->new({ tags => { i => '%s', b => '%{parse}s', size => '%{parse}s', url => 'url:%{parse}s', wikipedia => 'url:%{parse}s', noparse => '
    %{html}s
    ', quote => 'block:
    %s
    ', code => { code => sub { my ($parser, $attr, $content, $attribute_fallback) = @_; if ($attr eq 'perl') { # use some syntax highlighter $content = highlight_perl($$content); } else { $content = Parse::BBCode::escape_html($$content); } "$content" }, parse => 0, class => 'block', }, hr => { class => 'block', output => '
    ', single => 1, }, }, } ); The following list explains the above tag definitions: =over 4 =item C<%s> i => '%s' [i] italic [/i] turns out as italic <html> So C<%s> stands for the tag content. By default, it is parsed itself, so that you can nest tags. =item C<%{parse}s> b => '%{parse}s' [b] bold [/b] turns out as bold <html> C<%{parse}s> is the same as C<%s> because 'parse' is the default. =item C<%a> size => '%{parse}s' [size=7] some big text [/size] turns out as some big text So %a stands for the tag attribute. By default it will be HTML escaped. =item url tag, C<%A>, C<%{link}A> url => 'url:%{parse}s' the first thing you can see is the C at the beginning - this defines the url tag as a tag with the class 'url', and urls must not be nested. So this class definition is mainly there to prevent generating wrong HTML. if you nest url tags only the outer one will be parsed. another thing you can see is how to apply a special escape. The attribute defined with C<%{link}a> is checked for a valid URL. C will be filtered. [url=/foo.html]a link[/url] turns out as a link Note that a tag like [url]http://some.link.example[/url] will turn out as http://some.link.example In the cases where the attribute should be the same as the content you should use C<%A> instead of C<%a> which takes the content as the attribute as a fallback. You probably need this in all url-like tags: url => 'url:%{parse}s', =item C<%{uri}A> You might want to define your own urls, e.g. for wikipedia references: wikipedia => 'url:%{parse}s', C<%{uri}A> will uri-encode the searched term: [wikipedia]Harold & Maude[/wikipedia] [wikipedia="Harold & Maude"]a movie[/wikipedia] turns out as Harold & Maude a movie =item Don't parse tag content Sometimes you need to display verbatim bbcode. The simplest form would be a noparse tag: noparse => '
    %{html}s
    ' [noparse] [some]unbalanced[/foo] [/noparse] With this definition the output would be 
     [some]unbalanced[/foo]
    So inside a noparse tag you can write (almost) any invalid bbcode. The only exception is the noparse tag itself: [noparse] [some]unbalanced[/foo] [/noparse] [b]really bold[/b] [/noparse] Output: [some]unbalanced[/foo] really bold [/noparse] Because the noparse tag ends at the first closing tag, even if you have an additional opening noparse tag inside. The C<%{html}s> defines that the content should be HTML escaped. If you don't want any escaping you can't say C<%s> because the default is 'parse'. In this case you have to write C<%{noescape}>. =item Block tags quote => 'block:
    %s
    ', To force valid html you can add classes to tags. The default class is 'inline'. To declare it as a block add C<'block:"> to the start of the string. Block tags inside of inline tags will either close the outer tag(s) or leave the outer tag(s) unparsed, depending on the option C. =item Define subroutine for tag All these definitions might not be enough if you want to define your own code, for example to add a syntax highlighter. Here's an example: code => { code => sub { my ($parser, $attr, $content, $attribute_fallback, $tag, $info) = @_; if ($attr eq 'perl') { # use some syntax highlighter $content = highlight_perl($$content); } else { $content = Parse::BBCode::escape_html($$content); } "$content" }, parse => 0, class => 'block', }, So instead of a string you define a hash reference with a 'code' key and a sub reference. The other key is C which is 0 by default. If it is 0 the content in the tag won't be parsed, just as in the noparse tag above. If it is set to 1 you will get the rendered content as an argument to the subroutine. The first argument to the subroutine is the Parse::BBCode object itself. The second argument is the attribute, the third is the already rendered tag content as a scalar reference and the fourth argument is the attribute fallback which is set to the content if the attribute is empty. The fourth argument is just for convenience. The fifth argument is the tag object (Parse::BBCode::Tag) itself, so if necessary you can get the original tag content by using: my $original = $tag->raw_text; The sixth argument is an info hash. It contains: my $info = { tags => $tags, stack => $stack, classes => $classes, }; The variable $tags is a hashref which contains all tag names which are outside the current tag, with a count. This is convenient if you have to check if the current processed tag is inside a certain tag and you want to behave differently, like if ($info->{tags}->{special}) { # we are somewhere inside [special]...[/special] } The variable $stack contains an array ref with all outer tag names. So while processing the tag 'i' in [quote][quote][b]bold [i]italic[/i][/b][/quote][/quote] it contains [qw/ quote quote b i /] The variable $classes contains a hashref with all tag classes and their counts outside of the current processed tag. For example if you want to process URIs with URI::Find, and you are already in a tag with the class 'url' then you don't want to use URI::Find here. unless ($info->{classes}->{url}) { # not inside of a url class tag ([url], [wikipedia, etc.) # parse text for urls with URI::Find } =item Single-Tags Sometimes you might want single tags like for a horizontal line: hr => { class => 'block', output => '
    ', single => 1, }, The hr-Tag is a block tag (should not be inside inline tags), and it has no closing tag (option C) [hr] Output:
    =back =head1 ESCAPES my $p = Parse::BBCode->new({ ... escapes => { link => sub { }, }, }); You can define or override escapes. Default escapes are html, uri, link, email, htmlcolor, num. An escape functions as a validator and filter. For example, the 'link' escape looks if it got a valid URI (starting with C or C<\w+://>) and html-escapes it. It returns the empty string if the input is invalid. See L for the detailed list of escapes. =head1 URL FINDER Usually one wants to also create hyperlinks from any url found in the bbcode, not only in url tags. The following code will use L to search for all types of urls (unless inside of a url tag itself), create a link in the given format and html-escape the rest. If the url is longer than 50 chars, it will cut the link title and append three dots. If you set max_length to 0, the title won't be cut. my $p = Parse::BBCode->new({ url_finder => { max_length => 50, # sprintf format: format => '%s', }, tags => ... }); Note: If you use the special tag '' in the tag definitions you will overwrite the url finder and have to do that yourself. Alternative: my $p = Parse::BBCode->new({ url_finder => 1, ... This will use the default like shown above (max length 50 chars). Default is 0. =head1 ATTRIBUTES There are two types of tags. The default (option direct_attributes=1): [foo=bar a=b c=d] [foo="text with space" a=b c=d] The parsed attribute structure will look like: [ ['bar'], ['a' => 'b'], ['c' => 'd'] ] Another bbcode variant doesn't use direct attributes: [foo a=b c=d] The resulting attribute structure will have an empty first element: [ [''], ['a' => 'b'], ['c' => 'd'] ] =head1 ATTRIBUTE PARSING If you have bbcode attributes that don't fit into the two standard syntaxes you can inherit from Parse::BBCode and overwrite the parse_attributes method, or you can pass an option attribute_parser contaning a subref. Example: [size=10]big[/size] [foo|bar|boo]footext[/foo] end The size tag should be parsed normally, the foo tag needs different parsing. sub parse_attributes { my ($self, %args) = @_; # $$text contains '|bar|boo]footext[/foo] end my $text = $args{text}; my $tagname = $args{tag}; # 'foo' if ($tagname eq 'foo') { # work on $$text # result should be something like: # $$text should contain 'footext[/foo] end' my $valid = 1; my @attr = ( [''], [1 => 'bar'], [2 => 'boo'] ); my $attr_string = '|bar|boo'; return ($valid, [@attr], $attr_string, ']'); } else { return shift->SUPER::parse_attributes(@_); } } my $parser = Parse::BBCode->new({ ... attribute_parser => \&parse_attributes, }); If the attributes are not valid, return 0, [ [''] ], '|bar|boo', ']' If you don't find a closing square bracket, return: 0, [ [''] ], '|bar|boo', '' =head1 TEXT PROCESSORS If you set url_finder and linebreaks to 1, the default text processor will work like this: my $post_processor = \&sub_for_escaping_HTML; $text = code_to_replace_urls($text, $post_processor); $text =~ s/\r?\n|\r/
    \n/g; return $text; It will be applied to text outside of bbcode and inside of parseable bbcode tags (and not to code tags or other tags with unparsed content). If you need an additional post processor this usually cannot be done after the HTML escaping and url finding. So if you write a text processor it must do the HTML escaping itself. For example if you want to replace smileys with image tags you cannot simply do: $text =~ s/ :-\) //g; because then the image tag would be HTML escaped after that. On the other hand it's usually not possible to do something like that *after* the HTML escaping since that might introduce text sequences that look like a smiley (or whatever you want to replace). So a simple example for a customized text processor would be: ... url_finder => 1, linebreaks => 1, text_processor => sub { # for $info hash description see render() method my ($text, $info) = @_; my $out = ''; while ($text =~ s/(.*)( |^)(:\))(?= |$)//mgs) { # match a smiley and anything before my ($pre, $sp, $smiley) = ($1, $2, $3); # escape text and add smiley image tag $out .= Parse::BBCode::escape_html($pre) . $sp . ''; } # leftover text $out .= Parse::BBCode::escape_html($text); return $out; }, This will result in: Replacing urls, applying your text_processor to the rest of the text and after that replace linebreaks with
    tags. If you want to completely define the plain text processor yourself (ignoring the 'linebreak', 'url_finder', 'smileys' and 'text_processor' options) you define the special tag with the empty string: my $p = Parse::BBCode->new({ tags => { '' => sub { my ($parser, $attr, $content, $info) = @_; return frobnicate($content); # remember to escape HTML! }, ... =head1 SHORT TAGS It can be very convenient to have short tags like [foo://id]. This is not really a part of BBCode, but I consider it as quite similar, so I added it to this module. For example to link to threads, cpan modules or wikipedia articles: [thread://123] [thread://123|custom title] # can be implemented so that it links to thread 123 in the forum # and additionally fetch the thread title. [cpan://Module::Foo|some useful module] [wikipedia://Harold & Maude] You can define a short tag by adding the option C. The tag will work as a classic tag and short tag. If you only want to support the short version, set the option C to 0. my $p = Parse::BBCode->new({ tags => { Parse::BBCode::HTML->defaults, wikipedia => { short => 1, output => '%{parse}s', class => 'url', classic => 0, # don't support classic [wikipedia]...[/wikipedia] }, thread => { code => sub { my ($parser, $attr, $content, $attribute_fallback) = @_; my $id = $attribute_fallback; if ($id =~ tr/0-9//c) { return '[thread]' . encode_entities($id) . '[/thread]'; } my $name; if ($attr) { # custom title will be in $attr # [thread=123]custom title[/thread] # [thread://123|custom title] # already escaped $name = $$content; } return qq{$name}; }, short => 1, classic => 1, # default is 1 }, }, } ); =head1 WHY ANOTHER BBCODE PARSER I wrote this module because L is not extendable (or I didn't see how) and L seemed good at the first glance but has some issues, for example it says that the following bbode [code] foo [b] [/code] is invalid, while I think you should be able to write unbalanced code in code tags. Also BBCode::Parser dies if you have invalid code or not-permitted tags, but in a forum you'd rather show a partly parsed text then an error message. What I also wanted is an easy syntax to define own tags, ideally - for simple tags - as plain text, so you can put it in a configuration file. This allows forum admins to add tags easily. Some forums might want a tag for linking to perlmonks.org, other forums need other tags. Another goal was to always output a result and don't die. I might add an option which lets the parser die with unbalanced code. =head1 WHY BBCODE? Some forums and blogs prefer a kind of pseudo HTML for user comments. The arguments against bbcode is usually: "Why should people learn an additional markup language if they can just use HTML?" The problem is that many people don't know HTML. BBCode is often a bit shorter, for example if you have a code tag with an attribute that tells the parser what language the content is in. [code=perl]...[/code] ... Also, forum HTML is usually not real HTML. It is usually a subset and sometimes with additional tags. So in the backend you need to parse it anyway to turn it into real HTML. BBCode is widely known and used. Unfortunately though, there is no specification; some forums only allow attributes in double quotes, some forums implement only one attribute that can be seperated by spaces, which makes it difficult to parse if you want to support more than one attribute. I tried to support the most common syntax (attributes without quotes, in single or double quotes) and tags. If you need additional tags it's relatively easy to implement them. For example in my forum I implemented a [more] tag that hides long text or code in thread view. Without Javascript you will see the expanded content when clicking on the single article, or with Javascript the content will be added inline via Ajax. =head1 TODO =over 4 =item BBCode to Textile|Markdown There is a L module which is only roughly tested. =item API The main syntax is likely to stay, only the API for callbacks might change. At the moment it is not possible to add callbacks to the parsing process, only for the rendering phase. =back =head1 REQUIREMENTS perl >= 5.8.0, L, L =head1 SEE ALSO L - a parser which supplies the parsed tree if necessary. Too strict though for using in forums where people write unbalanced bbcode L - simple processor, no parse tree, good enough for processing usual bbcode with the most common tags L - really simple proccessor, just replaces start and end tags independently by their HTML aequivalents, so not very useful in many cases See C for a feature comparison of the modules and feel free to report mistakes. See C for a benchmark of the modules. =head1 BUGS Please report bugs at http://rt.cpan.org/NoAuth/Bugs.html?Dist=Parse-BBCode or https://github.com/perlpunk/Parse-BBCode/issues =head1 AUTHOR Tina Mueller =head1 CREDITS Thanks to Moritz Lenz for his suggestions about the implementation and the test cases. Viacheslav Tikhanovskii Sascha Kiefer =head1 COPYRIGHT AND LICENSE Copyright (C) 2014 by Tina Mueller This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.6.1 or, at your option, any later version of Perl 5 you may have available. =cut compare.pl100644001750001750 657112361234004 16524 0ustar00tinatina000000000000Parse-BBCode-0.15/examples#!/usr/bin/perl use strict; use warnings; use Carp qw(carp croak); use Data::Dumper; use BBCode::Parser; use Parse::BBCode; use HTML::BBCode; use HTML::BBReverse; use AUBBC; my %subs = ( 'BBCode::Parser' => \&parse_bb_parser, 'Parse::BBCode' => \&parse_p_bb, 'HTML::BBCode' => \&parse_html_bb, 'HTML::BBReverse' => \&parse_bbr, 'AUBBC' => \&parse_aubbc, ); my $unbalanced = <<'EOM'; [i]italic [b]bold[/b] EOM my $unbalanced2 = <<'EOM'; [i]italic [b]bold[/i] EOM my $unbalanced3 = <<'EOM'; [i]italic [code]bold[/i] EOM my $unknown = <<'EOM'; [some]unknown[/unknown] tag EOM my $forbidden = <<'EOM'; [img]forbidden[/img] EOM my $block = <<'EOM'; [i] italic [code]code block[/code] [/i] EOM my $list = <<'EOM'; [list] [*]first [*] second [/list] EOM my $image = <<'EOM'; [img]image.png[/img] [img="image.png"]text[/img] EOM my $url = <<'EOM'; [b]test[/b] http://perl.org/ EOM #[img=image.png][/img] #[img=image.png]text with [b]bold[/b][/img] #[img=image.png]text with "" quotes[/img] my %codes = ( unbalanced => $unbalanced, unbalanced2 => $unbalanced2, unbalanced3 => $unbalanced3, unknown => $unknown, forbidden => $forbidden, block => $block, list => $list, image => $image, url => $url, ); for my $key (sort keys %subs) { my $v = $key->VERSION; print "\n$key\t$v\n"; my $sub = $subs{$key}; for my $name (sort keys %codes) { my $code = $codes{$name}; my $out; print "======= $key $name:\n"; my $forbid = $name eq 'forbidden' ? 1 : 0; eval { $out = $sub->($code, $forbid); }; if ($@) { print "$key $name dies: $@\n"; print <<"EOM"; $code======= EOM } else { print "$key $name does not die\n"; print <<"EOM"; $code======= $out ======= EOM } } } sub parse_bb_parser { my ($code, $forbid) = @_; my $p = BBCode::Parser->new(follow_links => 1); if ($forbid) { $p->forbid('IMG'); } my $tree = $p->parse($code); my $out = $tree->toHTML(); } sub parse_aubbc { my ($code, $forbid) = @_; my $p; if ($forbid) { $p = AUBBC->new( no_img => 1 ); } else { $p = AUBBC->new(); } my $out = $p->do_all_ubbc($code); } sub parse_p_bb { my ($code, $forbid) = @_; my $p = Parse::BBCode->new({ tags => { b => '%s', i => '%s', url => '%s', code =>'block:
    Code:
    %{noparse}s
    ', 'img' => '%{html}s', }, }); if ($forbid) { $p->forbid(qw/ img /); } my $out = $p->render($code); } sub parse_html_bb { my ($code, $forbid) = @_; my $p; if ($forbid) { $p = HTML::BBCode->new({ allowed_tags => [ qw/ b i code url list / ], }); } else { $p = HTML::BBCode->new(); } my $out = $p->parse($code); } sub parse_bbr { my ($code, $forbid) = @_; my $p; if ($forbid) { $p = HTML::BBReverse->new( allowed_tags => [ qw/ b i code url list / ], ); } else { $p = HTML::BBReverse->new( ); } my $out = $p->parse($code); } example.pl100644001750001750 243212361234004 16521 0ustar00tinatina000000000000Parse-BBCode-0.15/examples#!/usr/bin/perl use strict; use warnings; use Data::Dumper; use Parse::BBCode; my %tag_def_html = ( code => { code => sub { my $c = $_[2]; $c = Parse::BBCode::escape_html($$c); "$c" }, }, perlmonks => 'url:%{parse}s', url => 'url:%{parse}s', i => '%{parse}s', b => '%{parse}s', ); my $bbc2html = Parse::BBCode->new({ tags => { %tag_def_html, }, } ); my $text = <<'EOM'; [i]italic [b]bold italic [/b][/i] [perlmonks=123]foo [i]italic[/i][/perlmonks] [url=javascript:alert(123)]foo [i]italic[/i][/url] [code]foo[b][/code] [code]foo[code]bar[/code][/code] [i]italic [b]bold italic [/i][/b] [b]bold? EOM my $parsed = $bbc2html->render($text); print "$parsed\n"; __DATA__ italic bold italic <html>
    foo <html>italic
    foo <html>italic
    foo[b]
    foo[code]bar<html>[/code]
    italic [b]bold italic <html>[/b]
    [b]bold?
    08_various_tags.t100644001750001750 2073112361234004 16402 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 39; use Parse::BBCode; use strict; use warnings; my %args = ( tags => { '' => sub { Parse::BBCode::escape_html($_[2]) }, i => '%s', b => '%{parse}s', size => { output => '%{parse}s', }, url => '%{parse}s', wikipedia => '%{parse}s', noparse => '
    %{html}s
    ', c => { code => sub { my ($parser, $attr, $content) = @_; $content = Parse::BBCode::escape_html($$content); $content =~ s/ / /g; return qq{$content}; }, }, code => { code => sub { my ($parser, $attr, $content, $attribute_fallback) = @_; if ($attr eq 'perl') { # use some syntax highlighter $content = "/usr/bin/perl -e '$$content'"; } else { $content = Parse::BBCode::escape_html($$content); } "$content" }, parse => 0, }, raw => { parse => 1, code => sub { my ($parser, $attr, $content, $attribute_fallback, $tag) = @_; my $text = $tag->raw_text . '|' . $tag->raw_content . '|' . $$content; }, }, html2 => { parse => 1, code => sub { my ($parser, $attr, $content, $attribute_fallback, $tag) = @_; $attr = $tag->get_attr; my $text = "[0]="$at->[1]"}; } $text .= ">$$content"; return $text; }, }, Parse::BBCode::HTML->optional('html'), Parse::BBCode::HTML->defaults(qw/ list * /), 'img' => '%{html}s', hr => { class => 'block', output => '
    ', single => 1, }, quote => 'block:
    %s
    ', frob => '%{frobnicate}s', }, escapes => { Parse::BBCode::HTML->default_escapes(qw/ link uri html /), frobnicate => sub { my ($p, $tag, $var) = @_; return uc reverse $var; }, }, ); my $p = Parse::BBCode->new({ %args, }); my $lf = Parse::BBCode->new({ %args, strip_linebreaks => 0, }); my @tests = ( [ q#[size=7]big [b]bold[/b] text[/size]#, q#big bold text# ], [ q#[url=http://foo/]interesting [b]bold[/b] link[/url]#, q#interesting bold link# ], [ q#[url="http://foo/"]interesting [b]bold[/b] link[/url]#, q#interesting bold link# ], [ q#[url=/foo]interesting [b]bold[/b] link[/url]#, q#interesting bold link# ], [ q#[wikipedia]Harold & Maude[/wikipedia]#, q#Harold & Maude# ], [ q#[wikipedia="Harold & Maude"]a movie[/wikipedia]#, q#a movie# ], [ q#[noparse]bbcode [b]which[/i] should not be [/code]parsed[/noparse]#, q#
    bbcode [b]which[/i] should not be [/code]parsed
    # ], [ q#[code=perl]say "foo";[/code]#, q#/usr/bin/perl -e 'say "foo";'# ], [ q#[code=perl]say "foo";[/code]#, q#/usr/bin/perl -e 'say "foo";'# ], [ q#[raw]some [b]bold[/b] text[/raw]#, q#[raw]some [b]bold[/b] text[/raw]|some [b]bold[/b] text|some bold text# ], [ q#[html]bold text[/html]#, q#bold text# ], [ q#[html2=style color=red size="7"]big [b]bold[/b] text[/html2]#, q#big bold text# ], [ qq#before\n[list]\n[*]first\n[*]second\n[*]third\n[/list]\nafter#, qq#before\n
    • first
    • second
    • third
    \nafter# ], [ q#[list][*]first with [url]/foo[/url][*]second[*]third[/list]#, q#
    • first with /foo
    • second
    • third
    # ], [ q#[list][*]first[*]second with [url]/foo[/url][*]third[/list]#, q#
    • first
    • second with /foo
    • third
    # ], [ q#[list][*]first[*]second with [url]/foo[*]third[/list]#, q#
    • first
    • second with [url]/foo
    • third
    # ], [ q#[list=1][*]first[*]second with [url]foo and [b]bold[/b][*]third[/list]#, q#
    1. first
    2. second with [url]foo and bold
    3. third
    # ], [ q#[list][*]a[list][*]c1[/list][/list]#, q#
    • a
      • c1
    # ], [ q#[list=1][*]a[list][*]c1[/list][/list]#, q#
    1. a
      • c1
    # ], [ q#[list=a][*]a[list][*]c1[/list][/list]#, q#
    1. a
      • c1
    # ], [ q#[quote][*]a[*]b [/quote] test#, q#
    [*]a[*]b
    test# ], [ q#test [*]a[*]b end#, q#test [*]a[*]b end# ], [ q#[img]/path/to/image.png[/img]#, q#/path/to/image.png# ], [ q#[img=/path/to/image.png]description[/img]#, q#description# ], [ q#[img=/path/to/image.png]description [b]with bold[/b][/img]#, q#description [b]with bold[/b]# ], [ q#text [quote]with bold and [hr]line[/quote]#, q#text
    with bold and
    line
    # ], [ qq#text [quote="foo"][quote="bar"]inner quote[/quote]outer quote[/quote]#, q#text
    inner quote
    outer quote
    # ], [ q#[quote="admin@2008-06-27 19:00:25"][quote="foo@2007-08-13 22:12:32"]test[/quote]test[/quote]#, q#
    test
    test
    # ], [ q#text [b]with bold and [hr]line[/b]#, q#text [b]with bold and
    line[/b]# ], [ q#text with bold and [hr]line#, q#text with bold and
    line# ], [ q#[img]javascript:boo()[/img]#, q#[img]javascript:boo()[/img]# ], [ qq#[img]javascr\tipt:boo()[/img]#, qq#[img]javascr\tipt:boo()[/img]# ], [ q#[frob]blubber bla[/frob]#, q#ALB REBBULB# ], [ q#start [c] code [/c] end#, q#start  code  end# ], [ qq#start\n[quote]\ncode\n[/quote]\nend#, qq#start\n
    code
    \nend# ], [ qq#start\n[quote]\ncode\n[/quote]\nend#, qq#start\n
    \ncode\n
    \nend#, $lf ], ); for (@tests) { my ($in, $exp, $parser) = @$_; $parser ||= $p; my $parsed = $parser->render($in); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; $in =~ s/\n/\\n/g; cmp_ok($parsed, 'eq', $exp, "$in"); } { my $p = Parse::BBCode->new({ tags => { '' => 'plain', i => '%s', }, } ); my $parsed = $p->render(q#foo [i]latin[/i]#); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; my $exp = 'foo latin'; is($parsed, $exp, "empty plain text definition"); } { my $p = Parse::BBCode->new({ tags => { i => '%s', }, } ); my $parsed = $p->render(q#foo [i]latin[/i]#); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; my $exp = 'foo latin'; is($parsed, $exp, "no plain text definition"); } { my $p = Parse::BBCode->new({ tags => { '' => sub { Parse::BBCode::escape_html(undef) }, i => '%s', }, } ); my $parsed = $p->render(q#foo [i]latin[/i]#); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; my $exp = ''; is($parsed, $exp, "undef plain text definition"); } compare.html100644001750001750 432212361234004 17045 0ustar00tinatina000000000000Parse-BBCode-0.15/examples Comparing BBCode-Modules
    Module/Version HTML::BBCode 2.06 BBCode::Parser 0.34 Parse::BBCode 0.12 HTML::BBReverse 0.07 AUBBC 4.06
    Unbalanced / incorrectly nested tags Leaves tags unparsed Closes open tags or dies
    depending on tags     		Leaves tags unparsed
    or closes tags if wanted     		Creates invalid HTML Leaves tags unparsed /
    Creates invalid HTML
    Add own tags No Yes Yes No Some (2)
    Unknown Tags leaves unparsed leaves unparsed leaves unparsed leaves unparsed leaves unparsed
    Forbidden Tags leaves unparsed Dies leaves unparsed leaves unparsed leaves unparsed
    Provides parsed tree No Yes Yes No No
    Block in Inline Creates broken output (1) Dies leaves unparsed Creates invalid HTML
    depending on block tags    		 Creates invalid HTML
    • (1) The output from '[i] italic [code]code block[/code] [/i]':
      <span style="font-style:italic"> italic  </span><div class="bbcode_code_header">Code:</div><div class="bbcode_code_body">code&nbsp;block</div>  &lt;/span&gt;
    • (2) Not possible to build tags with unparsed content; must use the builtin [code] tag
    BBCode000755001750001750 012361234004 15450 5ustar00tinatina000000000000Parse-BBCode-0.15/lib/ParseTag.pm100644001750001750 1127212361234004 16704 0ustar00tinatina000000000000Parse-BBCode-0.15/lib/Parse/BBCodepackage Parse::BBCode::Tag; $Parse::BBCode::Tag::VERSION = '0.15'; use strict; use warnings; use Carp qw(croak carp); use base 'Class::Accessor::Fast'; __PACKAGE__->follow_best_practice; __PACKAGE__->mk_accessors(qw/ name attr attr_raw content finished start end close class single type in_url num level auto_closed /); sub add_content { my ($self, $new) = @_; my $content = $self->get_content; if (ref $new) { push @$content, $new; return; } if (@$content and not ref $content->[-1]) { $content->[-1] .= $new; } else { push @$content, $new; } } sub raw_text { my ($self, %args) = @_; %args = ( auto_close => 1, %args, ); my $auto_close = $args{auto_close}; my ($start, $end) = ($self->get_start, $self->get_end); if (not $auto_close and $self->get_auto_closed) { $end = ''; } my $text = $start; $text .= $self->raw_content(%args); no warnings; $text .= $end; return $text; } sub _init_info { my ($self, $num, $level) = @_; $level ||= 0; my $name = $self->get_name; $num->{$name}++; $self->set_num($num->{$name}); $self->set_level($level); my $content = $self->get_content || []; for my $c (@$content) { next unless ref $c; $c->_init_info($num, $level + 1); } } sub walk { my ($self, $type, $sub) = @_; $type ||= 'bfs'; unless ($type eq 'bfs') { croak "walk(): $type '$type' not implemented"; } my $result = $sub->($self); return if $result; my $content = $self->get_content || []; for my $c (@$content) { next unless ref $c; $c->walk($type, $sub); } } sub raw_content { my ($self, %args) = @_; my $content = $self->get_content; my $text = ''; #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$self], ['self']); for my $c (@$content) { if (ref $c eq ref $self) { $text .= $c->raw_text(%args); } else { $text .= $c; } } return $text; } sub _reduce { my ($self) = @_; if ($self->get_finished) { return $self; } my @text = $self->get_start; my $content = $self->get_content; for my $c (@$content) { if (ref $c eq ref $self) { push @text, $c->_reduce; } else { push @text, $c; } } push @text, $self->get_end if defined $self->get_end; return @text; } 1; __END__ =pod =head1 NAME Parse::BBCode::Tag - Tag Class for Parse::BBCode =head1 DESCRIPTION If you parse a bbcode with L C returns a parse tree of Tag objects. =head1 METHODS =over 4 =item add_content $tag->add_content('string'); Adds 'string' to the end of the tag content. $tag->add_content($another_tag); Adds C<$another_tag> to the end of the tag content. =item raw_text my $bbcode = $tag->raw_text; Returns the raw text of the parse tree, so all tags are converted back to bbcode. =item raw_content my $bbcode = $tag->raw_content; Returns the raw content of the tag without the opening and closing tags. So if you have tag that was parsed from [i]italic and [bold]test[/b][/i] it will return italic and [bold]test[/b] =item walk Utility to do a breadth first search ('bfs') over the parsed tree. $tag->walk('bfs', sub { # tag is in $_ ... return 0; }); When the sub returns 1 it stops walking the tree. Useful for finding a certain tag. =back =head1 ACCESSORS The accessors of a tag are currently name attr attr_raw content finished start end close class You can call each accessor with C and C =over 4 =item name The tag name. for C<[i]...[/i]> it is C, the lowercase tag name. =item attr TODO =item attr_raw The raw text of the attribute =item content An arrayref of the content of the tag, each element either a string or a tag itself. =item finished Used during parsing, true if the end of the tag was found. =item start The original start string, e.g. 'C<[size=7]>' =item end The original end string, e.g. 'C<[/size]>' =item close True if the tag needs a closing tag. A tag which doesn't need a closing tag is C<[*]> for example, inside of C<[list]> tags. =item class 'block', 'inline' or 'url' =item single If this tag does not have a closing tag and also no content, like [hr], for example, set this to true. Default is 0. =item num Absolute number of tag with this name in the tree. Useful if you want to number code tags and offer download links. =item level Level of tag For the tag [u] in the following bbcode [b]bold [i]italic [u]underlined[/u][/i][/b] it returns 3. =back =cut 12_direct_attribute.t100644001750001750 174312361234004 17206 0ustar00tinatina000000000000Parse-BBCode-0.15/tuse Test::More tests => 2; use_ok('Parse::BBCode'); use strict; use warnings; my $p = Parse::BBCode->new({ direct_attribute => 0, tags => { 'a' => { parse => 1, code => sub { my ($parser, $attr, $content, $attribute_fallback, $token) = @_; my $at = $token->get_attr; my $href = ""; for my $item (@$at) { if ($item->[0] eq 'href') { $href = $item->[1]; last; } } return qq{$$content}; }, }, }, }); my @tests = ( [ q#[a href="foo"]link[/a]#, q#link# ], ); for (@tests) { my ($in, $exp) = @$_; my $parsed = $p->render($in); #warn __PACKAGE__.':'.__LINE__.": $parsed\n"; cmp_ok($parsed, 'eq', $exp, "$in"); } Text.pm100644001750001750 445612361234004 17103 0ustar00tinatina000000000000Parse-BBCode-0.15/lib/Parse/BBCodepackage Parse::BBCode::Text; $Parse::BBCode::Text::VERSION = '0.15'; use strict; use warnings; use Carp qw(croak carp); use base qw/ Parse::BBCode /; my %default_tags = ( 'b' => '%s', 'i' => '%s', 'u' => '%s', 'img' => '%s', 'url' => '%s', 'email' => 'mailto:%{email}A', 'size' => '%s', 'color' => '%s', 'list' => 'block:%{parse}s', '*' => { parse => 1, output => '* %s', close => 0, class => 'block', code => sub { my ($parser, $attr, $content, $attribute_fallback) = @_; $$content =~ s/\n+\Z//; $$content =~ s/^\s+//; return "* $$content\n"; }, }, quote => { parse => 1, class => 'block', code => sub { my ($parser, $attr, $content, $attribute_fallback) = @_; $$content =~ s/^/> /gm; $$content =~ s/^> >/>>/gm; "$attribute_fallback:\n$$content\n"; }, }, '' => sub { my $text = $_[2]; $text; }, ); my %optional_tags = ( # Parse::BBCode::HTML->optional(), ); my %default_escapes = ( Parse::BBCode::HTML->default_escapes ); sub defaults { my ($class, @keys) = @_; return @keys ? (map { $_ => $default_tags{$_} } grep { defined $default_tags{$_} } @keys) : %default_tags; } sub default_escapes { my ($class, @keys) = @_; return @keys ? (map { $_ => $default_escapes{$_} } grep { defined $default_escapes{$_} } @keys) : %default_escapes; } sub optional { my ($class, @keys) = @_; return @keys ? (grep defined, @optional_tags{@keys}) : %optional_tags; } 1; =pod =head1 NAME Parse::BBCode::Text - Provides plaintext defaults for Parse::BBCode =head1 SYNOPSIS use Parse::BBCode::Text; my $p = Parse::BBCode::Markdown->new(); my $code = 'some [b]b code[/b]'; my $plaintext = $p->render($code); =head1 DESCRIPTION This module can be used to turn bbcode into minimal plaintext. =head1 METHODS =over 4 =item defaults Returns a hash with default tags. b, i, u, img, url, email, size, color, list, * =item default_escapes Returns a hash with escaping functions. html, uri, link, email, htmlcolor, num =item optional Returns a hash of optional tags. html =back =cut HTML.pm100644001750001750 1264412361234004 16741 0ustar00tinatina000000000000Parse-BBCode-0.15/lib/Parse/BBCodepackage Parse::BBCode::HTML; $Parse::BBCode::HTML::VERSION = '0.15'; use strict; use warnings; use Carp qw(croak carp); use URI::Escape; use base 'Exporter'; our @EXPORT_OK = qw/ &defaults &default_escapes &optional /; my $email_valid = 0; eval { require Email::Valid; }; $email_valid = 1 unless $@; my %colors = ( aqua => 1, black => 1, blue => 1, fuchsia => 1, gray => 1, grey => 1, green => 1, lime => 1, maroon => 1, navy => 1, olive => 1, purple => 1, red => 1, silver => 1, teal => 1, white => 1, yellow => 1, ); my %default_tags = ( 'b' => '%s', 'i' => '%s', 'u' => '%s', 'img' => '[%{html}s]', 'url' => 'url:%s', 'email' => 'url:%s', 'size' => '%s', 'color' => '%s', 'list' => { parse => 1, class => 'block', code => sub { my ($parser, $attr, $content, $attribute_fallback, $tag) = @_; $$content =~ s/^\n+//; $$content =~ s/\n+\z//; my $type = "ul"; my $style = ''; if ($attr) { if ($attr eq '1') { $type = "ol"; } elsif ($attr eq 'a') { $type = "ol"; $style = ' style="list-style-type: lower-alpha"'; } } return "<$type$style>$$content"; }, }, '*' => { parse => 1, code => sub { my ($parser, $attr, $content, $attribute_fallback, $tag, $info) = @_; $$content =~ s/\n+\z//; if ($info->{stack}->[-2] eq 'list') { return "
  • $$content
    • ", } return Parse::BBCode::escape_html($tag->raw_text); }, close => 0, class => 'block', }, 'quote' => { code => sub { my ($parser, $attr, $content) = @_; my $title = 'Quote'; if ($attr) { $title = Parse::BBCode::escape_html($attr); } return <<"EOM";
    $title:
    $$content
    EOM }, parse => 1, class => 'block', }, 'code' => { code => sub { my ($parser, $attr, $content) = @_; my $title = 'Code'; if ($attr) { $title = Parse::BBCode::escape_html($attr); } $content = Parse::BBCode::escape_html($$content); return <<"EOM";
    $title:
    $content
    EOM }, parse => 0, class => 'block', }, 'noparse' => '%{html}s', ); my %optional_tags = ( 'html' => '%{noescape}s', ); my %default_escapes = ( html => sub { Parse::BBCode::escape_html($_[2]), }, uri => sub { uri_escape($_[2]), }, link => sub { my ($p, $tag, $var) = @_; if ($var =~ m{^ (?: [a-z]+:// | / ) \S+ \z}ix) { # allow proto:// and absolute links / } else { # invalid return; } $var = Parse::BBCode::escape_html($var); return $var; }, email => $email_valid ? sub { my ($p, $tag, $var) = @_; # extracts the address part of the email or undef my $valid = Email::Valid->address($var); return $valid ? Parse::BBCode::escape_html($valid) : ''; } : sub { my ($p, $tag, $var) = @_; $var = Parse::BBCode::escape_html($var); }, htmlcolor => sub { my $color = $_[2]; ($color =~ m/^(?:#[0-9a-fA-F]{6})\z/ || exists $colors{lc $color}) ? $color : 'inherit' }, num => sub { $_[2] =~ m/^[0-9]+\z/ ? $_[2] : 0; }, ); sub defaults { my ($class, @keys) = @_; return @keys ? (map { $_ => $default_tags{$_} } grep { defined $default_tags{$_} } @keys) : %default_tags; } sub default_escapes { my ($class, @keys) = @_; return @keys ? (map { $_ => $default_escapes{$_} } grep { defined $default_escapes{$_} } @keys) : %default_escapes; } sub optional { my ($class, @keys) = @_; return @keys ? (map { $_ => $optional_tags{$_} } grep { defined $optional_tags{$_} } @keys) : %optional_tags; } 1; __END__ =pod =head1 NAME Parse::BBCode::HTML - Provides HTML defaults for Parse::BBCode =head1 SYNOPSIS use Parse::BBCode; # my $p = Parse::BBCode->new(); my $p = Parse::BBCode->new({ tags => { Parse::BBCode::HTML->defaults, # add your own tags here if needed }, escapes => { Parse::BBCode::HTML->default_escapes, # add your own escapes here if needed }, }); my $code = 'some [b]b code[/b]'; my $parsed = $p->render($code); =head1 METHODS =over 4 =item defaults Returns a hash with default tags. b, i, u, img, url, email, size, color, list, *, quote, code =item default_escapes Returns a hash with escaping functions. These are: html, uri, link, email, htmlcolor, num =item optional Returns a hash of optional tags. These are: html =back =cut XHTML.pm100644001750001750 331112361234004 17040 0ustar00tinatina000000000000Parse-BBCode-0.15/lib/Parse/BBCodepackage Parse::BBCode::XHTML; $Parse::BBCode::XHTML::VERSION = '0.15'; use strict; use warnings; use Carp qw(croak carp); use URI::Escape; use base qw/ Parse::BBCode /; my $email_valid = 0; eval { require Email::Valid; }; $email_valid = 1 unless $@; my %default_tags = ( Parse::BBCode::HTML->defaults(), '' => sub { my $text = Parse::BBCode::escape_html($_[2]); $text =~ s{\r?\n|\r}{
    \n}g; $text; }, 'img' => '[%{html}s]', ); my %optional_tags = ( Parse::BBCode::HTML->optional(), ); my %default_escapes = ( Parse::BBCode::HTML->default_escapes ); sub defaults { my ($class, @keys) = @_; return @keys ? (map { $_ => $default_tags{$_} } grep { defined $default_tags{$_} } @keys) : %default_tags; } sub default_escapes { my ($class, @keys) = @_; return @keys ? (map { $_ => $default_escapes{$_} } grep { defined $default_escapes{$_} } @keys) : %default_escapes; } sub optional { my ($class, @keys) = @_; return @keys ? (grep defined, @optional_tags{@keys}) : %optional_tags; } 1; __END__ =pod =head1 NAME Parse::BBCode::XHTML - Provides XHTML defaults for Parse::BBCode =head1 SYNOPSIS use Parse::BBCode::XHTML; my $p = Parse::BBCode::XHTML->new(); my $code = 'some [b]b code[/b]'; my $parsed = $p->render($code); =head1 METHODS =over 4 =item defaults Returns a hash with default tags. b, i, u, img, url, email, size, color, list, *, quote, code =item default_escapes Returns a hash with escaping functions. html, uri, link, email, htmlcolor, num =item optional Returns a hash of optional tags. html =back =cut code_download.pl100644001750001750 401312361234004 17664 0ustar00tinatina000000000000Parse-BBCode-0.15/examples#!/usr/bin/perl5.10 # usage: # perl examples/code_download.pl display=article # perl examples/code_download.pl display=code article_id=23 code_id=1 use strict; use warnings; use Parse::BBCode; use CGI; my $bbcode = do { local $/; }; my $cgi = CGI->new; my $display = $cgi->param('display'); my $p = Parse::BBCode->new({ tags => { code => { code => sub { my ($parser, $attr, $content, $attribute_fallback, $tag, $info) = @_; my $article_id = $parser->get_params->{article_id}; my $code_id = $tag->get_num; my $code = Parse::BBCode::escape_html($$content); my $title = Parse::BBCode::escape_html($attr); return <<"EOM";
    Code($title) Download:
    $code
    EOM }, }, }, }); my $tree = $p->parse($bbcode); if ($display eq 'article') { my $rendered = $p->render_tree($tree, { article_id => 23 }); print $cgi->header; print <<"EOM"; $rendered EOM } elsif ($display eq 'code') { my $code_id = $cgi->param('code_id'); my $found; # search for code tag number $code_id $tree->walk('bfs', sub { my ($tag) = @_; if ($tag->get_name eq 'code' and $tag->get_num eq $code_id) { $found = $tag; return 1; } return 0; }); my $code = $found->raw_content; print $cgi->header( -type => 'text/plain', '-X-Content-Type-Options' => 'nosniff', '-Content-Disposition' => "attachment; filename=code_23_$code_id.txt", ); print $code; } __DATA__ Codebox one: [code=html] blabla [/code] Codebox two: [code=perl]use Moose; use Moose; has 'x' => (is => 'rw', isa => 'Int'); has 'y' => (is => 'rw', isa => 'Int'); [/code] Markdown.pm100644001750001750 476312361234004 17742 0ustar00tinatina000000000000Parse-BBCode-0.15/lib/Parse/BBCodepackage Parse::BBCode::Markdown; $Parse::BBCode::Markdown::VERSION = '0.15'; use strict; use warnings; use Carp qw(croak carp); use URI::Escape; use base qw/ Parse::BBCode /; my %default_tags = ( 'b' => '*%s*', 'i' => '__%s__', 'u' => '_%s_', # ![alt text](/path/to/img.jpg "Title") 'img' => '![%s](%A)', 'url' => 'url:[%s](%{link}A)', 'email' => 'url:[%s](mailto:%{email}A)', 'size' => '%s', 'color' => '%s', 'list' => 'block:%{parse}s', '*' => { parse => 1, output => '* %s', close => 0, class => 'block', }, quote => { parse => 1, class => 'block', code => sub { my ($parser, $attr, $content, $attribute_fallback) = @_; $$content =~ s/^/> /gm; $$content =~ s/^> >/>>/gm; "$attribute_fallback:\n$$content\n"; }, }, 'code' => { code => sub { my ($parser, $attr, $content, $attribute_fallback) = @_; $$content =~ s/^/| /gm; return "Code $attribute_fallback:\n" . ('-' x 20) . "\n$$content\n" . ('-' x 20); }, class => 'block', }, '' => sub { my $text = $_[2]; $text; }, ); my %optional_tags = ( # Parse::BBCode::HTML->optional(), ); my %default_escapes = ( Parse::BBCode::HTML->default_escapes ); sub defaults { my ($class, @keys) = @_; return @keys ? (map { $_ => $default_tags{$_} } grep { defined $default_tags{$_} } @keys) : %default_tags; } sub default_escapes { my ($class, @keys) = @_; return @keys ? (map { $_ => $default_escapes{$_} } grep { defined $default_escapes{$_} } @keys) : %default_escapes; } sub optional { my ($class, @keys) = @_; return @keys ? (grep defined, @optional_tags{@keys}) : %optional_tags; } 1; __END__ =pod =head1 NAME Parse::BBCode::Markdown - Provides Markdown defaults for Parse::BBCode =head1 SYNOPSIS use Parse::BBCode::Markdown; my $p = Parse::BBCode::Markdown->new(); my $code = 'some [b]b code[/b]'; my $parsed = $p->render($code); =head1 DESCRIPTION This module is experimental and subject to change. =head1 METHODS =over 4 =item defaults Returns a hash with default tags. b, i, u, img, url, email, size, color, list, *, quote, code =item default_escapes Returns a hash with escaping functions. html, uri, link, email, htmlcolor, num =item optional Returns a hash of optional tags. html =back =cut