Almost-minimal filesystem based blog.
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.

218 lines
5.6 KiB

  1. package Display::Markup;
  2. use base qw(Exporter);
  3. our @EXPORT_OK = qw(line_parse);
  4. use Display::Image qw(image_size);
  5. use Text::Textile;
  6. # some useful defaults.
  7. my %tags = ( retcon => q{div class="retcon"},
  8. freeverse => 'p',
  9. list => "ul>\n<li" );
  10. my %end_tags = ( retcon => 'div',
  11. freeverse => 'p',
  12. list => "li>\n</ul" );
  13. my %blank_lines = ( freeverse => "</p>\n\n<p>",
  14. list => "</li>\n\n<li>" );
  15. my %newlines = ( freeverse => "<br />\n" );
  16. my %dashes = ( freeverse => ' &mdash; ' );
  17. =item line_parse
  18. Performs substitutions on lines called by fragment_slurp, at least. Calls
  19. image_markup, Text::Textile, Wala::wiki_page_to_html, eval_perl. Returns
  20. string.
  21. Parses some special markup, specifically:
  22. <perl>embedded perl</perl>
  23. ${variable} interpolation from %DISPLAY_CONF
  24. <textile></textile> - Text::Textile to HTML
  25. <wala></wala> - Wala::wikify();
  26. <freeverse></freeverse>
  27. <retcon></retcon>
  28. <list></list>
  29. <image>filename.ext
  30. optional alt tag</image>
  31. =cut
  32. sub line_parse {
  33. my ($everything, $file) = (@_);
  34. # take care of wala markup
  35. $everything =~ s/<wala>(.*?)<\/wala>/Wala::wikify($1)/seg;
  36. # take care of textile markup, if we've got any
  37. textile_process($everything);
  38. # evaluate <image> tags.
  39. $everything =~ s!<image>(.*?)</image>!image_markup($file, $1)!seg;
  40. foreach my $key (keys %tags) {
  41. # Set some replacements, unless they've been explicitly set already.
  42. $end_tags{$key} = $tags{$key} unless $end_tags{$key};
  43. $blank_lines{$key} = "\n\n" unless $blank_lines{$key};
  44. $newlines{$key} = "\n" unless $newlines{$key};
  45. $dashes{$key} = " -- " unless $dashes{$key};
  46. while ($everything =~ m/(<$key>.*?<\/$key>)/s) {
  47. my $block = $1;
  48. # save the bits between instances of the block --
  49. my (@interstice_array) = split /\Q$block\E/s, $everything;
  50. # now, transform the contents of the block we've found:
  51. # tags that surround the block
  52. $block =~ s/\n?<$key>\n?/<$tags{$key}>/gs;
  53. $block =~ s!\n?</$key>\n?!</$end_tags{$key}>!gs;
  54. # dashes
  55. $block = dashes($dashes{$key}, $block);
  56. # blank lines within the block
  57. $block =~ s/\n\n/$blank_lines{$key}/gs;
  58. $block = newlines($newlines{$key}, $block);
  59. # and slap it all back together as $everything
  60. $everything = join $block, @interstice_array;
  61. }
  62. }
  63. return $everything;
  64. }
  65. sub newlines {
  66. my ($replacement, $block) = @_;
  67. # single newlines (i.e., line ends) within the block
  68. # except those preceded by a double-quote, which probably
  69. # indicates a still-open tag:
  70. $block =~ s/(?<=[^"\n]) # not a double-quote or newline
  71. # don't capture
  72. \n # end-of-line
  73. (?=[^\n]) # not a newline
  74. # don't capture
  75. /$replacement/xgs;
  76. return $block;
  77. }
  78. # might need a rewrite.
  79. sub dashes {
  80. my ($replacement, $block) =@_;
  81. $block =~ s/(\s+) # whitespace - no capture
  82. \-{2} # two dashes
  83. (\n|\s+|$) # newline, whitespace, or eol
  84. /$1${replacement}$2/xgs;
  85. return $block;
  86. }
  87. =item textile_process
  88. Inline replace <textile> markup in a string.
  89. Trying to implement some caching here, though it's questionable whether
  90. this makes any sense. There's also a closure which should retain the
  91. Text::Textile object between invocations, potentially saving some time at
  92. the expense of a little memory.
  93. =cut
  94. { my %cache;
  95. my $textile;
  96. sub textile_process {
  97. my $replacement;
  98. unless (defined $textile) {
  99. # head_offset: use h1., h2. in Textile formatting:
  100. $textile = Text::Textile->new( head_offset => 2 );
  101. }
  102. while ( $_[0] =~ m/<textile>(.*?)<\/textile>/sx ) {
  103. my $block = $1;
  104. if (exists $cache{$block}) {
  105. $replacement = $cache{$block};
  106. } else {
  107. $replacement = $textile->process($block);
  108. $cache{$block} = $replacement;
  109. }
  110. $_[0] =~ s/<textile>\Q$block\E<\/textile>/$replacement/sg;
  111. }
  112. return;
  113. }
  114. }
  115. =item image markup
  116. Parse out an image tag and return the appropriate html.
  117. Relies on image_size from Display::Image.
  118. =cut
  119. sub image_markup {
  120. my ($file, $block) = @_;
  121. my %DISPLAY_CONF = %Display::DISPLAY_CONF;
  122. # get a directory for the file we're working with
  123. $file =~ s'[^/]* # everything not a /
  124. $ # up to end of string
  125. ''x;
  126. # truncated file date that just includes date + sub docs
  127. my ($file_date) = $file =~ m{([0-9]{4}/ # year
  128. [0-9]{1,2}/ # month
  129. [0-9]{1,2}/ # day
  130. ([a-z]*/)*)$ # sub-entries
  131. }x;
  132. my ($image_name, $alt_text, $title_text) = split /\n/, $block;
  133. $title_text = $alt_text unless $title_text;
  134. my $image_file;
  135. if (-e "$file/$image_name" ) {
  136. $image_file = "$file/$image_name";
  137. $image_name = "${file_date}${image_name}";
  138. } elsif (-e "$DISPLAY_CONF{ROOT_DIR}/$image_name") {
  139. $image_file = "$DISPLAY_CONF{ROOT_DIR}/$image_name";
  140. }
  141. # get width & height in pixels for known filetypes
  142. my ($width, $height) = image_size($image_file);
  143. # this relies on mod_rewrite working:
  144. return<<"IMG";
  145. <img src="$DISPLAY_CONF{IMAGE_URL_ROOT}$image_name"
  146. height="$height"
  147. width="$width"
  148. alt="$alt_text"
  149. title="$title_text" />
  150. IMG
  151. }
  152. 1;