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.
251 lines
5.9 KiB
251 lines
5.9 KiB
package Display::Markup;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use base qw(Exporter);
|
|
our @EXPORT_OK = qw(line_parse image_markup gallery);
|
|
|
|
use File::Basename;
|
|
use Display::Image qw(image_size gallery);
|
|
use Text::Textile;
|
|
|
|
# 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 => ' — '
|
|
);
|
|
|
|
=item line_parse
|
|
|
|
Performs substitutions on lines called by fragment_slurp, at least. Calls
|
|
image_markup, Text::Textile, Wala::wiki_page_to_html, eval_perl. Returns
|
|
string.
|
|
|
|
Parses some special markup, specifically:
|
|
|
|
<perl>embedded perl</perl>
|
|
${variable} interpolation from %DISPLAY_CONF
|
|
<textile></textile> - Text::Textile to HTML
|
|
<wala></wala> - Wala::wikify();
|
|
<freeverse></freeverse>
|
|
<retcon></retcon>
|
|
<list></list>
|
|
|
|
<gallery>directory_name</gallery>
|
|
|
|
<image>filename.ext
|
|
optional alt tag</image>
|
|
|
|
=cut
|
|
|
|
sub line_parse {
|
|
my $self = shift;
|
|
my ($everything, $file) = (@_);
|
|
|
|
# Take care of <wala>, <textile>, <gallery>, and <image> tags:
|
|
|
|
#$everything =~ s/<wala>(.*?)<\/wala>/Wala::wikify($1)/seg;
|
|
textile_process($everything);
|
|
$everything =~ s!<gallery>(.*?)</gallery>!$self->gallery_markup($file, $1)!seg;
|
|
$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};
|
|
$blank_lines{$key} ||= "\n\n";
|
|
$newlines{$key} ||= "\n";
|
|
$dashes{$key} ||= " -- ";
|
|
|
|
# Transform blocks:
|
|
while ($everything =~ m/(<$key>.*?<\/$key>)/s) {
|
|
my $block = $1;
|
|
|
|
# Save the bits between instances of the block:
|
|
my (@interstices) = split /\Q$block\E/s, $everything;
|
|
|
|
# Tags that surround the block:
|
|
$block =~ s{\n?<$key>\n?}{<$tags{$key}>}gs;
|
|
$block =~ s{\n?</$key>\n?}{</$end_tags{$key}>}gs;
|
|
|
|
# Dashes, blank lines, and newlines:
|
|
$block = dashes($dashes{$key}, $block);
|
|
$block =~ s/\n\n/$blank_lines{$key}/gs;
|
|
$block = newlines($newlines{$key}, $block);
|
|
|
|
# ...and slap it all back together as $everything
|
|
$everything = join $block, @interstices;
|
|
}
|
|
}
|
|
|
|
return $everything;
|
|
}
|
|
|
|
sub newlines {
|
|
my ($replacement, $block) = @_;
|
|
|
|
# Single newlines (i.e., line ends) within the block,
|
|
# except those preceded by a double-quote, which probably
|
|
# indicates a still-open tag:
|
|
|
|
$block =~ s/(?<=[^"\n]) # not a double-quote or newline
|
|
# don't capture
|
|
|
|
\n # end-of-line
|
|
|
|
(?=[^\n]) # not a newline
|
|
# don't capture
|
|
/$replacement/xgs;
|
|
|
|
return $block;
|
|
|
|
}
|
|
|
|
# might need a rewrite.
|
|
sub dashes {
|
|
my ($replacement, $block) =@_;
|
|
|
|
$block =~ s/(\s+) # whitespace - no capture
|
|
\-{2} # two dashes
|
|
(\n|\s+|$) # newline, whitespace, or eol
|
|
/$1${replacement}$2/xgs;
|
|
|
|
return $block;
|
|
|
|
}
|
|
|
|
=item textile_process
|
|
|
|
Inline replace <textile> markup in a string.
|
|
|
|
Trying to implement some caching here, though it's questionable whether
|
|
this makes any sense. There's also a closure which should retain the
|
|
Text::Textile object between invocations, potentially saving some time at
|
|
the expense of a little memory.
|
|
|
|
=cut
|
|
|
|
{ my %cache;
|
|
my $textile;
|
|
|
|
sub textile_process {
|
|
my $replacement;
|
|
|
|
unless (defined $textile) {
|
|
# head_offset: use h1., h2. in Textile formatting:
|
|
$textile = Text::Textile->new( head_offset => 2 );
|
|
}
|
|
|
|
while ( $_[0] =~ m/<textile>(.*?)<\/textile>/sx ) {
|
|
my $block = $1;
|
|
|
|
if (exists $cache{$block}) {
|
|
$replacement = $cache{$block};
|
|
} else {
|
|
$replacement = $textile->process($block);
|
|
$cache{$block} = $replacement;
|
|
}
|
|
|
|
$_[0] =~ s/<textile>\Q$block\E<\/textile>/$replacement/sg;
|
|
}
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
=item image_markup
|
|
|
|
Parse out an image tag and return the appropriate html.
|
|
|
|
Relies on image_size from Display::Image.
|
|
|
|
=cut
|
|
|
|
sub image_markup {
|
|
my $self = shift;
|
|
my ($file, $block) = @_;
|
|
|
|
# Get a basename and directory for the file 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" ) {
|
|
$image_file = "$dir/$image_url";
|
|
$image_url = "${file_date}${image_url}";
|
|
} elsif (-e $self->root_dir . "/$image_url") {
|
|
$image_file = $self->root_dir . "/$image_url";
|
|
}
|
|
|
|
# Get width & height in pixels for known filetypes:
|
|
my ($width, $height) = image_size($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
|
|
}
|
|
|
|
=item gallery_markup
|
|
|
|
Generate a gallery of images.
|
|
|
|
=cut
|
|
|
|
sub gallery_markup {
|
|
my $self = shift;
|
|
my ($file, $block) = @_;
|
|
|
|
my ($dir, $basedir) = fileparse($file);
|
|
|
|
if (-d "$basedir/$file") {
|
|
return gallery("$basedir/$file", "");
|
|
}
|
|
}
|
|
|
|
# Encapsulate some ugly file-location functionality.
|
|
sub resolve_file {
|
|
}
|
|
|
|
1;
|