Text-Textile-2.13/000755 000767 000024 00000000000 12365057563 014070 5ustar00bradstaff000000 000000 Text-Textile-2.13/ARTISTIC000644 000767 000024 00000013737 12356531134 015237 0ustar00bradstaff000000 000000 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 as specified below. "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 uunet.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) give non-standard executables non-standard names, and clearly document 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. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 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 whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. 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 Text-Textile-2.13/bin/000755 000767 000024 00000000000 12365057563 014640 5ustar00bradstaff000000 000000 Text-Textile-2.13/Changes000644 000767 000024 00000004732 12365030022 015346 0ustar00bradstaff000000 000000 2.13 - - Added textile command-line tool submitted by Amir Karger. - Applied a patch submitted by Serap Kadam for issues with parsing whitespace around '!' characters. - Applied a patch submitted by Andy Yacomink for handling mixed-case HTML entity names. - Applied a patch submitted by Andy Yacomink for running some of the inline modifier code as a separate method to allow for a subclass to override/prevent them. 2.12 - - Now hosted at github -- Source: http://github.com/bradchoate/text-textile/tree/master -- Bugs: http://github.com/bradchoate/text-textile/issues 2.10 - - Now requires 5.6.1. - Fixed an incorrectly defined lexical variable. - Applied a patch submitted by Ryan McGuigan to prevent clobbering $_. - Applied a patch from Johannes Plunien to add the 'disable_encode_entities' option. - Should be taint-safe, as all tests run under -T. 2.03 - No changes. Just needed to bump version # for CPAN. 2.02 - Removed Encode package usage altogether until compatibility issues can be ironed out. Modified newline translation to be more cross-platform friendly. 2.01 - Patches to fix issues with older versions of Perl. 2.0 - Many, many fixes and improvements. - Added 'dl' paragraph block which allows for definition lists. - Improved support for embedded HTML. - Better processing for multiple inline formatting options within the same line and/or same section of text. - Added 'bc.' marker for future 'blockcode' tag (emits a pre, code pair for HTML, XHTML1 output). - Added CSS class/id, style, language assignment to markers. - Support for alignment for paragraphs, tables, images. - ':url' can now be appended to 'hn.', 'bq.', 'p.' to add a 'cite' attribute using the specified URL. - Stripped attributes from 'table' tag for Wiki-like markup. 1.1 - A number of regex updates. - If emphasis, strong, etc. shorthand appears at the start of the line, they are now handled properly. - Hand-entered HTML entities are preserved for non-'pre' blocks (meaning text that isn't in a 'pre' tag). This is different from 1.0, so please take note. Standalone '&' characters will still be escaped. - Additional TLDs were added to the URL regex. - A paragraph tag is now used for the content of the 'bq.' marker. - Nesting emphasis and strong formats should work better now. - Added CSS class support for images. - Added link support for images. - Added image dimension support for images. - Fixed a bug that was causing one of those 'internal server errors'. 1.0 - Initial release Text-Textile-2.13/lib/000755 000767 000024 00000000000 12365057563 014636 5ustar00bradstaff000000 000000 Text-Textile-2.13/Makefile.PL000644 000767 000024 00000002716 12356531134 016037 0ustar00bradstaff000000 000000 require 5.006001; use strict; use warnings; use ExtUtils::MakeMaker; my %parms = ( NAME => 'Text::Textile', AUTHOR => 'Brad Choate ', VERSION_FROM => 'lib/Text/Textile.pm', ABSTRACT_FROM => 'lib/Text/Textile.pm', EXE_FILES => [qw(bin/textile)], PREREQ_PM => { 'Test::Harness' => 2.50, # Something reasonably newish 'Exporter' => 0, 'Test::More' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Text-Textile-*' }, ); if ( $ExtUtils::MakeMaker::VERSION =~ /^\d\.\d\d$/ and $ExtUtils::MakeMaker::VERSION > 6.30 ) { $parms{LICENSE} = 'perl'; } if ( $ExtUtils::MakeMaker::VERSION ge '6.46' ) { $parms{META_MERGE} = { resources => { bugtracker => 'http://github.com/bradchoate/text-textile/issues', repository => 'http://github.com/bradchoate/text-textile/tree/master', } }; } WriteMakefile( %parms ); sub MY::postamble { my $file_next_filename = qx(perldoc -l File::Next); my $postamble = <<'MAKE_FRAG'; .PHONY: tags critic tags: ctags -f tags --recurse --totals \ --exclude=blib \ --exclude=.svn \ --exclude='*~' \ --exclude='Text-Textile-*' \ --languages=Perl --langmap=Perl:+.t \ critic: perlcritic -1 -profile perlcriticrc -q lib/Text/Textile.pm t/*.t cover: cover -delete HARNESS_PERL_SWITCHES=-MDevel::Cover make test cover MAKE_FRAG } Text-Textile-2.13/MANIFEST000644 000767 000024 00000000602 12365057563 015217 0ustar00bradstaff000000 000000 ARTISTIC Changes MANIFEST Makefile.PL README.textile bin/textile lib/Text/Textile.pm t/01compile.t t/02paragraph.t t/03url.t t/04list.t t/05combined.t t/06disable_encode_entities.t t/07code.t t/08bin_textile.t t/pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Text-Textile-2.13/META.json000644 000767 000024 00000002230 12365057563 015506 0ustar00bradstaff000000 000000 { "abstract" : "A humane web text generator.", "author" : [ "Brad Choate " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Text-Textile", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Exporter" : "0", "Test::Harness" : "2.5", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://github.com/bradchoate/text-textile/issues" }, "repository" : { "url" : "http://github.com/bradchoate/text-textile/tree/master" } }, "version" : "2.13" } Text-Textile-2.13/META.yml000644 000767 000024 00000001237 12365057563 015344 0ustar00bradstaff000000 000000 --- abstract: 'A humane web text generator.' author: - 'Brad Choate ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Text-Textile no_index: directory: - t - inc requires: Exporter: 0 Test::Harness: 2.5 Test::More: 0 resources: bugtracker: http://github.com/bradchoate/text-textile/issues repository: http://github.com/bradchoate/text-textile/tree/master version: 2.13 Text-Textile-2.13/README.textile000644 000767 000024 00000001400 12365024315 016405 0ustar00bradstaff000000 000000 h1. Text::Textile - a Perl implementation of Textile h2. DESCRIPTION Text::Textile is a Perl impementation of the Textile formatting language. h2. DOCUMENTATION Documentation for this module is available in Textile.pm in POD format. h2. INSTALLATION Traditional Perl module installation applies here: bc. perl Makefile.PL make make test make install h2. BUILD STATUS !https://travis-ci.org/bradchoate/text-textile.svg!:https://travis-ci.org/bradchoate/text-textile h2. CONTACT INFORMATION This module was written by Brad Choate (bradchoate.com), based off the hard work of Dean Allen (textism.com). h2. LICENSE This module is released under the Artistic license which allows it to be distributed and/or modified under the same terms as Perl itself. Text-Textile-2.13/t/000755 000767 000024 00000000000 12365057563 014333 5ustar00bradstaff000000 000000 Text-Textile-2.13/t/01compile.t000644 000767 000024 00000000276 12356531134 016305 0ustar00bradstaff000000 000000 #!/usr/bin/perl -Tw use strict; use warnings; use Test::More tests=>1; BEGIN { use_ok('Text::Textile'); } diag( "Testing Text::Textile $Text::Textile::VERSION under Perl $], $^X" ); Text-Textile-2.13/t/02paragraph.t000644 000767 000024 00000000423 12356531134 016615 0ustar00bradstaff000000 000000 #!/usr/bin/perl -Tw use warnings; use strict; use Test::More tests=>1; use Text::Textile qw(textile); my $source = "paragraph1\n\nparagraph2\n\n"; my $dest = textile($source); my $expected = "

paragraph1

\n\n

paragraph2

"; is($dest, $expected, 'Do we match?'); Text-Textile-2.13/t/03url.t000644 000767 000024 00000000440 12356531134 015452 0ustar00bradstaff000000 000000 #!/usr/bin/perl -Tw use warnings; use strict; use Test::More tests=>1; use Text::Textile qw(textile); my $source = '"title":http://www.example.com'; my $dest = textile($source); my $expected = '

title

'; is($dest, $expected, 'Do we match?'); Text-Textile-2.13/t/04list.t000644 000767 000024 00000001024 12356531134 015623 0ustar00bradstaff000000 000000 #!/usr/bin/perl -Tw use warnings; use strict; use Test::More tests=>2; use Text::Textile qw(textile); my $source = "* list1\n* list2\n* list3\n"; my $dest = textile($source); $dest =~ s/(^\s+|\s+$)//gs; my $expected = "
    \n
  • list1
    • \n
  • list2
    • \n
  • list3
    • \n
"; is($dest, $expected, 'Do we match?'); $source = "# list1\n# list2\n# list3\n"; $dest = textile($source); $dest =~ s/(^\s+|\s+$)//gs; $expected = "
    \n
  1. list1
    2. \n
  2. list2
    3. \n
  3. list3
    4. \n
"; is($dest, $expected, 'Do we match?'); Text-Textile-2.13/t/05combined.t000644 000767 000024 00000001273 12356531134 016437 0ustar00bradstaff000000 000000 #!/usr/bin/perl -Tw use warnings; use strict; use Test::More tests=>1; use Text::Textile qw(textile); my $source = <<'SOURCE'; start paragraph another paragraph * list of things with "urls":http://www.jerakeen.org in * more things in the list a http://bare.url.here. and an email\@address.com SOURCE my $dest = textile($source); $dest =~ s/(^\s+|\s+$)//g; my $expected = <<'EXPECTED';

start paragraph

another paragraph

  • list of things with urls in
  • more things in the list

a http://bare.url.here. and an email\@address.com

EXPECTED $expected =~ s/(^\s+|\s+$)//g; is($dest, $expected, 'Do we match?'); Text-Textile-2.13/t/06disable_encode_entities.t000644 000767 000024 00000003331 12356531134 021501 0ustar00bradstaff000000 000000 #!/usr/bin/perl -Tw use warnings; use strict; use Test::More tests => 2; use Text::Textile; { my $tt = Text::Textile->new( disable_encode_entities => 1 ); my $source = <<'SOURCE'; start paragraph another paragraph * list of things with "urls":http://www.jerakeen.org in * more things in the list a http://bare.url.here. and an email@address.com >>> No encode_entities here <<< and there &&& and here too SOURCE my $dest = $tt->process($source); $dest =~ s/(^\s+|\s+$)//g; my $expected = <<'EXPECTED';

start paragraph

another paragraph

  • list of things with urls in
  • more things in the list

a http://bare.url.here. and an email@address.com

>>> No encode_entities here
<<< and there
&&& and here too

EXPECTED $expected =~ s/(^\s+|\s+$)//g; is( $dest, $expected ); } { my $tt = Text::Textile->new( disable_encode_entities => 0 ); my $source = <<'SOURCE'; start paragraph another paragraph * list of things with "urls":http://www.jerakeen.org in * more things in the list a http://bare.url.here. and an email@address.com >>> encode_entities here <<< and there &&& and here too SOURCE my $dest = $tt->process($source); $dest =~ s/(^\s+|\s+$)//g; my $expected = <<'EXPECTED';

start paragraph

another paragraph

  • list of things with urls in
  • more things in the list

a http://bare.url.here. and an email@address.com

>>> encode_entities here
<<< and there
&&& and here too

