view release on metacpan or  search on metacpan

t/oddmuse-wiki.pl  view on Meta::CPAN

  }
}

sub GetParam {
  my ($name, $default) = @_;
  my $result = $q->param(encode_utf8($name));
  $result //= $default;
  return QuoteHtml($result); # you need to unquote anything that can have <tags>
}

sub SetParam {
  my ($name, $val) = @_;
  $q->param($name, $val);
}

sub InitLinkPatterns {
  my ($WikiWord, $QDelim);
  $QDelim = '(?:"")?'; # Optional quote delimiter (removed from the output)
  $WikiWord = '\p{Uppercase}+\p{Lowercase}+\p{Uppercase}\p{Alphabetic}*';
  $LinkPattern = "($WikiWord)$QDelim";
  $FreeLinkPattern = "([-,.()'%&!?;<> _1-9A-Za-z\x{0080}-\x{fffd}]|[-,.()'%&!?;<> _0-9A-Za-z\x{0080}-\x{fffd}][-,.()'%&!?;<> _0-9A-Za-z\x{0080}-\x{fffd}]+)"; # disallow "0" and must match HTML and plain text (ie. > and &gt;)
  # Intersites must start with uppercase letter to avoid confusion with URLs.
  $InterSitePattern = '[A-Z\x{0080}-\x{fffd}]+[A-Za-z\x{0080}-\x{fffd}]+';
  $InterLinkPattern = "($InterSitePattern:[-a-zA-Z0-9\x{0080}-\x{fffd}_=!?#\$\@~`\%&*+\\/:;.,]*[-a-zA-Z0-9\x{0080}-\x{fffd}_=#\$\@~`\%&*+\\/])$QDelim";
  $FreeInterLinkPattern = "($InterSitePattern:[-a-zA-Z0-9\x{0080}-\x{fffd}_=!?#\$\@~`\%&*+\\/:;.,()' ]+)"; # plus space and other characters, and no restrictions on the end of the pattern
  $UrlProtocols = 'https?|ftp|afs|news|nntp|mid|cid|mailto|wais|prospero|telnet|gophers?|irc|feed';
  $UrlProtocols .= '|file' if $NetworkFile;
  my $UrlChars = '[-a-zA-Z0-9/@=+$_~*.,;:?!\'"()&#%]'; # see RFC 2396
  my $EndChars = '[-a-zA-Z0-9/@=+$_~*]'; # no punctuation at the end of the url.
  $UrlPattern = "((?:$UrlProtocols):$UrlChars+$EndChars)";
  $FullUrlPattern="((?:$UrlProtocols):$UrlChars+)"; # when used in square brackets
  $ImageExtensions = '(gif|jpg|jpeg|png|bmp|svg)';
}

sub Clean {
  my $block = shift;
  return 0 unless defined($block); # "0" must print
  return 1 if $block eq '';        # '' is the result of a dirty rule
  $Fragment .= $block;
  return 1;
}

sub Dirty { # arg 1 is the raw text; the real output must be printed instead
  if ($Fragment ne '') {
    $Fragment =~ s|<p>\s*</p>||g; # clean up extra paragraphs (see end of ApplyRules)
    print $Fragment;
    push(@Blocks, $Fragment);
    push(@Flags, 0);
  }
  push(@Blocks, shift);
  push(@Flags, 1);
  $Fragment = '';
}

