Text-Textile-2.12/ 0000755 0000765 0000024 00000000000 11237341070 012567 5 ustar brad staff Text-Textile-2.12/ARTISTIC 0000644 0000765 0000024 00000013737 11237336750 013760 0 ustar brad staff
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.12/Changes 0000644 0000765 0000024 00000004062 11237340775 014077 0 ustar brad staff 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.12/lib/ 0000755 0000765 0000024 00000000000 11237341070 013335 5 ustar brad staff Text-Textile-2.12/lib/Text/ 0000755 0000765 0000024 00000000000 11237341070 014261 5 ustar brad staff Text-Textile-2.12/lib/Text/Textile.pm 0000644 0000765 0000024 00000326533 11237340775 016264 0 ustar brad staff package Text::Textile;
use strict;
use warnings;
use base 'Exporter';
our @EXPORT_OK = qw(textile);
our $VERSION = 2.12;
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;
}
# 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*) # 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!"!"!g;
$text =~ s!&(([a-z]+|#\d+);)!&$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/(?'"])|([{[])) # "' $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;
# 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;
}
}
{
# 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 eq '*';
$h = '' if $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<<