EXPECTED $expected =~ s/(^\s+|\s+$)//g; is( $dest, $expected ); } Text-Textile-2.13/t/07code.t000644 000767 000024 00000001033 12356531134 015565 0ustar00bradstaff000000 000000 #!/usr/bin/perl -w use warnings; use strict; use Test::More tests=>1; use Text::Textile qw(textile); my $source = <<'SOURCE'; @if@, @while@, @for@ and @else@ are some of my favorite keywords. I also like the variable @i@. SOURCE my $dest = textile($source); $dest =~ s/(^\s+|\s+$)//g; my $expected = <<'EXPECTED';

if, while, for and else are some of my favorite keywords. I also like the variable i.

EXPECTED $expected =~ s/(^\s+|\s+$)//g; is($dest, $expected); Text-Textile-2.13/t/08bin_textile.t000644 000767 000024 00000005030 12356531134 017163 0ustar00bradstaff000000 000000 # Test bin/textile script use warnings; use strict; use Test::More tests=>5; use File::Temp qw/ tempfile /; # textile executable to use for the test my $Textile_Exe = "blib/script/textile"; my $in = "_Hi_ there"; my $expect_out = "

Hi there

\n"; my $title = "My 1337 page"; my $fullpage_expect_out = "\n\n\n\n$expect_out\n\n"; my $title_expect_out = "\n\n$title\n\n\n$expect_out\n\n"; textile_is($in, $expect_out, "Simple textile run"); textile_is($in, $fullpage_expect_out, "textile -fullpage", "-fullpage"); textile_is($in, $title_expect_out, "textile -title", qq{-title "$title"}); # Bigger test (stolen from t/05combined.t) my $source = <start paragraph

another paragraph

  • list of things with urls in
  • more things in the list

a http://bare.url.here. and an email\@address.com

EXPECTED textile_is($source, $expected, "bigger test"); # Test with outfile (File::Temp will pick a name and add it to -outfile) textile_is($in, $expect_out, "textile -outfile", "-outfile"); exit; sub textile_is { my ($source, $expected, $name, $opts) = @_; $opts = "" unless defined $opts; # Make a file with input text. Always delete when program exits my ($fh, $filename) = tempfile(undef, UNLINK => 1); print $fh $source; close $fh; my $textile_out; if ($opts =~ /-outfile\b/) { # (undef, $filename) = tempfile($template, OPEN => 0); # File::Temp REALLY doesn't like not opening the temp file # (E.g., won't let you use UNLINK=>1) # So open it, close it, then let textile write to it. my ($out_fh, $out_filename) = tempfile(undef, UNLINK => 1); close $out_fh; # Give textile the new filename $opts =~ s/-outfile\b/-outfile $out_filename/; system "$^X $Textile_Exe $opts $filename" and BAIL_OUT("textile executable broke during '$name' test"); # Get the textile results open my $outin_fh, "<", $out_filename; $textile_out = join "", <$outin_fh>; close $outin_fh } else { # Run textile $textile_out = `$^X $Textile_Exe $opts $filename`; BAIL_OUT("textile executable broke during '$name' test") if $? || !defined $textile_out; } # compare w/ expected is($textile_out, $expected, $name); } Text-Textile-2.13/t/pod.t000644 000767 000024 00000000250 12356531134 015266 0ustar00bradstaff000000 000000 #!perl -Tw use warnings; use strict; use Test::More; eval 'use Test::Pod 1.14'; plan skip_all => 'Test::Pod 1.14 required for testing POD' if $@; all_pod_files_ok(); Text-Textile-2.13/lib/Text/000755 000767 000024 00000000000 12365057563 015562 5ustar00bradstaff000000 000000 Text-Textile-2.13/lib/Text/Textile.pm000644 000767 000024 00000327204 12365027143 017535 0ustar00bradstaff000000 000000 package Text::Textile; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw(textile); our $VERSION = 2.13; our $debug = 0; sub new { my $class = shift; my %options = @_; $options{filters} ||= {}; $options{charset} ||= 'iso-8859-1'; for ( qw( char_encoding do_quotes smarty_mode ) ) { $options{$_} = 1 unless exists $options{$_}; } for ( qw( trim_spaces preserve_spaces head_offset disable_encode_entities ) ) { $options{$_} = 0 unless exists $options{$_}; } my $self = bless \%options, $class; if (exists $options{css}) { $self->css($options{css}); } $options{macros} ||= $self->default_macros(); if (exists $options{flavor}) { $self->flavor($options{flavor}); } else { $self->flavor('xhtml1/css'); } return $self; } # getter/setter methods... sub set { my $self = shift; my $opt = shift; if (ref $opt eq 'HASH') { $self->set($_, $opt->{$_}) foreach %{$opt}; } else { my $value = shift; # the following options have special set methods # that activate upon setting: if ($opt eq 'charset') { $self->charset($value); } elsif ($opt eq 'css') { $self->css($value); } elsif ($opt eq 'flavor') { $self->flavor($value); } else { $self->{$opt} = $value; } } return; } sub get { my $self = shift; return $self->{shift} if @_; return undef; } sub disable_html { my $self = shift; if (@_) { $self->{disable_html} = shift; } return $self->{disable_html} || 0; } sub head_offset { my $self = shift; if (@_) { $self->{head_offset} = shift; } return $self->{head_offset} || 0; } sub flavor { my $self = shift; if (@_) { my $flavor = shift; $self->{flavor} = $flavor; if ($flavor =~ m/^xhtml(\d)?(\D|$)/) { if ($1 eq '2') { $self->{_line_open} = ''; $self->{_line_close} = ''; $self->{_blockcode_open} = ''; $self->{_blockcode_close} = ''; $self->{css_mode} = 1; } else { # xhtml 1.x $self->{_line_open} = ''; $self->{_line_close} = '
'; $self->{_blockcode_open} = '
';
                $self->{_blockcode_close} = '
'; $self->{css_mode} = 1; } } elsif ($flavor =~ m/^html/) { $self->{_line_open} = ''; $self->{_line_close} = '
'; $self->{_blockcode_open} = '
';
            $self->{_blockcode_close} = '