sub ApplyRules {
  # locallinks: apply rules that create links depending on local config (incl. interlink!)
  my ($text, $locallinks, $withanchors, $revision, @tags) = @_; # $revision is used for images
  $text =~ s/\r\n/\n/g;   # DOS to Unix
  $text =~ s/\n+$//g;   # No trailing paragraphs
  return if $text eq '';  # allow the text '0'
  local $Fragment = '';  # the clean HTML fragment not yet on @Blocks
  local @Blocks = ();  # the list of cached HTML blocks
  local @Flags = ();   # a list for each block, 1 = dirty, 0 = clean
  Clean(join('', map { AddHtmlEnvironment($_) } @tags));
  if ($OpenPageName and $PlainTextPages{$OpenPageName}) { # there should be no $PlainTextPages{''}
    Clean(CloseHtmlEnvironments() . $q->pre($text));
  } elsif (my ($type) = TextIsFile($text)) { # TODO? $type defined here??
    Clean(CloseHtmlEnvironments() . $q->p(T('This page contains an uploaded file:'))
	  . $q->p(GetDownloadLink($OpenPageName, (substr($type, 0, 6) eq 'image/'), $revision))
	  . (length $Page{summary} > 0 ? $q->blockquote(QuoteHtml($Page{summary})) : $q->p(T('No summary was provided for this file.'))));
  } else {
    my $smileyregex = join "|", keys %Smilies;
    $smileyregex = qr/(?=$smileyregex)/;
    local $_ = $text;
    local $bol = 1;
    while (1) {
      # Block level elements should eat trailing empty lines to prevent empty p elements.
      if ($bol and m/\G(\s*\n)+/cg) {
	Clean(CloseHtmlEnvironments() . AddHtmlEnvironment('p'));
      } elsif ($bol and m/\G(\&lt;include(\s+(text|with-anchors))?\s+"(.*)"\&gt;[ \t]*\n?)/cgi) {
	# <include "uri..."> includes the text of the given URI verbatim
	Clean(CloseHtmlEnvironments());
	Dirty($1);
	my ($oldpos, $old_, $type, $uri) = ((pos), $_, $3, UnquoteHtml($4)); # remember, page content is quoted!
	if ($uri =~ /^($UrlProtocols):/) {
	  if ($type eq 'text') {
	    print $q->pre({class=>"include $uri"}, QuoteHtml(GetRaw($uri)));
	  } else { # never use local links for remote pages, with a starting tag
	    print $q->start_div({class=>'include'});
	    ApplyRules(QuoteHtml(GetRaw($uri)), 0, ($type eq 'with-anchors'), undef, 'p');
	    print $q->end_div();
	  }
	} else {
	  $Includes{$OpenPageName} = 1;
	  local $OpenPageName = FreeToNormal($uri);
	  if ($type eq 'text') {
	    print $q->pre({class=>"include $OpenPageName"}, QuoteHtml(GetPageContent($OpenPageName)));
	  } elsif (not $Includes{$OpenPageName}) { # with a starting tag, watch out for recursion
	    print $q->start_div({class=>"include $OpenPageName"});
	    ApplyRules(QuoteHtml(GetPageContent($OpenPageName)), $locallinks, $withanchors, undef, 'p');
	    print $q->end_div();
	    delete $Includes{$OpenPageName};
	  } else {
	    print $q->p({-class=>'error'}, $q->strong(Ts('Recursive include of %s!', $OpenPageName)));
	  }
	}
	Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
	($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
      } elsif ($bol and m/\G(\&lt;(journal|titles):?(\d*)((\s+|:)(\d*),?(\d*))?(\s+"(.*?)")?(\s+(reverse|past|future))?(\s+search\s+(.*))?\&gt;[ \t]*\n?)/cgi) {
	# <journal 10 "regexp"> includes 10 pages matching regexp
	Clean(CloseHtmlEnvironments());
	Dirty($1);
	my ($oldpos, $old_) = (pos, $_); # remember these because of the call to PrintJournal()
	PrintJournal($6, $7, $9, $11, $3, $13, $2);
	Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
	($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
      } elsif ($bol and m/\G(\&lt;rss(\s+(\d*))?\s+(.*?)\&gt;[ \t]*\n?)/cgis) {
	# <rss "uri..."> stores the parsed RSS of the given URI
	Clean(CloseHtmlEnvironments());
	Dirty($1);
	my ($oldpos, $old_) = (pos, $_); # remember these because of the call to RSS()

t/oddmuse-wiki.pl  view on Meta::CPAN

  my $old_is_image = ($old_is_file =~ /^image\//);
  my $new_is_file = TextIsFile($new);
  if ($old_is_file or $new_is_file) {
    return $q->p($q->strong(T('Old revision:')))
      . $q->div({-class=>'old'}, # don't pring new revision, because that's the one that gets shown!
    $q->p($old_is_file ? GetDownloadLink($OpenPageName, $old_is_image, $revision) : $old))
    }
  $old =~ s/[\r\n]+/\n/g;
  $new =~ s/[\r\n]+/\n/g;
  return ImproveDiff(DoDiff($old, $new));
}

sub ImproveDiff {      # NO NEED TO BE called within a diff lock
  my $diff = QuoteHtml(shift);
  $diff =~ tr/\r//d;
  my @hunks = split (/^(\d+,?\d*[adc]\d+,?\d*\n)/m, $diff);
  my $result = shift (@hunks);  # intro
  while ($#hunks > 0) {         # at least one header and a real hunk
    my $header = shift (@hunks);
    $header =~ s|^(\d+.*c.*)|<p><strong>Changed:</strong></p>| # T('Changed:')
      or $header =~ s|^(\d+.*d.*)|<p><strong>Deleted:</strong></p>| # T('Deleted:')
	or $header =~ s|^(\d+.*a.*)|<p><strong>Added:</strong></p>|; # T('Added:')
    $result .= $header;
    my $chunk = shift (@hunks);
    my ($old, $new) = split (/\n---\n/, $chunk, 2);
    if ($old and $new) {
      ($old, $new) = DiffMarkWords($old, $new);
      $result .= "$old<p><strong>to</strong></p>\n$new"; # T('to')
    } else {
      if (substr($chunk, 0, 2) eq '&g') {
	$result .= DiffAddPrefix(DiffStripPrefix($chunk), '&gt; ', 'new');
      } else {
	$result .= DiffAddPrefix(DiffStripPrefix($chunk), '&lt; ', 'old');
      }
    }
  }
  return $result;
}

sub DiffMarkWords {
  my ($old, $new) = map { DiffStripPrefix($_) } @_;
  my @diffs = grep(/^\d/, split(/\n/, DoDiff(join("\n", split(/\s+|\b/, $old)) . "\n",
					     join("\n", split(/\s+|\b/, $new)) . "\n")));
  foreach my $diff (reverse @diffs) { # so that new html tags don't confuse word counts
    my ($start1, $end1, $type, $start2, $end2) = $diff =~ /^(\d+),?(\d*)([adc])(\d+),?(\d*)$/gm;
    if ($type eq 'd' or $type eq 'c') {
      $end1 ||= $start1;
      $old = DiffHtmlMarkWords($old, $start1, $end1);
    }
    if ($type eq 'a' or $type eq 'c') {
      $end2 ||= $start2;
      $new = DiffHtmlMarkWords($new, $start2, $end2);
    }
  }
  return (DiffAddPrefix($old, '&lt; ', 'old'),
	  DiffAddPrefix($new, '&gt; ', 'new'));
}

sub DiffHtmlMarkWords {
  my ($text, $start, $end) = @_;
  my @fragments = split(/(\s+|\b)/, $text);
  splice(@fragments, 2 * ($start - 1), 0, '<strong class="changes">');
  splice(@fragments, 2 * $end, 0, '</strong>');
  my $result = join('', @fragments);
  $result =~ s!&<(/?)strong([^>]*)>(amp|[gl]t);!<$1strong$2>&$3;!g;
  $result =~ s!&(amp|[gl]t)<(/?)strong([^>]*)>;!&$1;<$2strong$3>!g;
  return $result;
}

sub DiffStripPrefix {
  my $str = shift;
  $str =~ s/^&[lg]t; //gm;
  return $str;
}

sub DiffAddPrefix {
  my ($str, $prefix, $class) = @_;
  my @lines = split(/\n/, $str);
  for my $line (@lines) {
    $line = $prefix . $line;
  }
  return $q->div({-class=>$class}, $q->p(join($q->br(), @lines)));
}

sub ParseData {
  my $data = shift;
  my %result;
  while ($data =~ /(\S+?): (.*?)(?=\n[^ \t]|\Z)/gs) {
    my ($key, $value) = ($1, $2);
    $value =~ s/\n\t/\n/g;
    $result{$key} = $value;
  }
  # return unless %result; # undef instead of empty hash # TODO should we do that?
  return wantarray ? %result : \%result; # return list sometimes for compatibility
}

sub OpenPage {      # Sets global variables
  my $id = shift;
  return if $OpenPageName eq $id;
  if ($IndexHash{$id}) {
    %Page = %{ParseData(ReadFileOrDie(GetPageFile($id)))};
  } else {
    %Page = ();
    $Page{ts} = $Now;
    $Page{revision} = 0;
  }
  $OpenPageName = $id;
}

sub GetTextAtTime { # call with opened page, return $minor if all pages between now and $ts are minor!
  my $ts = shift;
  my $minor = $Page{minor};
  return ($Page{text}, $minor, 0) if $Page{ts} <= $ts; # current page is old enough
  return ($DeletedPage, $minor, 0) if $Page{revision} == 1 and $Page{ts} > $ts; # created after $ts
  my $keep = {};    # info may be needed after the loop
  foreach my $revision (GetKeepRevisions($OpenPageName)) {
    $keep = GetKeptRevision($revision);
    # $minor = 0 unless defined $keep; # TODO?
    $minor = 0 if not $keep->{minor} and $keep->{ts} >= $ts; # ignore keep{minor} if keep{ts} is too old
    return ($keep->{text}, $minor, 0) if $keep->{ts} <= $ts;
  }
  return ($DeletedPage, $minor, 0) if $keep->{revision} == 1; # then the page was created after $ts!
  return ($keep->{text}, $minor, $keep->{ts}); # the oldest revision available is not old enough
}