You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
394 lines
9.5 KiB
394 lines
9.5 KiB
package App::WRT::Markup;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use feature "state";
|
|
|
|
use base qw(Exporter);
|
|
our @EXPORT_OK = qw(line_parse image_markup eval_perl);
|
|
|
|
use App::WRT::Image qw(image_size);
|
|
use App::WRT::Util qw(file_get_contents);
|
|
|
|
use Carp;
|
|
use File::Basename;
|
|
use Text::Textile;
|
|
use Text::Markdown::Discount;
|
|
|
|
# Some useful defaults:
|
|
|
|
my %tags = (
|
|
retcon => q{div class="retcon"},
|
|
freeverse => 'p',
|
|
list => "ul>\n<li"
|
|
);
|
|
|
|
my %end_tags = (
|
|
retcon => 'div',
|
|
freeverse => 'p',
|
|
list => "li>\n</ul"
|
|
);
|
|
|
|
my %blank_lines = (
|
|
freeverse => "</p>\n\n<p>",
|
|
list => "</li>\n\n<li>"
|
|
);
|
|
|
|
my %newlines = (
|
|
freeverse => "<br />\n"
|
|
);
|
|
|
|
my %dashes = (
|
|
freeverse => ' — '
|
|
);
|
|
|
|
=over
|
|
|
|
=item eval_perl
|
|
|
|
Evaluate embedded Perl in a string, replacing blocks enclosed with <perl> tags
|
|
with whatever they return (well, evaluated in a scalar context). Returns the
|
|
modified string.
|
|
|
|
Also handles simple ${variables}, replacing them from the keys to $self.
|
|
|
|
=cut
|
|
|
|
sub eval_perl {
|
|
my $self = shift;
|
|
my ($text) = @_;
|
|
|
|
while ($text =~ m{<perl>(.*?)</perl>}s) {
|
|
my $block = $1;
|
|
|
|
# Run the $block, and include anything returned:
|
|
my $output = eval $block;
|
|
|
|
if ($@) {
|
|
# Errors - log and return an empty string:
|
|
carp($@);
|
|
$output = '';
|
|
}
|
|
|
|
$text =~ s{<perl>\Q$block\E</perl>}{$output}s;
|
|
}
|
|
|
|
# Interpolate variables:
|
|
$text =~ s{
|
|
\$\{ ([a-zA-Z_]+) \}
|
|
}{
|
|
if (defined $self->{$1}) {
|
|
$self->{$1};
|
|
} else {
|
|
# TODO: Possibly this should be fatal.
|
|
"UNDEFINED: $1";
|
|
}
|
|
}gex;
|
|
|
|
return $text;
|
|
}
|
|
|
|
=item line_parse
|
|
|
|
Performs substitutions on lines called by fragment_slurp, at least. Calls
|
|
include_process(), image_markup(), textile_process(), markdown_process(),
|
|
eval_perl().
|
|
|
|
Applies before-parsing and after-parsing filters.
|
|
|
|
Returns string.
|
|
|
|
Parses some special markup. Specifically:
|
|
|
|
<perl>print "hello world";</perl>
|
|
${variable} interpolation from the WRT object
|
|
|
|
<include>path/to/file/from/project/root</include>
|
|
|
|
<textile></textile> - Text::Textile to HTML
|
|
<markdown></markdown> - Text::Markdown::Discount to HTML
|
|
|
|
<image>filename.ext
|
|
optional alt tag
|
|
optional title text</image>
|
|
|
|
<freeverse></freeverse>
|
|
<retcon></retcon>
|
|
<list></list>
|
|
|
|
=cut
|
|
|
|
sub line_parse {
|
|
my $self = shift;
|
|
my ($everything, $file) = (@_);
|
|
|
|
# Eventually, this should probably only happen for templates:
|
|
$everything = $self->eval_perl($everything);
|
|
|
|
# Take care of <include>, <textile>, <markdown>, and <image> tags:
|
|
include_process($self, $everything);
|
|
textile_process($everything);
|
|
markdown_process($everything);
|
|
$everything =~ s!<image>(.*?)</image>!$self->image_markup($file, $1)!seg;
|
|
|
|
foreach my $key (keys %tags) {
|
|
# Set some replacements, unless they've been explicitly set already:
|
|
$end_tags{$key} ||= $tags{$key};
|
|
|
|
# Transform blocks:
|
|
while ($everything =~ m| (<$key>\n?) (.*?) (\n?</$key>) |sx) {
|
|
my $open = $1;
|
|
my $block = $2;
|
|
my $close = $3;
|
|
|
|
# Save the bits between instances of the block:
|
|
my (@interstices) = split /\Q$open$block$close\E/s, $everything;
|
|
|
|
# Transform dashes, blank lines, and newlines:
|
|
dashes($dashes{$key}, $block) if defined $dashes{$key};
|
|
$block =~ s/\n\n/$blank_lines{$key}/gs if defined $blank_lines{$key};
|
|
newlines($newlines{$key}, $block) if defined $newlines{$key};
|
|
|
|
# Slap it all back together as $everything, with start and end
|
|
# tags:
|
|
$block = "<$tags{$key}>$block</$end_tags{$key}>";
|
|
$everything = join $block, @interstices;
|
|
}
|
|
}
|
|
|
|
return $everything;
|
|
}
|
|
|
|
=item newlines($replacement, $block)
|
|
|
|
Inline replace single newlines (i.e., line ends) within the block, except those
|
|
preceded by a double-quote, which probably indicates a still-open tag.
|
|
|
|
=cut
|
|
|
|
sub newlines {
|
|
$_[1] =~ s/(?<=[^"\n]) # not a double-quote or newline
|
|
# don't capture
|
|
|
|
\n # end-of-line
|
|
|
|
(?=[^\n]) # not a newline
|
|
# don't capture
|
|
/$_[0]/xgs;
|
|
}
|
|
|
|
=item dashes($replacement, $block)
|
|
|
|
Inline replace double dashes in a block - " -- " - with a given replacement.
|
|
|
|
=cut
|
|
|
|
sub dashes {
|
|
$_[1] =~ s/(\s+) # whitespace - no capture
|
|
\-{2} # two dashes
|
|
(\n|\s+|$) # newline, whitespace, or eol
|
|
/$1$_[0]$2/xgs;
|
|
|
|
}
|
|
|
|
=item include_process
|
|
|
|
Inline replace <include>filename</include> tags, replacing them with the
|
|
contents of files.
|
|
|
|
=cut
|
|
|
|
sub include_process {
|
|
my $wrt = shift;
|
|
|
|
$_[0] =~ s{
|
|
|
|
<include> # start tag
|
|
(.*?) # anything (non-greedy)
|
|
</include> # end tag
|
|
|
|
}{
|
|
retrieve_include($wrt, $1);
|
|
}xesg;
|
|
}
|
|
|
|
=item retrieve_include
|
|
|
|
Get the contents of an included file. This probably needs a great
|
|
deal more thought than I am presently giving it.
|
|
|
|
=cut
|
|
|
|
sub retrieve_include {
|
|
my $wrt = shift;
|
|
my ($file) = @_;
|
|
|
|
# Trim leading and trailing spaces:
|
|
$file =~ s/^\s+//;
|
|
$file =~ s/\s+$//;
|
|
|
|
if ($file =~ m{^ (/ | [.]/) }x) {
|
|
# TODO: Leads with a slash or a ./
|
|
croak('Tried to open an include path with a leading / or ./ - not yet supported.');
|
|
} else {
|
|
# Use the archive root as path.
|
|
$file = $wrt->{root_dir} . '/' . $file;
|
|
}
|
|
|
|
if ($wrt->{cache_includes}) {
|
|
if (defined $wrt->{include_cache}->{$file}) {
|
|
return $wrt->{include_cache}->{$file};
|
|
}
|
|
}
|
|
|
|
unless (-e $file) {
|
|
carp "No such file: $file";
|
|
return '';
|
|
}
|
|
|
|
if (-d $file) {
|
|
carp("Tried to open a directory as an include path: $file");
|
|
return '';
|
|
}
|
|
|
|
if ($wrt->{cache_includes}) {
|
|
$wrt->{include_cache}->{$file} = file_get_contents($file);
|
|
return $wrt->{include_cache}->{$file};
|
|
} else {
|
|
return file_get_contents($file);
|
|
}
|
|
}
|
|
|
|
=item textile_process
|
|
|
|
Inline replace <textile> markup in a string.
|
|
|
|
=cut
|
|
|
|
# This is exactly the kind of code that, even though it isn't doing anything
|
|
# especially over the top, looks ghastly to people who don't read Perl, so I'll
|
|
# try to explain a bit.
|
|
|
|
sub textile_process {
|
|
|
|
# First, there's a state variable here which can retain the Text::Textile
|
|
# object between invocations of the function, saving us a bit of time on
|
|
# subsequent calls. This should be equivalent to creating a closure around
|
|
# the function and keeping a $textile variable there.
|
|
state $textile;
|
|
|
|
# Second, instead of unrolling the arguments to the function, we just act
|
|
# directly on the first (0th) one. =~ more or less means "do a regexy
|
|
# thing on this". It's followed by s, the substitution operator, which can
|
|
# use curly braces as delimiters between pattern and replacement.
|
|
|
|
$_[0] =~ s{
|
|
|
|
# Find tags...
|
|
|
|
<textile> # start tag
|
|
(.*?) # anything (non-greedy)
|
|
</textile> # end tag
|
|
|
|
}{
|
|
|
|
# ...and replace them with the result of evaluating this block.
|
|
|
|
# //= means "defined-or-equals"; if the var hasn't been defined yet,
|
|
# then make a new Textile object:
|
|
$textile //= Text::Textile->new();
|
|
|
|
# Process the stuff we slurped out of our tags - this value will be
|
|
# used to replace the entire match from above (in Perl, the last
|
|
# expression evaluated is the return value of subs, evals, etc.):
|
|
$textile->process($1);
|
|
|
|
}xesg;
|
|
|
|
# x: eXtended regexp - whitespace ignored by default, comments allowed
|
|
# e: Execute the replacement as Perl code, and use its value
|
|
# s: treat all lines of the search subject as a Single string
|
|
# g: Globally replace all matches
|
|
|
|
# For the genuinely concise version of this, see markdown_process().
|
|
}
|
|
|
|
=item markdown_process
|
|
|
|
Inline replace <markdown> markup in a string.
|
|
|
|
=cut
|
|
|
|
sub markdown_process {
|
|
state $markdown;
|
|
|
|
my $flags = Text::Markdown::Discount::MKD_EXTRA_FOOTNOTE();
|
|
|
|
$_[0] =~ s{
|
|
<markdown>(.*?)</markdown>
|
|
}{
|
|
$markdown //= Text::Markdown::Discount->new;
|
|
$markdown->markdown($1, $flags);
|
|
}xesg;
|
|
}
|
|
|
|
=item image_markup
|
|
|
|
Parse out an image tag and return the appropriate html.
|
|
|
|
Relies on image_size from App::WRT::Image.
|
|
|
|
=cut
|
|
|
|
sub image_markup {
|
|
my $self = shift;
|
|
my ($file, $block) = @_;
|
|
|
|
# Get a basename and directory for the file (entry) referencing the image:
|
|
my ($basename, $dir) = fileparse($file);
|
|
|
|
# Truncated file date that just includes date + sub docs:
|
|
my ($file_date) = $dir =~ m{
|
|
(
|
|
[0-9]{4}/ # year
|
|
[0-9]{1,2}/ # month
|
|
[0-9]{1,2}/ # day
|
|
([a-z]*/)* # sub-entries
|
|
)
|
|
$
|
|
}x;
|
|
|
|
# Process the contents of the <image> tag:
|
|
my ($image_url, $alt_text, $title_text) = split /\n/, $block;
|
|
$alt_text ||= q{};
|
|
$title_text ||= $alt_text;
|
|
|
|
# Resolve relative paths:
|
|
my $image_file;
|
|
if (-e "$dir/$image_url" ) {
|
|
# The path is to an image file in the same directory as current entry:
|
|
$image_file = "$dir/$image_url";
|
|
$image_url = "${file_date}${image_url}";
|
|
} elsif (-e $self->{entry_dir} . "/$image_url") {
|
|
# The path is to an image file starting with the entry_dir, like
|
|
# 2005/9/20/candles.jpg -> ./archives/2005/9/20/candles.jpg
|
|
$image_file = $self->{entry_dir} . "/$image_url";
|
|
}
|
|
|
|
# Get width & height in pixels for known filetypes:
|
|
my ($width, $height) = image_size($self->{root_dir_abs} . '/' . $image_file);
|
|
|
|
# This probably relies on mod_rewrite working:
|
|
$image_url = $self->{image_url_root} . $image_url;
|
|
return <<"IMG";
|
|
<img src="$image_url"
|
|
width="$width"
|
|
height="$height"
|
|
alt="$alt_text"
|
|
title="$title_text" />
|
|
IMG
|
|
}
|
|
|
|
=back
|
|
|
|
1;
|