'; $self->{css_mode} = $flavor =~ m/\/css/; } $self->_css_defaults() if $self->{css_mode} && !exists $self->{css}; } return $self->{flavor}; } sub css { my $self = shift; if (@_) { my $css = shift; if (ref $css eq 'HASH') { $self->{css} = $css; $self->{css_mode} = 1; } else { $self->{css_mode} = $css; $self->_css_defaults() if $self->{css_mode} && !exists $self->{css}; } } return $self->{css_mode} ? $self->{css} : 0; } sub charset { my $self = shift; if (@_) { $self->{charset} = shift; if ($self->{charset} =~ m/^utf-?8$/i) { $self->char_encoding(0); } else { $self->char_encoding(1); } } return $self->{charset}; } sub docroot { my $self = shift; $self->{docroot} = shift if @_; return $self->{docroot}; } sub trim_spaces { my $self = shift; $self->{trim_spaces} = shift if @_; return $self->{trim_spaces}; } sub filter_param { my $self = shift; $self->{filter_param} = shift if @_; return $self->{filter_param}; } sub preserve_spaces { my $self = shift; $self->{preserve_spaces} = shift if @_; return $self->{preserve_spaces}; } sub filters { my $self = shift; $self->{filters} = shift if @_; return $self->{filters}; } sub char_encoding { my $self = shift; $self->{char_encoding} = shift if @_; return $self->{char_encoding}; } sub disable_encode_entities { my $self = shift; $self->{disable_encode_entities} = shift if @_; return $self->{disable_encode_entities}; } sub handle_quotes { my $self = shift; $self->{do_quotes} = shift if @_; return $self->{do_quotes}; } # end of getter/setter methods # a URL discovery regex. This is from Mastering Regex from O'Reilly. # Some modifications by Brad Choate use vars qw($urlre $blocktags $clstyre $clstypadre $clstyfiltre $alignre $valignre $halignre $imgalignre $tblalignre $codere $punct); $urlre = qr{ # Must start out right... (?=[a-zA-Z0-9./#]) # Match the leading part (proto://hostname, or just hostname) (?: # ftp://, http://, or https:// leading part (?:ftp|https?|telnet|nntp)://(?:\w+(?::\w+)?@)?[-\w]+(?:\.\w[-\w]*)+ | (?:mailto:)?[-\+\w]+\@[-\w]+(?:\.\w[-\w]*)+ | # or, try to find a hostname with our more specific sub-expression (?i: [a-z0-9] (?:[-a-z0-9]*[a-z0-9])? \. )+ # sub domains # Now ending .com, etc. For these, require lowercase (?-i: com\b | edu\b | biz\b | gov\b | in(?:t|fo)\b # .int or .info | mil\b | net\b | org\b | museum\b | aero\b | coop\b | name\b | pro\b | [a-z][a-z]\b # two-letter country codes ) )? # Allow an optional port number (?: : \d+ )? # The rest of the URL is optional, and begins with / . . . (?: /? # The rest are heuristics for what seems to work well [^.!,?;:"'<>()\[\]{}\s\x7F-\xFF]* (?: [.!,?;:]+ [^.!,?;:"'<>()\[\]{}\s\x7F-\xFF]+ #'" )* )? }x; $punct = qr{[\!"#\$%&'()\*\+,\-\./:;<=>\?@\[\\\]\^_`{\|}\~]}; $valignre = qr/[\-^~]/; $tblalignre = qr/[<>=]/; $halignre = qr/(?:<>|[<>=])/; $alignre = qr/(?:$valignre|<>$valignre?|$valignre?<>|$valignre?$halignre?|$halignre?$valignre?)(?!\w)/; $imgalignre = qr/(?:[<>]|$valignre){1,2}/; $clstypadre = qr/ (?:\([A-Za-z0-9_\- \#]+\)) | (?:{ (?: \( [^)]+ \) | [^}] )+ }) | (?:\(+? (?![A-Za-z0-9_\-\#]) ) | (?:\)+?) | (?: \[ [a-zA-Z\-]+? \] ) /x; $clstyre = qr/ (?:\([A-Za-z0-9_\- \#]+\)) | (?:{ [A-Za-z0-9_\-](?: \( [^)]+ \) | [^}] )+ }) | (?: \[ [a-zA-Z\-]+? \] ) /x; $clstyfiltre = qr/ (?:\([A-Za-z0-9_\- \#]+\)) | (?:{ [A-Za-z0-9_\-](?: \( [^)]+ \) | [^}] )+ }) | (?:\|[^\|]+\|) | (?:\(+?(?![A-Za-z0-9_\-\#])) | (?:\)+) | (?: \[ [a-zA-Z]+? \] ) /x; $codere = qr/ (?: [\[{] @ # opening (?:\[([A-Za-z0-9]+)\])? # $1: language id (.+?) # $2: code @ # closing [\]}] ) | (?: (?:^|(?<=[\s\(])) @ # opening (?:\[([A-Za-z0-9]+)\])? # $3: language id ([^\s].*?[^\s]?) # $4: code itself @ # closing (?:$|(?=$punct{1,2}|\s)) ) /x; $blocktags = qr{ < (( /? ( h[1-6] | p | pre | div | table | t[rdh] | [ou]l | li | block(?:quote|code) | form | input | select | option | textarea ) [ >] ) | !-- ) }x; sub process { my $self = shift; return $self->textile(@_); } sub textile { my $self = shift; my ($str) = @_; # disable warnings for the sake of various regex that # have optional matches local $^W = 0; if (!ref $self) { # oops -- procedural technique used, so make # set $str to $self and instantiate a new object # for self $str = $self; $self = new Text::Textile; } return "" unless defined($str); # quick translator for abbreviated block names # to their tag my %macros = ('bq' => 'blockquote'); # an array to hold any portions of the text to be preserved # without further processing by Textile my @repl; # strip out extra newline characters. we're only matching for \n herein #$str =~ s!(?:\r?\n|\r)!\n!g; $str =~ s!(?:\015?\012|\015)!\n!g; # optionally remove trailing spaces $str =~ s/ +$//gm if $self->{trim_spaces}; # preserve contents of the '==', 'pre', 'blockcode' sections $str =~ s{(^|\n\n)==(.+?)==($|\n\n)} {$1."\n\n"._repl(\@repl, $self->format_block(text => $2))."\n\n".$3}ges; unless ($self->{disable_html}) { # preserve style, script tag contents $str =~ s{(<(style|script)(?:>| .+?>).*?)}{_repl(\@repl, $1)}ges; # preserve HTML comments $str =~ s{()}{_repl(\@repl, $1)}ges; # preserve pre block contents, encode contents by default my $pre_start = scalar(@repl); $str =~ s{(]*)?>)(.+?)()} {"\n\n"._repl(\@repl, $1.$self->encode_html($2, 1).$3)."\n\n"}ges; # fix code tags within pre blocks we just saved. for (my $i = $pre_start; $i < scalar(@repl); $i++) { $repl[$i] =~ s{<(/?)code(.*?)>}{<$1code$2>}gs; } # preserve code blocks by default, encode contents $str =~ s{(]+)?>)(.+?)()} {_repl(\@repl, $1.$self->encode_html($2, 1).$3)}ges; # encode blockcode tag (an XHTML 2 tag) and encode it's # content by default $str =~ s{(]+)?>)(.+?)()} {"\n\n"._repl(\@repl, $1.$self->encode_html($2, 1).$3)."\n\n"}ges; # preserve PHPish, ASPish code $str =~ s!(<([\?\%]).*?(\2)>)!_repl(\@repl, $1)!ges; } # pass through and remove links that follow this format # [id_without_spaces (optional title text)]url # lines like this are stripped from the content, and can be # referred to using the "link text":id_without_spaces syntax my %links; $str =~ s{(?:\n|^) [ ]* \[ ([^ ]+?) [ ]*? (?:\( (.+?) \) )? \] ((?:(?:ftp|https?|telnet|nntp)://|/)[^ ]+?) [ ]* (\n|$)} {($links{$1} = {url => $3, title => $2}),"$4"}gemx; local $self->{links} = \%links; # eliminate starting/ending blank lines $str =~ s/^\n+//s; $str =~ s/\n+$//s; # split up text into paragraph blocks, capturing newlines too my @para = split /(\n{2,})/, $str; my ($block, $bqlang, $filter, $class, $sticky, @lines, $style, $stickybuff, $lang, $clear); my $out = ''; foreach my $para (@para) { if ($para =~ m/^\n+$/s) { if ($sticky && defined $stickybuff) { $stickybuff .= $para; } else { $out .= $para; } next; } if ($sticky) { $sticky++; } else { $block = undef; $class = undef; $style = ''; $lang = undef; } my ($id, $cite, $align, $padleft, $padright, @lines, $buffer); if ($para =~ m/^(h[1-6]|p|bq|bc|fn\d+) ((?:$clstyfiltre*|$halignre)*) (\.\.?) (?::(\d+|$urlre))?\ /gx) { if ($sticky) { if ($block eq 'bc') { # close our blockcode section $out =~ s/\n\n$//; $out .= $self->{_blockcode_close}."\n\n"; } elsif ($block eq 'bq') { $out =~ s/\n\n$//; $out .= ''."\n\n"; } elsif ($block eq 'table') { my $table_out = $self->format_table(text => $stickybuff); $table_out = '' if !defined $table_out; $out .= $table_out; $stickybuff = undef; } elsif ($block eq 'dl') { my $dl_out = $self->format_deflist(text => $stickybuff); $dl_out = '' if !defined $dl_out; $out .= $dl_out; $stickybuff = undef; } $sticky = 0; } # block macros: h[1-6](class)., bq(class)., bc(class)., p(class). #warn "paragraph: [[$para]]\n\tblock: $1\n\tparams: $2\n\tcite: $4"; $block = $1; my $params = $2; $cite = $4; if ($3 eq '..') { $sticky = 1; } else { $sticky = 0; $class = undef; $bqlang = undef; $lang = undef; $style = ''; $filter = undef; } if ($block =~ m/^h([1-6])$/) { if ($self->{head_offset}) { $block = 'h' . ($1 + $self->{head_offset}); } } if ($params =~ m/($halignre+)/) { $align = $1; $params =~ s/$halignre+//; } if (defined $params) { if ($params =~ m/\|(.+)\|/) { $filter = $1; $params =~ s/\|.+?\|//; } if ($params =~ m/{([^}]+)}/) { $style = $1; $style =~ s/\n/ /g; $params =~ s/{[^}]+}//g; } if ($params =~ m/\(([A-Za-z0-9_\-\ ]+?)(?:\#(.+?))?\)/ || $params =~ m/\(([A-Za-z0-9_\-\ ]+?)?(?:\#(.+?))\)/) { if ($1 || $2) { $class = $1; $id = $2; if ($class) { $params =~ s/\([A-Za-z0-9_\-\ ]+?(#.*?)?\)//g; } elsif ($id) { $params =~ s/\(#.+?\)//g; } } } if ($params =~ m/(\(+)/) { $padleft = length($1); $params =~ s/\(+//; } if ($params =~ m/(\)+)/) { $padright = length($1); $params =~ s/\)+//; } if ($params =~ m/\[(.+?)\]/) { $lang = $1; if ($block eq 'bc') { $bqlang = $lang; $lang = undef; } $params =~ s/\[.+?\]//; } } #warn "settings:\n\tblock: $block\n\tpadleft: $padleft\n\tpadright: $padright\n\tclass: $class\n\tstyle: $style\n\tid: $id\n\tfilter: $filter\n\talign: $align\n\tlang: $lang\n\tsticky: $sticky"; $para = substr($para, pos($para)); } elsif ($para =~ m/^$/) { $buffer = $repl[$1-1]; } elsif ($para =~ m/^clear([<>]+)?\.$/) { if ($1 eq '<') { $clear = 'left'; } elsif ($1 eq '>') { $clear = 'right'; } else { $clear = 'both'; } next; } elsif ($sticky && (defined $stickybuff) && ($block eq 'table' || $block eq 'dl')) { $stickybuff .= $para; next; } elsif ($para =~ m/^(?:$halignre|$clstypadre*)* [\*\#] (?:$halignre|$clstypadre*)* \ /x) { # '*', '#' prefix means a list $buffer = $self->format_list(text => $para); } elsif ($para =~ m/^(?:table(?:$tblalignre|$clstypadre*)* (\.\.?)\s+)? (?:_|$alignre|$clstypadre*)*\|/x) { # handle wiki-style tables if (defined $1 && ($1 eq '..')) { $block = 'table'; $stickybuff = $para; $sticky = 1; next; } else { $buffer = $self->format_table(text => $para); } } elsif ($para =~ m/^(?:dl(?:$clstyre)*(\.\.?)\s+)/) { # handle definition lists if (defined $1 && ($1 eq '..')) { $block = 'dl'; $stickybuff = $para; $sticky = 1; next; } else { $buffer = $self->format_deflist(text => $para); } } if (defined $buffer) { $out .= $buffer; next; } @lines = split /\n/, $para; next unless @lines; $block ||= 'p'; $buffer = ''; my $pre = ''; my $post = ''; if ($block eq 'bc') { if ($sticky <= 1) { $pre .= $self->{_blockcode_open}; $pre =~ s/>$//s; $pre .= qq{ language="$bqlang"} if $bqlang; if ($align) { my $alignment = _halign($align); if ($self->{css_mode}) { if (($padleft || $padright) && (($alignment eq 'left') || ($alignment eq 'right'))) { $style .= ';float:'.$alignment; } else { $style .= ';text-align:'.$alignment; } $class .= ' '.$self->{css}{"class_align_$alignment"} || $alignment; } else { $pre .= qq{ align="$alignment"} if $alignment; } } $style .= qq{;padding-left:${padleft}em} if $padleft; $style .= qq{;padding-right:${padright}em} if $padright; $style .= qq{;clear:${clear}} if $clear; $class =~ s/^ // if $class; $pre .= qq{ class="$class"} if $class; $pre .= qq{ id="$id"} if $id; $style =~ s/^;// if $style; $pre .= qq{ style="$style"} if $style; $pre .= qq{ lang="$lang"} if $lang; $pre .= '>'; $lang = undef; $bqlang = undef; $clear = undef; } $para =~ s{(?:^|(?<=[\s>])|([{[])) ==(.+?)== (?:$|([\]}])|(?=$punct{1,2}|\s))} {_repl(\@repl, $self->format_block(text => $2, inline => 1, pre => $1, post => $3))}gesx; $buffer .= $self->encode_html_basic($para, 1); $buffer =~ s/<textile#(\d+)>//g; if ($sticky == 0) { $post .= $self->{_blockcode_close}; } $out .= $pre . $buffer . $post; next; } elsif ($block eq 'bq') { if ($sticky <= 1) { $pre .= '{css_mode}) { if (($padleft || $padright) && (($alignment eq 'left') || ($alignment eq 'right'))) { $style .= ';float:'.$alignment; } else { $style .= ';text-align:'.$alignment; } $class .= ' '.$self->{css}{"class_align_$alignment"} || $alignment; } else { $pre .= qq{ align="$alignment"} if $alignment; } } $style .= qq{;padding-left:${padleft}em} if $padleft; $style .= qq{;padding-right:${padright}em} if $padright; $style .= qq{;clear:${clear}} if $clear; $class =~ s/^ // if $class; $pre .= qq{ class="$class"} if $class; $pre .= qq{ id="$id"} if $id; $style =~ s/^;// if $style; $pre .= qq{ style="$style"} if $style; $pre .= qq{ lang="$lang"} if $lang; $pre .= q{ cite="} . $self->format_url(url => $cite) . '"' if defined $cite; $pre .= '>'; $clear = undef; } $pre .= '

