File Coverage

blib/lib/Text/WikiCreole.pm

Criterion	Covered	Total	%
statement	93	128	72.6
branch	37	66	56.0
condition	8	15	53.3
subroutine	12	20	60.0
pod	9	14	64.2
total	159	243	65.4

package Text::WikiCreole;
require Exporter;
@ISA = (Exporter);
@EXPORT = qw(creole_parse creole_plugin creole_tag creole_img creole_customimgs
             creole_link creole_barelink creole_customlinks creole_custombarelinks);
use vars qw($VERSION);
use strict;
use warnings;

our $VERSION = "0.07";

sub  strip_head_eq { # strip lead/trail white/= from headings
  $_[0] =~ s/^\s*=*\s*//o;
  $_[0] =~ s/\s*=*\s*$//o;
  return $_[0];
}

sub strip_list {  # strip list markup trickery
  $_[0] =~ s/(?:`*| *)[\*\#]/`/o;
  $_[0] =~ s/\n(?:`*| *)[\*\#]/\n`/gso;
  return $_[0];
}

# characters that may indicate inline wiki markup
my @specialchars = ('^', '\\', '*', '/', '_', ',', '{', '[',
                    '<', '~', '|', "\n", '#', ':', ';', '(', '-', '.');
# plain characters - auto-generated below (ascii printable minus @specialchars)
my @plainchars;

# non-plain text inline widgets
my @inline = ('strong', 'em', 'br',  'esc', 'img', 'link', 'ilink',
              'inowiki', 'sub', 'sup', 'mono', 'u', 'plug', 'plug2', 'tm',
              'reg', 'copy', 'ndash', 'ellipsis', 'amp');
my @all_inline = (@inline, 'plain', 'any'); # including plain text

# blocks
my @blocks = ('h1', 'h2', 'h3', 'hr', 'nowiki', 'h4', 'h5', 'h6',
              'ul', 'ol', 'table', 'p', 'ip', 'dl', 'plug', 'plug2', 'blank');

# handy - used several times in %chunks
my $eol = '(?:\n|$)'; # end of line (or string)
my $bol = '(?:^|\n)'; # beginning of line (or string)

# user-supplied plugin parser function
my $plugin_function;
# user-supplied link URL parser function
my $link_function;
# user-supplied bare link parser function
my $barelink_function;
# user-supplied image URL parser function
my $img_function;

# initialize once
my $initialized = 0;

my %chunks = (
  top => {
     contains => \@blocks,
  },
  blank => {
    curpat => "(?= *$eol)",
    fwpat => "(?=(?:^|\n) *$eol)",
    stops => '(?=\S)',
    hint => ["\n"],
    filter => sub { return ""; }, # whitespace into the bit bucket
    open => "", close => "",
  },
  p => {
    curpat => '(?=.)',
    stops => ['blank', 'ip', 'h', 'hr', 'nowiki', 'ul', 'ol', 'dl', 'table'],
    hint => \@plainchars,
    contains => \@all_inline,
    filter => sub { chomp $_[0]; return $_[0]; },
    open => "", close => "\n\n",
  },
  ip => {
    curpat => '(?=:)',
    fwpat => '\n(?=:)',
    stops => ['blank', 'h', 'hr', 'nowiki', 'ul', 'ol', 'dl', 'table'],
    hint => [':'],
    contains => ['p', 'ip'],
    filter => sub {
      $_[0] =~ s/://o;
      $_[0] =~ s/\n:/\n/so;
      return $_[0];
    },
    open => "", close => "\n",
  },
  dl => {
    curpat => '(?=;)',
    fwpat => '\n(?=;)',
    stops => ['blank', 'h', 'hr', 'nowiki', 'ul', 'ol', 'table'],
    hint => [';'],
    contains => ['dt', 'dd'],
    open => "\n", close => "\n",
  },
  dt => {
    curpat => '(?=;)',
    fwpat => '\n(?=;)',
    stops => '(?=:|\n)',
    hint => [';'],
    contains => \@all_inline,
    filter => sub { $_[0] =~ s/^;\s*//o; return $_[0]; },
    open => "  ", close => "\n",
  },
  dd => {
    curpat => '(?=\n|:)',
    fwpat => '(?:\n|:)',
    stops => '(?=:)|\n(?=;)',
    hint => [':', "\n"],
    contains => \@all_inline,
    filter => sub {
      $_[0] =~ s/(?:\n|:)\s*//so;
      $_[0] =~ s/\s*$//so;
      return $_[0];
    },
    open => "    ", close => "\n",
  },
  table => {
    curpat => '(?= *\|.)',
    fwpat => '\n(?= *\|.)',
    stops => '\n(?= *[^\|])',
    contains => ['tr'],
    hint => ['|', ' '],
    open => "\n", close => "\n\n",
  },
  tr => {
    curpat => '(?= *\|)',
    stops => '\n',
    contains => ['td', 'th'],
    hint => ['|', ' '],
    filter => sub { $_[0] =~ s/^ *//o; $_[0] =~ s/\| *$//o; return $_[0]; },
    open => "
  },
  td => {
    curpat => '(?=\|[^=])',
    # this gnarly regex fixes ambiguous '|' for links/imgs/nowiki in tables
    stops => '[^~](?=\|(?!(?:[^\[]*\]\])|(?:[^\{]*\}\})))',
    contains => \@all_inline,
    hint => ['|'],
    filter => sub {$_[0] =~ s/^ *\| *//o; $_[0] =~ s/\s*$//so; return $_[0]; },
    open => "
  },
  th => {
    curpat => '(?=\|=)',
    # this gnarly regex fixes ambiguous '|' for links/imgs/nowiki in tables
    stops => '[^~](?=\|(?!(?:[^\[]*\]\])|(?:[^\{]*\}\})))',
    contains => \@all_inline,
    hint => ['|'],
    filter => sub {$_[0] =~ s/^ *\|= *//o; $_[0] =~ s/\s*$//so; return $_[0]; },
    open => "
  },
  ul => {
    curpat => '(?=(?:`| *)\*[^\*])',
    fwpat => '(?=\n(?:`| *)\*[^\*])',
    stops => ['blank', 'ip', 'h', 'nowiki', 'li', 'table', 'hr', 'dl'],
    contains => ['ul', 'ol', 'li'],
    hint => ['*', ' '],
    filter => \&strip_list,
    open => "\n", close => "\n",
  },
  ol => {
    curpat => '(?=(?:`| *)\#[^\#])',
    fwpat => '(?=\n(?:`| *)\#[^\#])',
    stops => ['blank', 'ip', 'h', 'nowiki', 'li', 'table', 'hr', 'dl'],
    contains => ['ul', 'ol', 'li'],
    hint => ['#', ' '],
    filter => \&strip_list,
    open => "\n", close => "\n",
  },
  li => {
    curpat => '(?=`[^\*\#])',
    fwpat => '\n(?=`[^\*\#])',
    stops => '\n(?=`)',
    hint => ['`'],
    filter => sub {
      $_[0] =~ s/` *//o;
      chomp $_[0];
      return $_[0];
    },
    contains => \@all_inline,
    open => "    ", close => "\n",
  },
  nowiki => {
    curpat => '(?=\{\{\{ *\n)',
    fwpat => '\n(?=\{\{\{ *\n)',
    stops => "\n\}\}\} *$eol",
    hint => ['{'],
    filter => sub {
      substr($_[0], 0, 3, '');
      $_[0] =~ s/\}\}\}\s*$//o;
      $_[0] =~ s/&/&/go;
      $_[0] =~ s/
      $_[0] =~ s/>/>/go;
      return $_[0];
    },
    open => "", close => "\n\n",
  },
  hr => {
    curpat => "(?= *-{4,} *$eol)",
    fwpat => "\n(?= *-{4,} *$eol)",
    hint => ['-', ' '],
    stops => $eol,
    open => "\n\n", close => "",
    filter => sub { return ""; } # ----- into the bit bucket
  },
  h => { curpat => '(?=(?:^|\n) *=)' }, # matches any heading
  h1 => {
    curpat => '(?= *=[^=])',
    hint => ['=', ' '],
    stops => '\n',
    contains => \@all_inline,
    open => "", close => "\n\n",
    filter => \&strip_head_eq,
  },
  h2 => {
    curpat => '(?= *={2}[^=])',
    hint => ['=', ' '],
    stops => '\n',
    contains => \@all_inline,
    open => "", close => "\n\n",
    filter => \&strip_head_eq,
  },
  h3 => {
    curpat => '(?= *={3}[^=])',
    hint => ['=', ' '],
    stops => '\n',
    contains => \@all_inline,
    open => "", close => "\n\n",
    filter => \&strip_head_eq,
  },
  h4 => {
    curpat => '(?= *={4}[^=])',
    hint => ['=', ' '],
    stops => '\n',
    contains => \@all_inline,
    open => "", close => "\n\n",
    filter => \&strip_head_eq,
  },
  h5 => {
    curpat => '(?= *={5}[^=])',
    hint => ['=', ' '],
    stops => '\n',
    contains => \@all_inline,
    open => "", close => "\n\n",
    filter => \&strip_head_eq,
  },
  h6 => {
    curpat => '(?= *={6,})',
    hint => ['=', ' '],
    stops => '\n',
    contains => \@all_inline,
    open => "", close => "\n\n",
    filter => \&strip_head_eq,
  },
  plain => {
    curpat => '(?=[^\*\/_\,\^\\\\{\[\<\|])',
    stops => \@inline,
    hint => \@plainchars,
    open => '', close => ''
  },
  any => { # catch-all
    curpat => '(?=.)',
    stops => \@inline,
    open => '', close => ''
  },
  br => {
    curpat => '(?=\\\\\\\\)',
    stops => '\\\\\\\\',
    hint => ['\\'],
    filter => sub { return ''; },
    open => '', close => '',
  },
  esc => {
    curpat => '(?=~[\S])',
    stops => '~.',
    hint => ['~'],
    filter => sub { substr($_[0], 0, 1, ''); return $_[0]; },
    open => '', close => '',
  },
  inowiki => {
    curpat => '(?=\{{3}.*?\}*\}{3})',
    stops => '.*?\}*\}{3}',
    hint => ['{'],
    filter => sub {
      substr($_[0], 0, 3, '');
      $_[0] =~ s/\}{3}$//o;
      $_[0] =~ s/&/&/go;
      $_[0] =~ s/
      $_[0] =~ s/>/>/go;
      return $_[0];
    },
    open => "", close => "",
  },
  plug => {
    curpat => '(?=\<{3}.*?\>*\>{3})',
    stops => '.*?\>*\>{3}',
    hint => ['<'],
    filter => sub {
      substr($_[0], 0, 3, '');
      $_[0] =~ s/\>{3}$//o;
      if($plugin_function) {
        return &$plugin_function($_[0]);
      }
      return "<<<$_[0]>>>";
    },
    open => "", close => "",
  },
  plug2 => {
    curpat => '(?=\<{2}.*?\>*\>{2})',
    stops => '.*?\>*\>{2}',
    hint => ['<'],
    filter => sub {
      substr($_[0], 0, 2, '');
      $_[0] =~ s/\>{2}$//o;
      if($plugin_function) {
        return &$plugin_function($_[0]);
      }
      return "<<$_[0]>>";
    },
    open => "", close => "",
  },
  ilink => {
    curpat => '(?=(?:https?|ftp):\/\/)',
    stops => '(?=[[:punct:]]?(?:\s|$))',
    hint => ['h', 'f'],
    filter => sub {
      $_[0] =~ s/^\s*//o;
      $_[0] =~ s/\s*$//o;
      if($barelink_function) {
        $_[0] = &$barelink_function($_[0]);
      }
      return "href=\"$_[0]\">$_[0]"; },
    open => " "",
  },
  link => {
    curpat => '(?=\[\[[^\n]+?\]\])',
    stops => '\]\]',
    hint => ['['],
    contains => ['href', 'atext'],
    filter => sub {
      substr($_[0], 0, 2, '');
      substr($_[0], -2, 2, '');
      $_[0] .= "|$_[0]" unless $_[0] =~ tr/|/|/; # text = url unless given
      return $_[0];
    },
    open => " "",
  },
  href => {
    curpat => '(?=[^\|])',
    stops => '(?=\|)',
    filter => sub {
      $_[0] =~ s/^\s*//o;
      $_[0] =~ s/\s*$//o;
      if($link_function) {
        $_[0] = &$link_function($_[0]);
      }
      return $_[0];
    },
    open => 'href="', close => '">',
  },
  atext => {
    curpat => '(?=\|)',
    stops => '\n',
    hint => ['|'],
    contains => \@all_inline,
    filter => sub {
      $_[0] =~ s/^\|\s*//o;
      $_[0] =~ s/\s*$//o;
      return $_[0];
    },
    open => '', close => '',
  },
  img => {
    curpat => '(?=\{\{[^\{][^\n]*?\}\})',
    stops => '\}\}',
    hint => ['{'],
    contains => ['imgsrc', 'imgalt'],
    filter => sub {
      substr($_[0], 0, 2, '');
      $_[0] =~ s/\}\}$//o;
      return $_[0];
    },
    open => " " />",
  },
  imgalt => {
    curpat => '(?=\|)',
    stops => '\n',
    hint => ['|'],
    filter => sub { $_[0] =~ s/^\|\s*//o; $_[0] =~ s/\s*$//o; return $_[0]; },
    open => ' alt="', close => '"',
  },
  imgsrc => {
    curpat => '(?=[^\|])',
    stops => '(?=\|)',
    filter => sub {
      $_[0] =~ s/^\s*//o;
      $_[0] =~ s/\s*$//o;
      if($img_function) {
        $_[0] = &$img_function($_[0]);
      }
      return $_[0];
    },
    open => 'src="', close => '"',
  },
  strong => {
    curpat => '(?=\*\*)',
    stops => '\*\*.*?\*\*',
    hint => ['*'],
    contains => \@all_inline,
    filter => sub {
      substr($_[0], 0, 2, '');
      $_[0] =~ s/\*\*$//o;
      return $_[0];
    },
    open => "", close => "",
  },
  em => {
    curpat => '(?=\/\/)',
    stops => '\/\/.*?(?
    hint => ['/'],
    contains => \@all_inline,
    filter => sub {
      substr($_[0], 0, 2, '');
      $_[0] =~ s/\/\/$//o;
      return $_[0];
    },
    open => "", close => "",
  },
  mono => {
    curpat => '(?=\#\#)',
    stops => '\#\#.*?\#\#',
    hint => ['#'],
    contains => \@all_inline,
    filter => sub {
      substr($_[0], 0, 2, '');
      $_[0] =~ s/\#\#$//o;
      return $_[0];
    },
    open => "", close => "",
  },
  sub => {
    curpat => '(?=,,)',
    stops => ',,.*?,,',
    hint => [','],
    contains => \@all_inline,
    filter => sub {
      substr($_[0], 0, 2, '');
      $_[0] =~ s/\,\,$//o;
      return $_[0];
    },
    open => "", close => "",
  },
  sup => {
    curpat => '(?=\^\^)',
    stops => '\^\^.*?\^\^',
    hint => ['^'],
    contains => \@all_inline,
    filter => sub {
      substr($_[0], 0, 2, '');
      $_[0] =~ s/\^\^$//o;
      return $_[0];
    },
    open => "", close => "",
  },
  u => {
    curpat => '(?=__)',
    stops => '__.*?__',
    hint => ['_'],
    contains => \@all_inline,
    filter => sub {
      substr($_[0], 0, 2, '');
      $_[0] =~ s/__$//o;
      return $_[0];
    },
    open => "", close => "",
  },
  amp => {
    curpat => '(?=\&(?!\w+\;))',
    stops => '.',
    hint => ['&'],
    filter => sub { return "&"; },
    open => "", close => "",
  },
  tm => {
    curpat => '(?=\(TM\))',
    stops => '\(TM\)',
    hint => ['('],
    filter => sub { return "™"; },
    open => "", close => "",
  },
  reg => {
    curpat => '(?=\(R\))',
    stops => '\(R\)',
    hint => ['('],
    filter => sub { return "®"; },
    open => "", close => "",
  },
  copy => {
    curpat => '(?=\(C\))',
    stops => '\(C\)',
    hint => ['('],
    filter => sub { return "©"; },
    open => "", close => "",
  },
  ndash => {
    curpat => '(?=--)',
    stops => '--',
    hint => ['-'],
    filter => sub { return "–"; },
    open => "", close => "",
  },
  ellipsis => {
    curpat => '(?=\.\.\.)',
    stops => '\.\.\.',
    hint => ['.'],
    filter => sub { return "…"; },
    open => "", close => "",
  },
);


sub parse; # predeclared because it's recursive

sub parse {
  my ($tref, $chunk) = @_;
  my ($html, $ch);
  my $pos = 0; my $lpos = 0;
  while(1) {
    if($ch) { # if we already know what kind of chunk this is
      if ($$tref =~ /$chunks{$ch}{delim}/g) { # find where it stops...
        $pos = pos($$tref);                   #     another chunk
      } else {
        $pos = length $$tref;                 #     end of string
      }

      $html .= $chunks{$ch}{open};            # print the open tag

      my $t = substr($$tref, $lpos, $pos - $lpos); # grab the chunk
      if($chunks{$ch}{filter}) {   # filter it, if applicable
        $t = &{$chunks{$ch}{filter}}($t);
      }
      $lpos = $pos;  # remember where this chunk ends (where next begins)
      if($t && $chunks{$ch}{contains}) {  # if it contains other chunks...
        $html .= parse(\$t, $ch);         #    recurse.
      } else {
        $html .= $t;                      #    otherwise, print it
      }
      $html .= $chunks{$ch}{close};       # print the close tag
    }

    if($pos && $pos == length($$tref)) { # we've eaten the whole string
      last;
    } else {                             # more string to come
      $ch = undef;
      my $fc = substr($$tref, $pos, 1);     # get a hint about the next chunk
      foreach (@{$chunks{$chunk}{hints}{$fc}}) {
#        print "trying $_ for -$fc- on -" . substr($$tref, $pos, 2) . "-\n";
        if($$tref =~ $chunks{$_}{curpatcmp}) { # hint helped id the chunk
           $ch = $_; last;
        }
      }
      unless($ch) {                           #  hint didn't help
        foreach (@{$chunks{$chunk}{contains}}) { # check all possible chunks
#          print "trying $_ on -" . substr($$tref, $pos, 2) . "-\n";
          if ($$tref =~ $chunks{$_}{curpatcmp}) { # found one
            $ch = $_; last;
          }
        }
        last unless $ch;  # no idea what this is.  ditch the rest and give up.
      }
    }
  }
  return $html;  # voila!
}

# compile a regex that matches any of the patterns that interrupt the
# current chunk.
sub delim {
  if(ref $chunks{$_[0]}{stops}) {
    my $regex;
    foreach(@{$chunks{$_[0]}{stops}}) {
      if($chunks{$_}{fwpat}) {
        $regex .= "$chunks{$_}{fwpat}|";
      } else {
        $regex .= "$chunks{$_}{curpat}|";
      }
    }
    chop $regex;
    return qr/$regex/s;
  } else {
    return qr/$chunks{$_[0]}{stops}/s;
  }
}

# one-time optimization of the grammar - speeds the parser up a ton
sub init {
  return if $initialized;

  $initialized = 1;

  # build an array of "plain content" characters by subtracting @specialchars
  # from ascii printable (ascii 32 to 126)
  my %is_special = map({$_ => 1} @specialchars);
  for (32 .. 126) {
    push(@plainchars, chr($_)) unless $is_special{chr($_)};
  }

  # precompile a bunch of regexes
  foreach my $c (keys %chunks) {
    if($chunks{$c}{curpat}) {
      $chunks{$c}{curpatcmp} = qr/\G$chunks{$c}{curpat}/s;
    }
    if($chunks{$c}{stops}) {
      $chunks{$c}{delim} = delim $c;
    }
    if($chunks{$c}{contains}) { # store hints about each chunk to speed id
      foreach my $ct (@{$chunks{$c}{contains}}) {
        foreach (@{$chunks{$ct}{hint}}) {
          push @{$chunks{$c}{hints}{$_}}, $ct;
        }
      }
    }
  }
}

sub creole_parse {
  return unless defined $_[0] && length $_[0] > 0;
  my $text = $_[0];
  init;
  my $html = parse(\$text, "top");
  return $html;
}

sub creole_plugin {
  return unless defined $_[0];
  $plugin_function = $_[0];
}

sub creole_link {
  return unless defined $_[0];
  $link_function = $_[0];
}

sub creole_customlinks {
  $chunks{href}{open} = "";
  $chunks{href}{close} = "";
  $chunks{link}{open} = "";
  $chunks{link}{close} = "";
  delete $chunks{link}{contains};
  $chunks{link}{filter} = sub {
    if($link_function) {
      $_[0] = &$link_function($_[0]);
    }
    return $_[0];
  }
}

sub creole_barelink {
  return unless defined $_[0];
  $barelink_function = $_[0];
}

sub creole_custombarelinks {
  $chunks{ilink}{open} = "";
  $chunks{ilink}{close} = "";
  $chunks{ilink}{filter} = sub {
    if($barelink_function) {
      $_[0] = &$barelink_function($_[0]);
    }
    return $_[0];
  }
}

sub creole_customimgs {
  $chunks{img}{open} = "";
  $chunks{img}{close} = "";
  delete $chunks{img}{contains};
  $chunks{img}{filter} = sub {
    if($img_function) {
      $_[0] = &$img_function($_[0]);
    }
    return $_[0];
  }
}

sub creole_img {
  return unless defined $_[0];
  $img_function = $_[0];
}

sub creole_tag {
  my ($tag, $type, $text) = @_;
  if(! $tag) {
    foreach (sort keys %chunks) {
      my $o = $chunks{$_}{open};
      my $c = $chunks{$_}{close};
      next unless $o && $o =~ /
      $o =~ s/\n/\\n/gso if $o; $o = "" unless $o;
      $c =~ s/\n/\\n/gso if $c; $c = "" unless $c;
      print "$_: open($o) close($c)\n";
    }
  } else {
    return unless ($type eq "open" || $type eq "close");
    return unless $chunks{$tag};
    $chunks{$tag}{$type} = $text ? $text : "";
  }
}

1;
__END__