File Coverage

blib/lib/Text/YAWikiFormater.pm

Criterion	Covered	Total	%
statement	203	259	78.3
branch	76	118	64.4
condition	18	54	33.3
subroutine	16	20	80.0
pod	7	7	100.0
total	320	458	69.8

package Text::YAWikiFormater;

use 5.006;
use strict;
use warnings;

use HTML::Entities qw(encode_entities);
use JSON qw(from_json);

our $VERSION = '0.50';

my %plugins = (
    toc    => \&_handle_toc,
    image  => \&_handle_image,

    restore_code_block  => \&_restore_code_block,
  );

my %namespaces = (
    wp  => { prefix => 'http://en.wikipedia.org/', category=>':' },
		gs	=> { prefix => 'http://www.google.com/search?q=' },
  );

my %closed = (
    b    => qr{(?:(?
    i    => qr{(?
    u    => qr{__},
    del  => qr{(?
    tt  => qw{''},

    heads  => [qr[^(?=!{1,6}\s)]msix, qr[$]msix, \&_header_id, undef,"\n"],

    code  => [qr[^\{\{\{$]msix,qr[^\}\}\}$]msix, \&_escape_code],

    blockquote  => [qr{^>\s}msix, qr{^(?!>)}msix, qr{^>\s}msix, '',"\n"],

    lists  => [qr{^(?=[\*\#]+\s)}msix, qr{(?:^(?![\*\#\s])|\z)}msix, \&_do_lists],

    links    => [qr{(?=\[\[)}, qr{(?<=\]\])},\&_do_links],
    links2  => [qr{\s(?=http://)}, qr{\s},\&_do_links],

    br    => [qr{^(?=$)}msix, qr[$]msix, sub { "",'',''}],

    comments  => [qr{/\*}msix, qr{\*/}msix, sub{ '','',''}],
  );

my %nonclosed = (
    hr  => qr{^[-\*]{3,}\s*?$}msix,
  );

my @do_first = qw( code lists );

sub new {
  my $class = shift;

  my $self = bless { @_ }, $class;

  die "body is a mandatory parameter" unless $self->{body};

  return $self;
}

sub urls {
  my $self= shift;
  my $body = $self->{body};

  return unless $body;

  my @links = $body =~m{(\[\[(?:\S[^\|\]]*)(?:\|(?:[^\]]+))?\]\])}g;
  push @links, $body =~m{\s(https?://\S+)\s}g;

  my $links = $self->{_links} ||= {};

  LINK:
  for my $lnk ( @links ) {
    next if $links->{$lnk};

    my $hlnk = $links->{$lnk} ||= {};

    if ($lnk =~ m{\Ahttps?://}) {
      %$hlnk = ( title => $lnk, href => $lnk, _class => 'external' );
      next LINK;
    }

    ($lnk) = $lnk =~ m{\A\[\[(.*)\]\]\z}g;
    my ($label,$link) = split qr{\|}, $lnk, 2;
    unless ($link) {
      $link = $label;
      if ( $link =~ m{.*[\>\:]([^\>]+)\z} ) {
        $label = $1;
      }
    }

    $hlnk->{title} = $label;
    $hlnk->{original_to} = $link;
    if ($link =~ m{\Ahttps?://} ) {
      $hlnk->{_class} = 'external';
      $hlnk->{href}    = $link;
      next LINK;
    }

    my ($base,$categ) = ('','/');
    if ( $link =~ m{\A(\w+):} ) {
      my ($namespace,$lnk) = split qr{:}, $link, 2;
      $link = $lnk;
      if ( my $nmsp = $namespaces{ $namespace } ){
        if (ref $nmsp eq 'HASH' ) {
          $base   = $nmsp->{prefix}   if $nmsp->{prefix};
          $categ   = $nmsp->{category} if $nmsp->{category};
        } elsif (ref $nmsp eq 'CODE') {
          ($base, $categ, $lnk) = $nmsp->($namespace,$link);
          if ( $lnk and $lnk =~ m{\Ahttps?://} ) {
            $hlnk->{href} = $lnk;
            $hlnk->{_class}='external';
            next LINK;
          } elsif ( $lnk ) {
            $link = $lnk;
          }
        }

      } else {
        warn "Unknow namespace: $namespace on $lnk\n";
      }
    }

    if ( $categ ) {
      $link =~ s{\>}{$categ}g;
    }
    if ( $base ) {
      $link = $base.$link;
    }
    unless ( $link =~ m{\Ahttps?://} ) {
      $link = urify( $link );
    }
    $hlnk->{href} = $link;
  }

  return wantarray ? %{$self->{_links}} : $self->{_links};
}

sub urify {
  my $link = shift;
  my $reg = shift || "^\\w\\-\\/\\s\\#";

  $link =~ s{\s*>\s*}{/}g unless $link =~ m{/};

  $link = encode_entities( $link, $reg );
  $link =~ s{\s+}{-}g;
  while (my ($ent)=$link=~/\&(\#?\w+);/) {
    my $ec=$ent=~/(acute|grave|circ|uml|ring|slash|tilde|cedil)$/i?
      substr($ent,0,1):'_';
    $link=~s/\&$ent;/$ec/ig;
  }
  $link="\L$link";
  $link=~s/\_+$//g;
  $link=~s/\_+/\_/g;

  return $link;
}

sub set_links {
  my ($self, $links) = @_;

  $self->{_links} = $links;

  return;
}

sub format {
  my $self = shift;
  my $body = $self->{body};

  delete $self->{__headers};
  delete $self->{__toc};

  my %done = ();

  $body =~ s{&}{&}g;
  $body =~ s{<}{<}g;
  $body =~ s{>}{>}g;

  # closed tags
  for my $tag ( @do_first, keys %closed ) {
    next if $done{ $tag }++;

    my ($re1, $re2, $re3, $re4, $re5, $re6)
      = ref $closed{ $tag } eq 'ARRAY'
      ? @{ $closed{ $tag } }
      : ( $closed{ $tag } );

    if (!$re2) {
      my $in = 0;
      while ( $body =~ m{$re1}msix ) {
        my $tg = $in ? "" :"<$tag>";
        $body=~s{$re1}{$tg}msix;
        $in = 1 - $in;
      }
      $body.="" if $in;
    } else {
      while ($body =~ m{$re1(.*?)$re2}msix) {
        my $in = $1;
        my ($t1,$t2) = ("<$tag>","");
        if (ref $re3 eq 'Regexp') {
          $re4 //= '';
          $in =~ s{ $re3 }{$re4}msixg;
        } elsif (ref $re3 eq 'CODE') {
          ($t1,$in,$t2) = $re3->($self, $t1, $in, $t2);
        }
        $re5 //= '';
        $body =~ s{$re1(.*?)$re2}{$t1$in$t2$re5}smxi;
      }
    }
  }

  for my $tag ( keys %nonclosed ) {
    my ($re1) = ($nonclosed{ $tag } );

    $body =~ s{ $re1 }{<$tag />}msixg;
  }

  while ($body =~ m[(?
    my ($plugin, $params) = ($1,$2);
    $params = _parse_plugin_params($params);

    my $res = '';
    if ( $plugins{$plugin} ){
      $res = $plugins{ $plugin }->( $self, $plugin, $params ) // '';
    }

    $body =~ s[(?
  }

  while ($body =~ m[\/\+\+(\w+)(?:[:\s*](.+))?\+\+\/]msix) {
    my ($plugin, $params) = ($1,$2);
    $params=~s{\A\s*}{};
    my @params = split qr{\s*,\s*}, $params;

    my $res = '';
    if ( $plugins{$plugin} ){
      $res = $plugins{ $plugin }->( $self, $plugin, @params ) // '';
    }

    $body =~ s[\/\+\+(\w+)(?:[:\s*](.+))?\+\+\/][$res]msix;
  }

  return $body;
}

sub register_namespace {
  my $class = shift;

  my ($namespace, $info, $override) = @_;

	$namespaces{ $namespace } = $info
		if $override or !$namespaces{ $namespace };
}

sub register_plugin {
	my $class = shift;

	my ($pluginname, $pluginref, $override) = @_;

	$plugins{ $pluginname } = $pluginref
		if $override or !$plugins{ $pluginname };
}

sub _header_id {
  my $self = shift;
  my $headers   = $self->{__headers}       ||= {};
  my $headnames  = $self->{__headnames}     ||= {};
  my $toc       = $self->{__toc}           ||= [];
  my ($t1, $in, $t2) = @_;

  my ($type) = $in =~ m{^(!{1,6})\s};
  $in =~ s{^!*\s}{};

  $t1 = 'h'.length($type);
  $t2 = "";
  $t1 = "<$t1>";

  my $id = urify($in, "^\\w\\-\\s");

  if ($headers->{$id}) {
    my $cnt = 1;
    $cnt++ while $headers->{"${id}_$cnt"};
    $id .= "_$cnt";
  }

  $headnames->{$id} = $in;
  $headers->{$id}   = substr($t1, 2, 1);
  push @$toc, $id;

  substr($t1, -1, 0, " id='$id'");

  return $t1, $in, $t2;
}

sub _escape_code {
  my $self = shift;

  my ($t1, $in, $t2) = @_;

  $in=~s{\n}{\n}gs;

  $self->{__codecnt}++;
  $self->{__codeblock}->{$self->{__codecnt}} = $in;

  return '',"/++restore_code_block: $self->{__codecnt}++/", '';
}

sub _do_lists {
  my $self = shift;

  my ($t1, $in, $t2) = @_;

  my @lines = split qr{\n}ms, $in;
  $in = '';
  my $cl = '';
  my $item;
  for my $ln (@lines) {
    if ( $ln !~ m{^\s} ) {
      if ($item) {
        $in .= "$item\n";
        $item = '';
      }
      my ($nl,$l) = $ln =~ m{^([\*\#]+)\s+(.*)$};
      $ln = $l;
      my $close = '';
      my $start = -1;
      if ($nl ne $cl) {
        for my $i (0..length($cl)-1) {
          next if !$close and substr($cl,$i,1) eq substr($nl, $i, 1);
          $start = $i unless $close;
          $close = (substr($cl,$i,1) eq '#' ? "" : "").$close;
        }
        $start = length($cl) if $start == -1;
        $in.=$close."\n" if $close;
        for my $i ($start..length($nl)-1) {
          $in.= substr($nl, $i, 1) eq '#'?"":"";
        }
        $cl = $nl;
      }
    }
    $item .= $ln;
  }
  if ($item) {
    $in .= "$item\n";
  }
  if ($cl) {
    for my $i (reverse 0..length($cl)-1) {
      $in.=substr($cl,$i,1) eq '#' ? "" : "";
    }
    $in.="\n";
  }

  return '',$in,'';
}

sub _do_links {
  my $self = shift;

  my (undef, $link, undef) = @_;

  $self->urls() unless $self->{_links} and $self->{_links}->{$link};

  my $lnk = $self->{_links}->{$link} || {};

  my ($t1,$t2) = ('','');

  $t1 = "
  my $class = $lnk->{class} || $lnk->{_class} || '';
  if ( $class ) {
    $t1.=" class='$class'";
  }
  $t1.='>';

  return $t1, $lnk->{title}, $t2;
}

sub _handle_toc {
  my ($self) = shift;

  my $toc       = $self->{__toc};
  my $headers   = $self->{__headers};
  my $headnames  = $self->{__headnames};

  my $res = "\n";
  for my $head (@$toc) {
    $res.='*'x$headers->{$head};

    $res.=' ';
    $res.='[['.$headnames->{$head}.'|#'.$head."]]\n";
  }
  $res.="\n";

  my $wf = (ref $self)->new(body => $res);
  $res = $wf->format();

  $res = "$res";

  return $res;
}

sub _handle_image {
  my ($self, $plugin, $params) = @_;
  my $src;

  if (ref $params eq 'ARRAY') {
    $src = shift @$params;
    if (@$params and ref $params->[0] eq 'HASH') {
      $params = $params->[0];
    } else {
      $params = { @$params };
    }
  } else {
    $src = delete $params->{src};
  }

  return '' unless $src;

  if ($src =~ m{\Ahttps?://} and $self->{image_filter}) {
    $src = $self->{image_filter}->($src, $params);
  } elsif ($self->{image_mapper}) {
    $src = $self->{image_mapper}->($src, $params);
  }

  return '' unless $src;

  my $res = "
  if ( $params->{size} ) {
    my ($w,$h) = $params->{size} =~ m{\A\d+x\d+\z};

    if ($w and $h) {
       $params->{width}   ||= $w;
      $params->{height} ||= $h;
       delete $params->{size};
    }
  }
  for my $attr ( qw(alt title heigth width) ) {
    next unless $params->{ $attr };
    my $av = $params->{ $attr };
    $av =~ s{&}{&}g;
    $av =~ s{<}{>}g;
    $av  =~ s{>}{<}g;
    $av =~ s{'}{'}g;
    $res.=" $attr='$av'";
  }

  $res.=' />';

  #MAYBETODO: support for caption, to allow to frame the images
  # and add a legend under the image.

  return $res;
}

sub _restore_code_block {
  my ($self, $plugin, $block) = @_;

  my $res = $self->{__codeblock}->{$block};

  return "$res";
}

sub _parse_plugin_params {
  my $paramstr = shift;

  return [] unless $paramstr;

  unless ($paramstr =~ m(\A\s*[\{\[]) ) {
    $paramstr = '['.$paramstr.']';
  }

  my $params = eval {
      from_json( $paramstr, { utf8 => 1 })
    } or do print STDERR "Error Parsing params: $paramstr ==> $@\n";
    #MAYBETODO: export this error somehow? silent it?
    # exporting it may be useful - specially while previewing
    # the result.

  return $params;
}

1;
__END__