'; } elsif ($block =~ m/fn(\d+)/) { my $fnum = $1; $pre .= '{css}{class_footnote} if $self->{css}{class_footnote}; if ($align) { my $alignment = _halign($align); if ($self->{css_mode}) { if (($padleft || $padright) && (($alignment eq 'left') || ($alignment eq 'right'))) { $style .= ';float:'.$alignment; } else { $style .= ';text-align:'.$alignment; } $class .= $self->{css}{"class_align_$alignment"} || $alignment; } else { $pre .= qq{ align="$alignment"}; } } $style .= qq{;padding-left:${padleft}em} if $padleft; $style .= qq{;padding-right:${padright}em} if $padright; $style .= qq{;clear:${clear}} if $clear; $class =~ s/^ // if $class; $pre .= qq{ class="$class"} if $class; $pre .= qq{ id="}.($self->{css}{id_footnote_prefix}||'fn').$fnum.'"'; $style =~ s/^;// if $style; $pre .= qq{ style="$style"} if $style; $pre .= qq{ lang="$lang"} if $lang; $pre .= '>'; $pre .= ''.$fnum.' '; # we can close like a regular paragraph tag now $block = 'p'; $clear = undef; } else { $pre .= '<' . ($macros{$block} || $block); if ($align) { my $alignment = _halign($align); if ($self->{css_mode}) { if (($padleft || $padright) && (($alignment eq 'left') || ($alignment eq 'right'))) { $style .= ';float:'.$alignment; } else { $style .= ';text-align:'.$alignment; } $class .= ' '.$self->{css}{"class_align_$alignment"} || $alignment; } else { $pre .= qq{ align="$alignment"}; } } $style .= qq{;padding-left:${padleft}em} if $padleft; $style .= qq{;padding-right:${padright}em} if $padright; $style .= qq{;clear:${clear}} if $clear; $class =~ s/^ // if $class; $pre .= qq{ class="$class"} if $class; $pre .= qq{ id="$id"} if $id; $style =~ s/^;// if $style; $pre .= qq{ style="$style"} if $style; $pre .= qq{ lang="$lang"} if $lang; $pre .= qq{ cite="} . $self->format_url(url => $cite) . '"' if defined $cite && $block eq 'bq'; #' $pre .= '>'; $clear = undef; } $buffer = $self->format_paragraph(text => $para); if ($block eq 'bq') { $post .= '

' if $buffer !~ m/]/; if ($sticky == 0) { $post .= ''; } } else { $post .= ''; } if ($buffer =~ m/$blocktags/) { $buffer =~ s/^\n\n//s; $out .= $buffer; } else { $buffer = $self->format_block(text => "|$filter|".$buffer, inline => 1) if defined $filter; $out .= $pre . $buffer . $post; } } if ($sticky) { if ($block eq 'bc') { # close our blockcode section $out .= $self->{_blockcode_close}; # . "\n\n"; } elsif ($block eq 'bq') { $out .= ''; # . "\n\n"; } elsif (($block eq 'table') && ($stickybuff)) { my $table_out = $self->format_table(text => $stickybuff); $out .= $table_out if defined $table_out; } elsif (($block eq 'dl') && ($stickybuff)) { my $dl_out = $self->format_deflist(text => $stickybuff); $out .= $dl_out if defined $dl_out; } } # cleanup-- restore preserved blocks my $i = scalar(@repl); $out =~ s!(?:<|<)textile#$i(?:>|>)!$_!, $i-- while local $_ = pop @repl; # scan for br, hr tags that are not closed and close them # only for xhtml! just the common ones -- don't fret over input # and the like. if ($self->{flavor} =~ m/^xhtml/i) { $out =~ s/(<(?:img|br|hr)[^>]*?(?/$1 \/>/g; } return $out; } sub format_paragraph { my $self = shift; my (%args) = @_; my $buffer = defined $args{text} ? $args{text} : ''; my @repl; $buffer =~ s{(?:^|(?<=[\s>])|([{[])) ==(.+?)== (?:$|([\]}])|(?=$punct{1,2}|\s))} {_repl(\@repl, $self->format_block(text => $2, inline => 1, pre => $1, post => $3))}gesx; my $tokens; if ($buffer =~ m/{disable_html})) { # optimization -- no point in tokenizing if we # have no tags to tokenize $tokens = _tokenize($buffer); } else { $tokens = [['text', $buffer]]; } my $result = ''; foreach my $token (@{$tokens}) { my $text = $token->[1]; if ($token->[0] eq 'tag') { $text =~ s/&(?!amp;)/&/g; $result .= $text; } else { $text = $self->format_inline(text => $text); $result .= $text; } } # now, add line breaks for lines that contain plaintext my @lines = split /\n/, $result; $result = ''; my $needs_closing = 0; foreach my $line (@lines) { if (($line !~ m/($blocktags)/) && (($line =~ m/^[^<]/ || $line =~ m/>[^<]/) || ($line !~ m/{_line_open}) { $result .= "\n" if $result ne ''; $result .= $self->{_line_open} . $line . $self->{_line_close}; } else { if ($needs_closing) { $result .= $self->{_line_close} ."\n"; } else { $needs_closing = 1; $result .= "\n" if $result ne ''; } $result .= $line; } } else { if ($needs_closing) { $result .= $self->{_line_close} ."\n"; } else { $result .= "\n" if $result ne ''; } $result .= $line; $needs_closing = 0; } } # at this point, we will restore the \001's to \n's (reversing # the step taken in _tokenize). #$result =~ s/\r/\n/g; $result =~ s/\001/\n/g; my $i = scalar(@repl); $result =~ s||$_|, $i-- while local $_ = pop @repl; # quotalize if ($self->{do_quotes}) { $result = $self->process_quotes($result); } return $result; } { my @qtags = (['**', 'b', '(?format_code(text => $2.$4, lang => $1.$3))}gem; # images must be processed before encoding the text since they might # have the <, > alignment specifiers... # !blah (alt)! -> image $text =~ s!(?:^|(?<=[\s>])|([{[])) # $1: open brace/bracket \! # opening ($imgalignre?) # $2: optional alignment ($clstypadre*) # $3: optional CSS class/id ($imgalignre?) # $4: optional alignment (?:(?<=[^\!])\s+)? # optional space between alignment/css stuff ([^\s\(\!]+) # $5: filename (\s*[^\(\!]*(?:\([^\)]+\))?[^\!]*) # $6: extras (alt text) \! # closing (?::(\d+|$urlre))? # $7: optional URL (?:$|([\]}])|(?=$punct{1,2}|\s))# $8: closing brace/bracket !_repl(\@repl, $self->format_image(pre => $1, src => $5, align => $2||$4, extra => $6, url => $7, clsty => $3, post => $8))!gemx; $text =~ s!(?:^|(?<=[\s>])|([{[])) # $1: open brace/bracket \% # opening ($halignre?) # $2: optional alignment ($clstyre*) # $3: optional CSS class/id ($halignre?) # $4: optional alignment (?:\s*) # spacing ([^\%]+?) # $5: text \% # closing (?::(\d+|$urlre))? # $6: optional URL (?:$|([\]}])|(?=$punct{1,2}|\s))# $7: closing brace/bracket !_repl(\@repl, $self->format_span(pre => $1,text => $5,align => $2||$4, cite => $6, clsty => $3, post => $7))!gemx; $text = $self->encode_html($text); $text =~ s!<textile#(\d+)>!!g; $text =~ s!&quot;!"!g; $text =~ s!&(([a-zA-Z0-9]+|#\d+|#x[0-9A-Fa-f]+);)!&$1!g; $text =~ s!"!"!g; #" # These create markup with entities. Do first and 'save' result for later: # "text":url -> hyperlink # links with brackets surrounding my $parenre = qr/\( (?: [^()] )* \)/x; $text =~ s!( [{[] (?: (?:" # quote character ($clstyre*)? # $2: optional CSS class/id ([^"]+?) # $3: link text (?:\( ( (?:[^()]|$parenre)*) \))? # $4: optional link title " # closing quote ) | (?:' # open single quote ($clstyre*)? # $5: optional CSS class/id ([^']+?) # $6: link text (?:\( ( (?:[^()]|$parenre)*) \))? # $7: optional link title ' # closing quote ) ) :(.+?) # $8: URL suffix [\]}] ) !_repl(\@repl, $self->format_link( text => $1, linktext => defined $3 ? $3 : $6, title => $self->encode_html_basic( defined $4 ? $4 : $7 ), url => $8, clsty => defined $2 ? $2 : $5) )!gemx; $text =~ s!((?:^|(?<=[\s>\(])) # $1: open brace/bracket (?: (?:" # quote character " ($clstyre*)? # $2: optional CSS class/id ([^"]+?) # $3: link text " (?:\( ( (?:[^()]|$parenre)*) \))? # $4: optional link title " # closing quote # " ) | (?:' # open single quote ' ($clstyre*)? # $5: optional CSS class/id ([^']+?) # $6: link text ' (?:\( ( (?:[^()]|$parenre)*) \))? # $7: optional link title ' # closing quote ' ) ) :(\d+|$urlre) # $8: URL suffix (?:$|(?=$punct{1,2}|\s))) # $9: closing brace/bracket !_repl(\@repl, $self->format_link( text => $1, linktext => defined $3 ? $3 : $6, title => $self->encode_html_basic( defined $4 ? $4 : $7 ), url => $8, clsty => defined $2 ? $2 : $5) )!gemx; if ($self->{flavor} =~ m/^xhtml2/) { # citation with cite link $text =~ s!(?:^|(?<=[\s>'"\(])|([{[])) # $1: open brace/bracket ' \?\? # opening '??' ([^\?]+?) # $2: characters (can't contain '?') \?\? # closing '??' :(\d+|$urlre) # $3: optional citation URL (?:$|([\]}])|(?=$punct{1,2}|\s))# $4: closing brace/bracket !_repl(\@repl, $self->format_cite(pre => $1,text => $2,cite => $3,post => $4))!gemx; } # footnotes if ($text =~ m/[^ ]\[\d+\]/) { my $fntag = '{css}{class_footnote}.'"' if $self->{css}{class_footnote}; $fntag .= '>$2}g; } # translate macros: $text =~ s{(\{)(.+?)(\})} {$self->format_macro(pre => $1, post => $3, macro => $2)}gex; # these were present with textile 1 and are common enough # to not require macro braces... # (tm) -> ™ $text =~ s{[\(\[]TM[\)\]]}{™}gi; # (c) -> © $text =~ s{[\(\[]C[\)\]]}{©}gi; # (r) -> ® $text =~ s{[\(\[]R[\)\]]}{®}gi; if ($self->{preserve_spaces}) { # replace two spaces with an em space $text =~ s/(?format_phrase_modifiers( text => $text ); # ABC(Aye Bee Cee) -> acronym $text =~ s{\b([A-Z][A-Za-z0-9]*?[A-Z0-9]+?)\b(?:[(]([^)]*)[)])} {_repl(\@repl,qq{$1})}ge; # ABC -> 'capped' span if (my $caps = $self->{css}{class_caps}) { $text =~ s/(^|[^"][>\s]) # " ((?:[A-Z](?:[A-Z0-9\.,']|\&){2,}\ *)+?) # ' (?=[^A-Z\.0-9]|$) /$1._repl(\@repl, qq{$2<\/span>})/gemx; } # nxn -> n×n $text =~ s{((?:[0-9\.]0|[1-9]|\d['"])\ ?)x(\ ?\d)}{$1×$2}g; # translate these entities to the Unicode equivalents: $text =~ s/…/…/g; $text =~ s/‘/‘/g; $text =~ s/’/’/g; $text =~ s/“/“/g; $text =~ s/”/”/g; $text =~ s/–/–/g; $text =~ s/—/—/g; # Restore replacements done earlier: my $i = scalar(@repl); $text =~ s||$_|, $i-- while local $_ = pop @repl; # translate entities to characters for highbit stuff since # we're using utf8 # removed for backward compatability with older versions of Perl #if ($self->{charset} =~ m/^utf-?8$/i) { # # translate any unicode entities to native UTF-8 # $text =~ s/\&\#(\d+);/($1 > 127) ? pack('U',$1) : chr($1)/ge; #} $text; } sub format_phrase_modifiers { my $self = shift; my (%args) = @_; my $text = defined $args{text} ? $args{text} : ''; my $redo = $text =~ m/[\*_\?\-\+\^\~]/; my $last = $text; while ($redo) { # simple replacements... $redo = 0; foreach my $tag (@qtags) { my ($f, $r, $qf, $cls) = @{$tag}; if ($text =~ s/(?:^|(?<=[\s>'"])|([{[])) # "' $1 - pre $qf # (?:($clstyre*))? # $2 - attributes ([^$cls\s].*?) # $3 - content (?<=\S)$qf # (?:$|([\]}])|(?=$punct{1,2}|\s)) # $4 - post /$self->format_tag(tag => $r, marker => $f, pre => $1, text => $3, clsty => $2, post => $4)/gemx) { $redo ||= $last ne $text; $last = $text; } } } # superscript is an even simpler replacement... $text =~ s/(?$1<\/sup>/g; return $text; } } { # pull in charnames, but only for Perl 5.8 or later (and # disable strict subs for backward compatability my $Have_Charnames = 0; if ($] >= 5.008) { eval 'use charnames qw(:full);'; $Have_Charnames = 1; } sub format_macro { my $self = shift; my %attrs = @_; my $macro = $attrs{macro}; if (defined $self->{macros}->{$macro}) { return $self->{macros}->{$macro}; } # handle full unicode name translation if ($Have_Charnames) { # charnames::vianame is only available in Perl 5.8.0 and later... if (defined (my $unicode = charnames::vianame(uc($macro)))) { return '&#'.$unicode.';'; } } return $attrs{pre}.$macro.$attrs{post}; } } sub format_cite { my $self = shift; my (%args) = @_; my $pre = defined $args{pre} ? $args{pre} : ''; my $text = defined $args{text} ? $args{text} : ''; my $post = defined $args{post} ? $args{post} : ''; my $cite = $args{cite}; _strip_borders(\$pre, \$post); my $tag = $pre.'{flavor} =~ m/^xhtml2/) && defined $cite && $cite) { $cite = $self->format_url(url => $cite); $tag .= qq{ cite="$cite"}; } else { $post .= ':'; } $tag .= '>'; return $tag . $self->format_inline(text => $text) . ''.$post; } sub format_code { my $self = shift; my (%args) = @_; my $code = defined $args{text} ? $args{text} : ''; my $lang = $args{lang}; $code = $self->encode_html($code, 1); $code =~ s/<textile#(\d+)>//g; my $tag = '' . $code . ''; } sub format_classstyle { my $self = shift; my ($clsty, $class, $style) = @_; $style = '' if not defined $style; $class =~ s/^ // if defined $class; my ($lang, $padleft, $padright, $id); if ($clsty && ($clsty =~ m/{([^}]+)}/)) { my $_style = $1; $_style =~ s/\n/ /g; $style .= ';'.$_style; $clsty =~ s/{[^}]+}//g; } if ($clsty && ($clsty =~ m/\(([A-Za-z0-9_\- ]+?)(?:#(.+?))?\)/ || $clsty =~ m/\(([A-Za-z0-9_\- ]+?)?(?:#(.+?))\)/)) { if ($1 || $2) { if ($class) { $class = $1 . ' ' . $class; } else { $class = $1; } $id = $2; if ($class) { $clsty =~ s/\([A-Za-z0-9_\- ]+?(#.*?)?\)//g; } if ($id) { $clsty =~ s/\(#.+?\)//g; } } } if ($clsty && ($clsty =~ m/(\(+)/)) { $padleft = length($1); $clsty =~ s/\(+//; } if ($clsty && ($clsty =~ m/(\)+)/)) { $padright = length($1); $clsty =~ s/\)+//; } if ($clsty && ($clsty =~ m/\[(.+?)\]/)) { $lang = $1; $clsty =~ s/\[.+?\]//g; } my $attrs = ''; $style .= qq{;padding-left:${padleft}em} if $padleft; $style .= qq{;padding-right:${padright}em} if $padright; $style =~ s/^;//; if ( $class ) { $class =~ s/^ //; $class =~ s/ $//; $attrs .= qq{ class="$class"}; } $attrs .= qq{ id="$id"} if $id; $attrs .= qq{ style="$style"} if $style; $attrs .= qq{ lang="$lang"} if $lang; $attrs =~ s/^ //; return $attrs; } sub format_tag { my $self = shift; my (%args) = @_; my $tagname = $args{tag}; my $text = defined $args{text} ? $args{text} : ''; my $pre = defined $args{pre} ? $args{pre} : ''; my $post = defined $args{post} ? $args{post} : ''; my $clsty = defined $args{clsty} ? $args{clsty} : ''; _strip_borders(\$pre, \$post); my $tag = "<$tagname"; my $attr = $self->format_classstyle($clsty); $tag .= qq{ $attr} if $attr; $tag .= qq{>$text}; return $pre.$tag.$post; } sub format_deflist { my $self = shift; my (%args) = @_; my $str = defined $args{text} ? $args{text} : ''; my $clsty; my @lines = split /\n/, $str; if ($lines[0] =~ m/^(dl($clstyre*?)\.\.?(?:\ +|$))/) { $clsty = $2; $lines[0] = substr($lines[0], length($1)); } my ($dt, $dd); my $out = ''; foreach my $line (@lines) { if ($line =~ m/^((?:$clstyre*)(?:[^\ ].*?)(?format_classstyle($clsty) if $clsty; $tag .= qq{ $attr} if $attr; $tag .= '>'."\n"; return $tag.$out."\n"; } sub add_term { my ($self, $dt, $dd) = @_; my ($dtattr, $ddattr); my $dtlang; if ($dt =~ m/^($clstyre*)/) { my $param = $1; $dtattr = $self->format_classstyle($param); if ($param =~ m/\[([A-Za-z]+?)\]/) { $dtlang = $1; } $dt = substr($dt, length($param)); } if ($dd =~ m/^($clstyre*)/) { my $param = $1; # if the language was specified for the term, # then apply it to the definition as well (unless # already specified of course) if ($dtlang && ($param =~ m/\[([A-Za-z]+?)\]/)) { undef $dtlang; } $ddattr = $self->format_classstyle(($dtlang ? "[$dtlang]" : '') . $param); $dd = substr($dd, length($param)); } my $out = 'format_inline(text => $dt) . '' . "\n"; if ($dd =~ m/\n\n/) { $dd = $self->textile($dd) if $dd =~ m/\n\n/; } else { $dd = $self->format_paragraph(text => $dd); } $out .= '' . "\n"; return $out; } sub format_list { my $self = shift; my (%args) = @_; my $str = defined $args{text} ? $args{text} : ''; my %list_tags = ('*' => 'ul', '#' => 'ol'); my @lines = split /\n/, $str; my @stack; my $last_depth = 0; my $item = ''; my $out = ''; foreach my $line (@lines) { if ($line =~ m/^((?:$clstypadre*|$halignre)*) ([\#\*]+) ((?:$halignre|$clstypadre*)*) \ (.+)$/x) { if ($item ne '') { if ($item =~ m/\n/) { if ($self->{_line_open}) { $item =~ s/(]*>|^)/$1$self->{_line_open}/gm; $item =~ s/(\n|$)/$self->{_line_close}$1/gs; } else { $item =~ s/(\n)/$self->{_line_close}$1/gs; } } $out .= $item; $item = ''; } my $type = substr($2, 0, 1); my $depth = length($2); my $blockparam = $1; my $itemparam = $3; $line = $4; my ($blockclsty, $blockalign, $blockattr, $itemattr, $itemclsty, $itemalign); if ($blockparam =~ m/($clstypadre+)/) { $blockclsty = $1; } if ($blockparam =~ m/($halignre+)/) { $blockalign = $1; } if ($itemparam =~ m/($clstypadre+)/) { $itemclsty = $1; } if ($itemparam =~ m/($halignre+)/) { $itemalign = $1; } $itemattr = $self->format_classstyle($itemclsty) if $itemclsty; if ($depth > $last_depth) { for (my $j = $last_depth; $j < $depth; $j++) { $out .= qq{<$list_tags{$type}}; push @stack, $type; if ($blockclsty) { $blockattr = $self->format_classstyle($blockclsty); $out .= ' '.$blockattr if $blockattr; } $out .= ">\n\n\n}; } if ($depth) { $out .= 'format_paragraph(text => $line); } if ($item =~ m/\n/) { if ($self->{_line_open}) { $item =~ s/(]*>|^)/$1$self->{_line_open}/gm; $item =~ s/(\n|$)/$self->{_line_close}$1/gs; } else { $item =~ s/(\n)/$self->{_line_close}$1/gs; } } $out .= $item; for (my $j = 1; $j <= $last_depth; $j++) { $out .= '' if $j == 1; my $type = pop @stack; $out .= "\n".''; $out .= '' if $j != $last_depth; } return $out; } sub format_block { my $self = shift; my (%args) = @_; my $str = defined $args{text} ? $args{text} : ''; my $pre = defined $args{pre} ? $args{pre} : ''; my $post = defined $args{post} ? $args{post} : ''; my $inline = $args{inline}; _strip_borders(\$pre, \$post); my ($filters) = $str =~ m/^(\|(?:(?:[a-z0-9_\-]+)\|)+)/; if ($filters) { my $filtreg = quotemeta($filters); $str =~ s/^$filtreg//; $filters =~ s/^\|//; $filters =~ s/\|$//; my @filters = split /\|/, $filters; $str = $self->apply_filters(text => $str, filters => \@filters); my $count = scalar(@filters); if ($str =~ s!(

){$count}!$1!gs) { $str =~ s!(

){$count}!$1!gs; $str =~ s!(){$count}!$1!gs; } } if ($inline) { # strip off opening para, closing para, since we're # operating within an inline block $str =~ s/^\s*]*>//; $str =~ s/<\/p>\s*$//; } return $pre.$str.$post; } sub format_link { my $self = shift; my (%args) = @_; my $text = defined $args{text} ? $args{text} : ''; my $linktext = defined $args{linktext} ? $args{linktext} : ''; my $title = $args{title}; my $url = $args{url}; my $clsty = $args{clsty}; if (!defined $url || $url eq '') { return $text; } if ($self->{links} && $self->{links}{$url}) { $title ||= $self->{links}{$url}{title}; $url = $self->{links}{$url}{url}; } $linktext =~ s/ +$//; $linktext = $self->format_paragraph(text => $linktext); $url = $self->format_url(linktext => $linktext, url => $url); my $tag = qq{format_classstyle($clsty); $tag .= qq{ $attr} if $attr; if (defined $title) { $title =~ s/^\s+//; $tag .= qq{ title="$title"} if length($title); } $tag .= qq{>$linktext}; return $tag; } sub format_url { my $self = shift; my (%args) = @_; my $url = defined $args{url} ? $args{url} : ''; if ($url =~ m/^(mailto:)?([-\+\w]+\@[-\w]+(\.\w[-\w]*)+)$/) { $url = 'mailto:'.$self->mail_encode($2); } if ($url !~ m{^(/|\./|\.\./|#)}) { $url = "http://$url" if $url !~ m{^(?:https?|ftp|mailto|nntp|telnet)}; } $url =~ s/&(?!amp;)/&/g; $url =~ s/ /\+/g; $url =~ s/^((?:.+?)\?)(.+)$/$1.$self->encode_url($2)/ge; return $url; } sub format_span { my $self = shift; my (%args) = @_; my $text = defined $args{text} ? $args{text} : ''; my $pre = defined $args{pre} ? $args{pre} : ''; my $post = defined $args{post} ? $args{post} : ''; my $cite = defined $args{cite} ? $args{cite} : ''; my $align = $args{align}; my $clsty = $args{clsty}; _strip_borders(\$pre, \$post); my ($class, $style); my $tag = qq{{css_mode}) { my $alignment = _halign($align); $style .= qq{;float:$alignment} if $alignment; $class .= ' '.$self->{css}{"class_align_$alignment"} if $alignment; } else { my $alignment = _halign($align) || _valign($align); $tag .= qq{ align="$alignment"} if $alignment; } } my $attr = $self->format_classstyle($clsty, $class, $style); $tag .= qq{ $attr} if $attr; if (defined $cite) { $cite =~ s/^://; $cite = $self->format_url(url => $cite); $tag .= qq{ cite="$cite"}; } return $pre.$tag.'>'.$self->format_paragraph(text => $text).''.$post; } sub format_image { my $self = shift; my (%args) = @_; my $src = defined $args{src} ? $args{src} : ''; my $pre = defined $args{pre} ? $args{pre} : ''; my $post = defined $args{post} ? $args{post} : ''; my $extra = $args{extra}; my $align = $args{align}; my $link = $args{url}; my $clsty = $args{clsty}; _strip_borders(\$pre, \$post); return $pre.'!!'.$post if length($src) == 0; my $tag; if ($self->{flavor} =~ m/^xhtml2/) { my $type; # poor man's mime typing. need to extend this externally if ($src =~ m/(?:\.jpeg|\.jpg)$/i) { $type = 'image/jpeg'; } elsif ($src =~ m/\.gif$/i) { $type = 'image/gif'; } elsif ($src =~ m/\.png$/i) { $type = 'image/png'; } elsif ($src =~ m/\.tiff$/i) { $type = 'image/tiff'; } $tag = qq{{css_mode}) { my $alignment = _halign($align); $style .= qq{;float:$alignment} if $alignment; $class .= ' '.$alignment if $alignment; $alignment = _valign($align); if ($alignment) { my $imgvalign = ($alignment =~ m/(top|bottom)/ ? 'text-' . $alignment : $alignment); $style .= qq{;vertical-align:$imgvalign} if $imgvalign; $class .= ' '.$self->{css}{"class_align_$alignment"} if $alignment; } } else { my $alignment = _halign($align) || _valign($align); $tag .= qq{ align="$alignment"} if $alignment; } } my ($pctw, $pcth, $w, $h, $alt); if (defined $extra) { ($alt) = $extra =~ m/\(([^\)]+)\)/; $extra =~ s/\([^\)]+\)//; my ($pct) = ($extra =~ m/(^|\s)(\d+)%(\s|$)/)[1]; if (!$pct) { ($pctw, $pcth) = ($extra =~ m/(^|\s)(\d+)%x(\d+)%(\s|$)/)[1,2]; } else { $pctw = $pcth = $pct; } if (!$pctw && !$pcth) { ($w,$h) = ($extra =~ m/(^|\s)(\d+|\*)x(\d+|\*)(\s|$)/)[1,2]; $w = '' if $w && $w eq '*'; $h = '' if $h && $h eq '*'; if (!$w) { ($w) = ($extra =~ m/(^|[,\s])(\d+)w([\s,]|$)/)[1]; } if (!$h) { ($h) = ($extra =~ m/(^|[,\s])(\d+)h([\s,]|$)/)[1]; } } } $alt = '' unless defined $alt; if ($self->{flavor} !~ m/^xhtml2/) { $tag .= ' alt="' . $self->encode_html_basic($alt) . '"'; } if ($w && $h) { if ($self->{flavor} !~ m/^xhtml2/) { $tag .= qq{ height="$h" width="$w"}; } else { $style .= qq{;height:$h}.qq{px;width:$w}.q{px}; } } else { my ($image_w, $image_h) = $self->image_size($src); if (($image_w && $image_h) && ($w || $h)) { # image size determined, but only width or height specified if ($w && !$h) { # width defined, scale down height proportionately $h = int($image_h * ($w / $image_w)); } elsif ($h && !$w) { $w = int($image_w * ($h / $image_h)); } } else { $w = $image_w; $h = $image_h; } if ($w && $h) { if ($pctw || $pcth) { $w = int($w * $pctw / 100); $h = int($h * $pcth / 100); } if ($self->{flavor} !~ m/^xhtml2/) { $tag .= qq{ height="$h" width="$w"}; } else { $style .= qq{;height:$h}.qq{px;width:$w}.q{px}; } } } my $attr = $self->format_classstyle($clsty, $class, $style); $tag .= qq{ $attr} if $attr; if ($self->{flavor} =~ m/^xhtml2/) { $tag .= '>

' . $self->encode_html_basic($alt) . '

'; } elsif ($self->{flavor} =~ m/^xhtml/) { $tag .= ' />'; } else { $tag .= '>'; } if (defined $link) { $link =~ s/^://; $link = $self->format_url(url => $link); $tag = ''.$tag.''; } return $pre.$tag.$post; } sub format_table { my $self = shift; my (%args) = @_; my $str = defined $args{text} ? $args{text} : ''; my @lines = split /\n/, $str; my @rows; my $line_count = scalar(@lines); for (my $i = 0; $i < $line_count; $i++) { if ($lines[$i] !~ m/\|\s*$/) { if ($i + 1 < $line_count) { $lines[$i+1] = $lines[$i] . "\n" . $lines[$i+1] if $i+1 <= $#lines; } else { push @rows, $lines[$i]; } } else { push @rows, $lines[$i]; } } my ($tid, $tpadl, $tpadr, $tlang); my $tclass = ''; my $tstyle = ''; my $talign = ''; if ($rows[0] =~ m/^table[^\.]/) { my $row = $rows[0]; $row =~ s/^table//; my $params = 1; # process row parameters until none are left while ($params) { if ($row =~ m/^($tblalignre)/) { # found row alignment $talign .= $1; $row = substr($row, length($1)) if $1; redo if $1; } if ($row =~ m/^($clstypadre)/) { # found a class/id/style/padding indicator my $clsty = $1; $row = substr($row, length($clsty)) if $clsty; if ($clsty =~ m/{([^}]+)}/) { $tstyle = $1; $clsty =~ s/{([^}]+)}//; redo if $tstyle; } if ($clsty =~ m/\(([A-Za-z0-9_\- ]+?)(?:#(.+?))?\)/ || $clsty =~ m/\(([A-Za-z0-9_\- ]+?)?(?:#(.+?))\)/) { if ($1 || $2) { $tclass = $1; $tid = $2; redo; } } $tpadl = length($1) if $clsty =~ m/(\(+)/; $tpadr = length($1) if $clsty =~ m/(\)+)/; $tlang = $1 if $clsty =~ m/\[(.+?)\]/; redo if $clsty; } $params = 0; } $row =~ s/\.\s+//; $rows[0] = $row; } my $out = ''; my @cols = split /\|/, $rows[0].' '; my (@colalign, @rowspans); foreach my $row (@rows) { my @cols = split /\|/, $row.' '; my $colcount = $#cols; pop @cols; my $colspan = 0; my $row_out = ''; my ($rowclass, $rowid, $rowalign, $rowstyle, $rowheader); $cols[0] = '' if !defined $cols[0]; if ($cols[0] =~ m/_/) { $cols[0] =~ s/_//g; $rowheader = 1; } if ($cols[0] =~ m/{([^}]+)}/) { $rowstyle = $1; $cols[0] =~ s/{[^}]+}//g; } if ($cols[0] =~ m/\(([^\#]+?)?(#(.+))?\)/) { $rowclass = $1; $rowid = $3; $cols[0] =~ s/\([^\)]+\)//g; } $rowalign = $1 if $cols[0] =~ m/($alignre)/; for (my $c = $colcount - 1; $c > 0; $c--) { if ($rowspans[$c]) { $rowspans[$c]--; next if $rowspans[$c] > 1; } my ($colclass, $colid, $header, $colparams, $colpadl, $colpadr, $collang); my $colstyle = ''; my $colalign = $colalign[$c]; my $col = pop @cols; $col ||= ''; my $attrs = ''; if ($col =~ m/^(((_|[\/\\]\d+|$alignre|$clstypadre)+)\. )/) { my $colparams = $2; $col = substr($col, length($1)); my $params = 1; # keep processing column parameters until there # are none left... while ($params) { if ($colparams =~ m/^(_|$alignre)/g) { # found alignment or heading indicator $attrs .= $1; $colparams = substr($colparams, pos($colparams)) if $1; redo if $1; } if ($colparams =~ m/^($clstypadre)/g) { # found a class/id/style/padding marker my $clsty = $1; $colparams = substr($colparams, pos($colparams)) if $clsty; if ($clsty =~ m/{([^}]+)}/) { $colstyle = $1; $clsty =~ s/{([^}]+)}//; } if ($clsty =~ m/\(([A-Za-z0-9_\- ]+?)(?:#(.+?))?\)/ || $clsty =~ m/\(([A-Za-z0-9_\- ]+?)?(?:#(.+?))\)/) { if ($1 || $2) { $colclass = $1; $colid = $2; if ($colclass) { $clsty =~ s/\([A-Za-z0-9_\- ]+?(#.*?)?\)//g; } elsif ($colid) { $clsty =~ s/\(#.+?\)//g; } } } if ($clsty =~ m/(\(+)/) { $colpadl = length($1); $clsty =~ s/\(+//; } if ($clsty =~ m/(\)+)/) { $colpadr = length($1); $clsty =~ s/\)+//; } if ($clsty =~ m/\[(.+?)\]/) { $collang = $1; $clsty =~ s/\[.+?\]//; } redo if $clsty; } if ($colparams =~ m/^\\(\d+)/) { $colspan = $1; $colparams = substr($colparams, length($1)+1); redo if $1; } if ($colparams =~ m/\/(\d+)/) { $rowspans[$c] = $1 if $1; $colparams = substr($colparams, length($1)+1); redo if $1; } $params = 0; } } if (length($attrs)) { $header = 1 if $attrs =~ m/_/; $colalign = '' if $attrs =~ m/($alignre)/ && length($1); # determine column alignment if ($attrs =~ m/<>/) { $colalign .= '<>'; } elsif ($attrs =~ m//) { $colalign = '>'; } if ($attrs =~ m/\^/) { $colalign .= '^'; } elsif ($attrs =~ m/~/) { $colalign .= '~'; } elsif ($attrs =~ m/-/) { $colalign .= '-'; } } $header = 1 if $rowheader; $colalign[$c] = $colalign if $header; $col =~ s/^ +//; $col =~ s/ +$//; if (length($col)) { # create one cell tag my $rowspan = $rowspans[$c] || 0; my $col_out = '<' . ($header ? 'th' : 'td'); if (defined $colalign) { # horizontal, vertical alignment my $halign = _halign($colalign); $col_out .= qq{ align="$halign"} if $halign; my $valign = _valign($colalign); $col_out .= qq{ valign="$valign"} if $valign; } # apply css attributes, row, column spans $colstyle .= qq{;padding-left:${colpadl}em} if $colpadl; $colstyle .= qq{;padding-right:${colpadr}em} if $colpadr; $col_out .= qq{ class="$colclass"} if $colclass; $col_out .= qq{ id="$colid"} if $colid; $colstyle =~ s/^;// if $colstyle; $col_out .= qq{ style="$colstyle"} if $colstyle; $col_out .= qq{ lang="$collang"} if $collang; $col_out .= qq{ colspan="$colspan"} if $colspan > 1; $col_out .= qq{ rowspan="$rowspan"} if ($rowspan||0) > 1; $col_out .= '>'; # if the content of this cell has newlines OR matches # our paragraph block signature, process it as a full-blown # textile document if (($col =~ m/\n\n/) || ($col =~ m/^(?:$halignre|$clstypadre*)* [\*\#] (?:$clstypadre*|$halignre)*\ /x)) { $col_out .= $self->textile($col); } else { $col_out .= $self->format_paragraph(text => $col); } $col_out .= ''; $row_out = $col_out . $row_out; $colspan = 0 if $colspan; } else { $colspan = 1 if $colspan == 0; $colspan++; } } if ($colspan > 1) { # handle the spanned column if we came up short $colspan--; $row_out = q{1 ? qq{ colspan="$colspan"} : '') . qq{>$row_out}; } # build one table row $out .= q{$row_out}; } # now, form the table tag itself my $table = ''; $table .= q{{css_mode}) { # horizontal alignment my $alignment = _halign($talign); if ($talign eq '=') { $tstyle .= ';margin-left:auto;margin-right:auto'; } else { $tstyle .= ';float:'.$alignment if $alignment; } $tclass .= ' '.$alignment if $alignment; } else { my $alignment = _halign($talign); $table .= qq{ align="$alignment"} if $alignment; } } $tstyle .= qq{;padding-left:${tpadl}em} if $tpadl; $tstyle .= qq{;padding-right:${tpadr}em} if $tpadr; $tclass =~ s/^ // if $tclass; $table .= qq{ class="$tclass"} if $tclass; $table .= qq{ id="$tid"} if $tid; $tstyle =~ s/^;// if $tstyle; $table .= qq{ style="$tstyle"} if $tstyle; $table .= qq{ lang="$tlang"} if $tlang; $table .= q{ cellspacing="0"} if $tclass || $tid || $tstyle; $table .= qq{>$out}; if ($table =~ m{}) { # exception -- something isn't right so return fail case return undef; } return $table; } sub apply_filters { my $self = shift; my (%args) = @_; my $text = $args{text}; return '' unless defined $text; my $list = $args{filters}; my $filters = $self->{filters}; return $text unless (ref $filters) eq 'HASH'; my $param = $self->filter_param; foreach my $filter (@{$list}) { next unless $filters->{$filter}; if ((ref $filters->{$filter}) eq 'CODE') { $text = $filters->{$filter}->($text, $param); } } return $text; } # minor utility / formatting routines { my $Have_Entities = eval 'use HTML::Entities; 1' ? 1 : 0; sub encode_html { my $self = shift; my($html, $can_double_encode) = @_; return '' unless defined $html; return $html if $self->{disable_encode_entities}; if ($Have_Entities && $self->{char_encoding}) { $html = HTML::Entities::encode_entities($html); } else { $html = $self->encode_html_basic($html, $can_double_encode); } return $html; } sub decode_html { my $self = shift; my ($html) = @_; $html =~ s{"}{"}g; $html =~ s{&}{&}g; $html =~ s{<}{<}g; $html =~ s{>}{>}g; return $html; } sub encode_html_basic { my $self = shift; my($html, $can_double_encode) = @_; return '' unless defined $html; return $html unless $html =~ m/[^\w\s]/; if ($can_double_encode) { $html =~ s{&}{&}g; } else { ## Encode any & not followed by something that looks like ## an entity, numeric or otherwise. $html =~ s/&(?!#?[xX]?(?:[0-9a-fA-F]+|\w{1,8});)/&/g; } $html =~ s{"}{"}g; $html =~ s{<}{<}g; $html =~ s{>}{>}g; return $html; } } { my $Have_ImageSize = eval 'use Image::Size; 1' ? 1 : 0; sub image_size { my $self = shift; my ($file) = @_; if ($Have_ImageSize) { if (-f $file) { return Image::Size::imgsize($file); } else { if (my $docroot = $self->docroot) { require File::Spec; my $fullpath = File::Spec->catfile($docroot, $file); if (-f $fullpath) { return Image::Size::imgsize($fullpath); } } } } return undef; } } sub encode_url { my $self = shift; my($str) = @_; $str =~ s!([^A-Za-z0-9_\.\-\+\&=\%;])! ord($1) > 255 ? '%u' . (uc sprintf("%04x", ord($1))) : '%' . (uc sprintf("%02x", ord($1)))!egx; return $str; } sub mail_encode { my $self = shift; my ($addr) = @_; # granted, this is simple, but it gives off warm fuzzies $addr =~ s!([^\$])! ord($1) > 255 ? '%u' . (uc sprintf("%04x", ord($1))) : '%' . (uc sprintf("%02x", ord($1)))!egx; return $addr; } sub process_quotes { # stub routine for now. subclass and implement. my $self = shift; my ($str) = @_; return $str; } # a default set of macros for the {...} macro syntax # just a handy way to write a lot of the international characters # and some commonly used symbols sub default_macros { my $self = shift; # <, >, " must be html entities in the macro text since # those values are escaped by the time they are processed # for macros. return { 'c|' => '¢', # CENT SIGN '|c' => '¢', # CENT SIGN 'L-' => '£', # POUND SIGN '-L' => '£', # POUND SIGN 'Y=' => '¥', # YEN SIGN '=Y' => '¥', # YEN SIGN '(c)' => '©', # COPYRIGHT SIGN '<<' => '«', # LEFT-POINTING DOUBLE ANGLE QUOTATION '(r)' => '®', # REGISTERED SIGN '+_' => '±', # PLUS-MINUS SIGN '_+' => '±', # PLUS-MINUS SIGN '>>' => '»', # RIGHT-POINTING DOUBLE ANGLE QUOTATION '1/4' => '¼', # VULGAR FRACTION ONE QUARTER '1/2' => '½', # VULGAR FRACTION ONE HALF '3/4' => '¾', # VULGAR FRACTION THREE QUARTERS 'A`' => 'À', # LATIN CAPITAL LETTER A WITH GRAVE '`A' => 'À', # LATIN CAPITAL LETTER A WITH GRAVE 'A\'' => 'Á', # LATIN CAPITAL LETTER A WITH ACUTE '\'A' => 'Á', # LATIN CAPITAL LETTER A WITH ACUTE 'A^' => 'Â', # LATIN CAPITAL LETTER A WITH CIRCUMFLEX '^A' => 'Â', # LATIN CAPITAL LETTER A WITH CIRCUMFLEX 'A~' => 'Ã', # LATIN CAPITAL LETTER A WITH TILDE '~A' => 'Ã', # LATIN CAPITAL LETTER A WITH TILDE 'A"' => 'Ä', # LATIN CAPITAL LETTER A WITH DIAERESIS '"A' => 'Ä', # LATIN CAPITAL LETTER A WITH DIAERESIS 'Ao' => 'Å', # LATIN CAPITAL LETTER A WITH RING ABOVE 'oA' => 'Å', # LATIN CAPITAL LETTER A WITH RING ABOVE 'AE' => 'Æ', # LATIN CAPITAL LETTER AE 'C,' => 'Ç', # LATIN CAPITAL LETTER C WITH CEDILLA ',C' => 'Ç', # LATIN CAPITAL LETTER C WITH CEDILLA 'E`' => 'È', # LATIN CAPITAL LETTER E WITH GRAVE '`E' => 'È', # LATIN CAPITAL LETTER E WITH GRAVE 'E\'' => 'É', # LATIN CAPITAL LETTER E WITH ACUTE '\'E' => 'É', # LATIN CAPITAL LETTER E WITH ACUTE 'E^' => 'Ê', # LATIN CAPITAL LETTER E WITH CIRCUMFLEX '^E' => 'Ê', # LATIN CAPITAL LETTER E WITH CIRCUMFLEX 'E"' => 'Ë', # LATIN CAPITAL LETTER E WITH DIAERESIS '"E' => 'Ë', # LATIN CAPITAL LETTER E WITH DIAERESIS 'I`' => 'Ì', # LATIN CAPITAL LETTER I WITH GRAVE '`I' => 'Ì', # LATIN CAPITAL LETTER I WITH GRAVE 'I\'' => 'Í', # LATIN CAPITAL LETTER I WITH ACUTE '\'I' => 'Í', # LATIN CAPITAL LETTER I WITH ACUTE 'I^' => 'Î', # LATIN CAPITAL LETTER I WITH CIRCUMFLEX '^I' => 'Î', # LATIN CAPITAL LETTER I WITH CIRCUMFLEX 'I"' => 'Ï', # LATIN CAPITAL LETTER I WITH DIAERESIS '"I' => 'Ï', # LATIN CAPITAL LETTER I WITH DIAERESIS 'D-' => 'Ð', # LATIN CAPITAL LETTER ETH '-D' => 'Ð', # LATIN CAPITAL LETTER ETH 'N~' => 'Ñ', # LATIN CAPITAL LETTER N WITH TILDE '~N' => 'Ñ', # LATIN CAPITAL LETTER N WITH TILDE 'O`' => 'Ò', # LATIN CAPITAL LETTER O WITH GRAVE '`O' => 'Ò', # LATIN CAPITAL LETTER O WITH GRAVE 'O\'' => 'Ó', # LATIN CAPITAL LETTER O WITH ACUTE '\'O' => 'Ó', # LATIN CAPITAL LETTER O WITH ACUTE 'O^' => 'Ô', # LATIN CAPITAL LETTER O WITH CIRCUMFLEX '^O' => 'Ô', # LATIN CAPITAL LETTER O WITH CIRCUMFLEX 'O~' => 'Õ', # LATIN CAPITAL LETTER O WITH TILDE '~O' => 'Õ', # LATIN CAPITAL LETTER O WITH TILDE 'O"' => 'Ö', # LATIN CAPITAL LETTER O WITH DIAERESIS '"O' => 'Ö', # LATIN CAPITAL LETTER O WITH DIAERESIS 'O/' => 'Ø', # LATIN CAPITAL LETTER O WITH STROKE '/O' => 'Ø', # LATIN CAPITAL LETTER O WITH STROKE 'U`' => 'Ù', # LATIN CAPITAL LETTER U WITH GRAVE '`U' => 'Ù', # LATIN CAPITAL LETTER U WITH GRAVE 'U\'' => 'Ú', # LATIN CAPITAL LETTER U WITH ACUTE '\'U' => 'Ú', # LATIN CAPITAL LETTER U WITH ACUTE 'U^' => 'Û', # LATIN CAPITAL LETTER U WITH CIRCUMFLEX '^U' => 'Û', # LATIN CAPITAL LETTER U WITH CIRCUMFLEX 'U"' => 'Ü', # LATIN CAPITAL LETTER U WITH DIAERESIS '"U' => 'Ü', # LATIN CAPITAL LETTER U WITH DIAERESIS 'Y\'' => 'Ý', # LATIN CAPITAL LETTER Y WITH ACUTE '\'Y' => 'Ý', # LATIN CAPITAL LETTER Y WITH ACUTE 'a`' => 'à', # LATIN SMALL LETTER A WITH GRAVE '`a' => 'à', # LATIN SMALL LETTER A WITH GRAVE 'a\'' => 'á', # LATIN SMALL LETTER A WITH ACUTE '\'a' => 'á', # LATIN SMALL LETTER A WITH ACUTE 'a^' => 'â', # LATIN SMALL LETTER A WITH CIRCUMFLEX '^a' => 'â', # LATIN SMALL LETTER A WITH CIRCUMFLEX 'a~' => 'ã', # LATIN SMALL LETTER A WITH TILDE '~a' => 'ã', # LATIN SMALL LETTER A WITH TILDE 'a"' => 'ä', # LATIN SMALL LETTER A WITH DIAERESIS '"a' => 'ä', # LATIN SMALL LETTER A WITH DIAERESIS 'ao' => 'å', # LATIN SMALL LETTER A WITH RING ABOVE 'oa' => 'å', # LATIN SMALL LETTER A WITH RING ABOVE 'ae' => 'æ', # LATIN SMALL LETTER AE 'c,' => 'ç', # LATIN SMALL LETTER C WITH CEDILLA ',c' => 'ç', # LATIN SMALL LETTER C WITH CEDILLA 'e`' => 'è', # LATIN SMALL LETTER E WITH GRAVE '`e' => 'è', # LATIN SMALL LETTER E WITH GRAVE 'e\'' => 'é', # LATIN SMALL LETTER E WITH ACUTE '\'e' => 'é', # LATIN SMALL LETTER E WITH ACUTE 'e^' => 'ê', # LATIN SMALL LETTER E WITH CIRCUMFLEX '^e' => 'ê', # LATIN SMALL LETTER E WITH CIRCUMFLEX 'e"' => 'ë', # LATIN SMALL LETTER E WITH DIAERESIS '"e' => 'ë', # LATIN SMALL LETTER E WITH DIAERESIS 'i`' => 'ì', # LATIN SMALL LETTER I WITH GRAVE '`i' => 'ì', # LATIN SMALL LETTER I WITH GRAVE 'i\'' => 'í', # LATIN SMALL LETTER I WITH ACUTE '\'i' => 'í', # LATIN SMALL LETTER I WITH ACUTE 'i^' => 'î', # LATIN SMALL LETTER I WITH CIRCUMFLEX '^i' => 'î', # LATIN SMALL LETTER I WITH CIRCUMFLEX 'i"' => 'ï', # LATIN SMALL LETTER I WITH DIAERESIS '"i' => 'ï', # LATIN SMALL LETTER I WITH DIAERESIS 'n~' => 'ñ', # LATIN SMALL LETTER N WITH TILDE '~n' => 'ñ', # LATIN SMALL LETTER N WITH TILDE 'o`' => 'ò', # LATIN SMALL LETTER O WITH GRAVE '`o' => 'ò', # LATIN SMALL LETTER O WITH GRAVE 'o\'' => 'ó', # LATIN SMALL LETTER O WITH ACUTE '\'o' => 'ó', # LATIN SMALL LETTER O WITH ACUTE 'o^' => 'ô', # LATIN SMALL LETTER O WITH CIRCUMFLEX '^o' => 'ô', # LATIN SMALL LETTER O WITH CIRCUMFLEX 'o~' => 'õ', # LATIN SMALL LETTER O WITH TILDE '~o' => 'õ', # LATIN SMALL LETTER O WITH TILDE 'o"' => 'ö', # LATIN SMALL LETTER O WITH DIAERESIS '"o' => 'ö', # LATIN SMALL LETTER O WITH DIAERESIS ':-' => '÷', # DIVISION SIGN '-:' => '÷', # DIVISION SIGN 'o/' => 'ø', # LATIN SMALL LETTER O WITH STROKE '/o' => 'ø', # LATIN SMALL LETTER O WITH STROKE 'u`' => 'ù', # LATIN SMALL LETTER U WITH GRAVE '`u' => 'ù', # LATIN SMALL LETTER U WITH GRAVE 'u\'' => 'ú', # LATIN SMALL LETTER U WITH ACUTE '\'u' => 'ú', # LATIN SMALL LETTER U WITH ACUTE 'u^' => 'û', # LATIN SMALL LETTER U WITH CIRCUMFLEX '^u' => 'û', # LATIN SMALL LETTER U WITH CIRCUMFLEX 'u"' => 'ü', # LATIN SMALL LETTER U WITH DIAERESIS '"u' => 'ü', # LATIN SMALL LETTER U WITH DIAERESIS 'y\'' => 'ý', # LATIN SMALL LETTER Y WITH ACUTE '\'y' => 'ý', # LATIN SMALL LETTER Y WITH ACUTE 'y"' => 'ÿ', # LATIN SMALL LETTER Y WITH DIAERESIS '"y' => 'ÿ', # LATIN SMALL LETTER Y WITH DIAERESIS 'OE' => 'Œ', # LATIN CAPITAL LIGATURE OE 'oe' => 'œ', # LATIN SMALL LIGATURE OE '*' => 'ߦ', # BULLET 'Fr' => '₣', # FRENCH FRANC SIGN 'L=' => '₤', # LIRA SIGN '=L' => '₤', # LIRA SIGN 'Rs' => '₨', # RUPEE SIGN 'C=' => '€', # EURO SIGN '=C' => '€', # EURO SIGN 'tm' => '™', # TRADE MARK SIGN '<-' => '←', # LEFTWARDS ARROW '->' => '→', # RIGHTWARDS ARROW '<=' => '⇐', # LEFTWARDS DOUBLE ARROW '=>' => '⇒', # RIGHTWARDS DOUBLE ARROW '=/' => '≠', # NOT EQUAL TO '/=' => '≠', # NOT EQUAL TO '<_' => '≤', # LESS-THAN OR EQUAL TO '_<' => '≤', # LESS-THAN OR EQUAL TO '>_' => '≥', # GREATER-THAN OR EQUAL TO '_>' => '≥', # GREATER-THAN OR EQUAL TO ':(' => '☹', # WHITE FROWNING FACE ':)' => '☺', # WHITE SMILING FACE 'spade' => '♠', # BLACK SPADE SUIT 'club' => '♣', # BLACK CLUB SUIT 'heart' => '♥', # BLACK HEART SUIT 'diamond' => '♦', # BLACK DIAMOND SUIT }; } # "private", internal routines sub _css_defaults { my $self = shift; my %css_defaults = ( class_align_right => 'right', class_align_left => 'left', class_align_center => 'center', class_align_top => 'top', class_align_bottom => 'bottom', class_align_middle => 'middle', class_align_justify => 'justify', class_caps => 'caps', class_footnote => 'footnote', id_footnote_prefix => 'fn', ); return $self->css(\%css_defaults); } sub _halign { my ($align) = @_; if ($align =~ m/<>/) { return 'justify'; } elsif ($align =~ m//) { return 'right'; } elsif ($align =~ m/=/) { return 'center'; } return ''; } sub _valign { my ($align) = @_; if ($align =~ m/\^/) { return 'top'; } elsif ($align =~ m/~/) { return 'bottom'; } elsif ($align =~ m/-/) { return 'middle'; } return ''; } sub _imgalign { my ($align) = @_; $align =~ s/(<>|=)//g; return _valign($align) || _halign($align); } sub _strip_borders { my ($pre, $post) = @_; if (${$post} && ${$pre} && ((my $open = substr(${$pre}, 0, 1)) =~ m/[{[]/)) { my $close = substr(${$post}, 0, 1); if ((($open eq '{') && ($close eq '}')) || (($open eq '[') && ($close eq ']'))) { ${$pre} = substr(${$pre}, 1); ${$post} = substr(${$post}, 1); } else { $close = substr(${$post}, -1, 1) if $close !~ m/[}\]]/; if ((($open eq '{') && ($close eq '}')) || (($open eq '[') && ($close eq ']'))) { ${$pre} = substr(${$pre}, 1); ${$post} = substr(${$post}, 0, length(${$post}) - 1); } } } return; } sub _repl { push @{$_[0]}, $_[1]; return ''; } sub _tokenize { my $str = shift; my $pos = 0; my $len = length $str; my @tokens; my $depth = 6; my $nested_tags = join('|', ('(?:]') x $depth) . (')*>)' x $depth); my $match = qr/(?s: )| # comment (?s: <\? .*? \?> )| # processing instruction (?s: <\% .*? \%> )| # ASP-like (?:$nested_tags)| (?:$codere)/x; # nested tags while ($str =~ m/($match)/g) { my $whole_tag = $1; my $sec_start = pos $str; my $tag_start = $sec_start - length $whole_tag; if ($pos < $tag_start) { push @tokens, ['text', substr($str, $pos, $tag_start - $pos)]; } if ($whole_tag =~ m/^[[{]?\@/) { push @tokens, ['text', $whole_tag]; } else { # this clever hack allows us to preserve \n within tags. # this is restored at the end of the format_paragraph method #$whole_tag =~ s/\n/\r/g; $whole_tag =~ s/\n/\001/g; push @tokens, ['tag', $whole_tag]; } $pos = pos $str; } push @tokens, ['text', substr($str, $pos, $len - $pos)] if $pos < $len; return \@tokens; } 1; __END__ =head1 NAME Text::Textile - A humane web text generator. =head1 SYNOPSIS use Text::Textile qw(textile); my $text = <process($text); print $html; =head1 ABSTRACT Text::Textile is a Perl-based implementation of Dean Allen's Textile syntax. Textile is shorthand for doing common formatting tasks. =head1 METHODS =head2 new( [%options] ) Instantiates a new Text::Textile object. Optional options can be passed to initialize the object. Attributes for the options key are the same as the get/set method names documented here. =head2 set( $attribute, $value ) Used to set Textile attributes. Attribute names are the same as the get/set method names documented here. =head2 get( $attribute ) Used to get Textile attributes. Attribute names are the same as the get/set method names documented here. =head2 disable_html( [$disable] ) Gets or sets the "disable html" control, which allows you to prevent HTML tags from being used within the text processed. Any HTML tags encountered will be removed if disable html is enabled. Default behavior is to allow HTML. =head2 flavor( [$flavor] ) Assigns the HTML flavor of output from Text::Textile. Currently these are the valid choices: html, xhtml (behaves like "xhtml1"), xhtml1, xhtml2. Default flavor is "xhtml1". Note that the xhtml2 flavor support is experimental and incomplete (and will remain that way until the XHTML 2.0 draft becomes a proper recommendation). =head2 css( [$css] ) Gets or sets the CSS support for Textile. If CSS is enabled, Textile will emit CSS rules. You may pass a 1 or 0 to enable or disable CSS behavior altogether. If you pass a hashref, you may assign the CSS class names that are used by Text::Textile. The following key names for such a hash are recognized: =over =item class_align_right defaults to "right" =item class_align_left defaults to "left" =item class_align_center defaults to "center" =item class_align_top defaults to "top" =item class_align_bottom defaults to "bottom" =item class_align_middle defaults to "middle" =item class_align_justify defaults to "justify" =item class_caps defaults to "caps" =item class_footnote defaults to "footnote" =item id_footnote_prefix defaults to "fn" =back =head2 charset( [$charset] ) Gets or sets the character set targetted for publication. At this time, Text::Textile only changes its behavior if the "utf-8" character set is assigned. Specifically, if utf-8 is requested, any special characters created by Textile will be output as native utf-8 characters rather than HTML entities. =head2 docroot( [$path] ) Gets or sets the physical file path to root of document files. This path is utilized when images are referenced and size calculations are needed (the Image::Size module is used to read the image dimensions). =head2 trim_spaces( [$trim] ) Gets or sets the "trim spaces" control flag. If enabled, this will clear any lines that have only spaces on them (the newline itself will remain). =head2 preserve_spaces( [$preserve] ) Gets or sets the "preserve spaces" control flag. If enabled, this will replace any double spaces within the paragraph data with the   HTML entity (wide space). The default is 0. Spaces will pass through to the browser unchanged and render as a single space. Note that this setting has no effect on spaces within C<< 
 >>,
C<<  >> or C<<