home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / UseMod.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-22  |  13.8 KB  |  439 lines
  1. package CGI::Wiki::Formatter::UseMod;
  2.  
  3. use strict;
  4.  
  5. use vars qw( $VERSION @_links_found );
  6. $VERSION = '0.09';
  7.  
  8. use URI::Escape;
  9. use Text::WikiFormat as => 'wikiformat';
  10. use HTML::PullParser;
  11. use URI::Find::Delimited;
  12.  
  13. =head1 NAME
  14.  
  15. CGI::Wiki::Formatter::UseMod - UseModWiki-style formatting for CGI::Wiki
  16.  
  17. =head1 DESCRIPTION
  18.  
  19. A formatter backend for L<CGI::Wiki> that supports UseMod-style formatting.
  20.  
  21. =head1 SYNOPSIS
  22.  
  23.   use CGI::Wiki::Formatter::UseMod;
  24.  
  25.   # Instantiate - see below for parameter details.
  26.   my $formatter = CGI::Wiki::Formatter::UseMod->new( %config );
  27.  
  28.   # Format some text.
  29.   my $cooked = $formatter->format($raw);
  30.  
  31.   # Find out which other nodes that text would link to.
  32.   my @links_to = $formatter->find_internal_links($raw);
  33.  
  34. =head1 METHODS
  35.  
  36. =over 4
  37.  
  38. =item B<new>
  39.  
  40.   my $formatter = CGI::Wiki::Formatter::UseMod->new(
  41.                  extended_links      => 0, # $FreeLinks
  42.                  implicit_links      => 1, # $WikiLinks
  43.                  force_ucfirst_nodes => 1, # $FreeUpper
  44.                  use_headings        => 1, # $UseHeadings
  45.                  allowed_tags        => [qw(b i)], # defaults to none
  46.                  macros              => {},
  47.                  node_prefix         => 'wiki.pl?',
  48.                  node_suffix         => '',
  49.                  edit_prefix         => 'wiki.pl?action=edit&id=',
  50.                  edit_suffix         => '',
  51.                  munge_urls          => 0,
  52.   );
  53.  
  54. Parameters will default to the values shown above (apart from
  55. C<allowed_tags>, which defaults to allowing no tags).
  56.  
  57. =over 4
  58.  
  59. =item B<URL munging>
  60.  
  61. If you set C<munge_urls> to true, then your URLs will be more
  62. user-friendly, for example
  63.  
  64.   http://example.com/wiki.cgi?Mailing_List_Managers
  65.  
  66. rather than
  67.  
  68.   http://example.com/wiki.cgi?Mailing%20List%20Managers
  69.  
  70. The former behaviour is the actual UseMod behaviour, but requires a
  71. little fiddling about in your code (see C<node_name_to_node_param>),
  72. so the default is to B<not> munge URLs.
  73.  
  74. =item B<Macros>
  75.  
  76. Be aware that macros are processed I<after> filtering out disallowed
  77. HTML tags.  They are also not called in any particular order.
  78.  
  79. The keys of macros should be either regexes or strings. The values can
  80. be strings, or, if the corresponding key is a regex, can be coderefs.
  81. The coderef will be called with the first nine substrings captured by
  82. the regex as arguments. I would like to call it with all captured
  83. substrings but apparently this is complicated.
  84.  
  85. =back
  86.  
  87. Macro examples:
  88.  
  89.   macros => {
  90.  
  91.       '@SEARCHBOX' =>
  92.                 qq(<form action="wiki.pl" method="get">
  93.                    <input type="hidden" name="action" value="search">
  94.                    <input type="text" size="20" name="terms">
  95.                    <input type="submit"></form>),
  96.  
  97.       qr/\@INDEX\s+\[Category\s+([^\]]+)]/ =>
  98.             sub { return "{an index of things in category $_[0]}" }
  99.  
  100.   }
  101.  
  102. =cut
  103.  
  104. sub new {
  105.     my ($class, @args) = @_;
  106.     my $self = {};
  107.     bless $self, $class;
  108.     $self->_init(@args) or return undef;
  109.     return $self;
  110. }
  111.  
  112. sub _init {
  113.     my ($self, %args) = @_;
  114.  
  115.     # Store the parameters or their defaults.
  116.     my %defs = ( extended_links      => 0,
  117.                  implicit_links      => 1,
  118.                  force_ucfirst_nodes => 1,
  119.                  use_headings        => 1,
  120.                  allowed_tags        => [],
  121.                  macros              => {},
  122.                  node_prefix         => 'wiki.pl?',
  123.                  node_suffix         => '',
  124.                  edit_prefix         => 'wiki.pl?action=edit&id=',
  125.                  edit_suffix         => '',
  126.                  munge_urls          => 0,
  127.                );
  128.  
  129.     my %collated = (%defs, %args);
  130.     foreach my $k (keys %defs) {
  131.         $self->{"_".$k} = $collated{$k};
  132.     }
  133.  
  134.     return $self;
  135. }
  136.  
  137. =item B<format>
  138.  
  139.   my $html = $formatter->format($submitted_content, $wiki);
  140.  
  141. Escapes any tags which weren't specified as allowed on creation, then
  142. interpolates any macros, then translates the raw Wiki language
  143. supplied into HTML.
  144.  
  145. A L<CGI::Wiki> object can be supplied as an optional second parameter.
  146. This object will be used to determine whether a linked-to node exists
  147. or not, and alter the presentation of the link accordingly. This is
  148. only really in here for use when this method is being called from
  149. within L<CGI::Wiki>.
  150.  
  151. =cut
  152.  
  153. sub format {
  154.     my ($self, $raw, $wiki) = @_;
  155.     $raw =~ s/\r\n/\n/sg; # CGI newline is \r\n not \n
  156.     my $safe = "";
  157.  
  158.     my %allowed = map {lc($_) => 1, "/".lc($_) => 1} @{$self->{_allowed_tags}};
  159.  
  160.     # Parse the HTML - even if we're not allowing any tags, because we're
  161.     # using a custom escaping routine rather than CGI.pm
  162.     my $parser = HTML::PullParser->new(doc   => $raw,
  163.                                        start => '"TAG", tag, text',
  164.                                        end   => '"TAG", tag, text',
  165.                                        text  => '"TEXT", tag, text');
  166.     while (my $token = $parser->get_token) {
  167.         my ($flag, $tag, $text) = @$token;
  168.         if ($flag eq "TAG" and !defined $allowed{lc($tag)}) {
  169.             $safe .= $self->_escape_HTML($text);
  170.         } else {
  171.             $safe .= $text;
  172.         }
  173.     }
  174.  
  175.     # Now do any inline links.
  176.     my $finder = URI::Find::Delimited->new( ignore_quoted => 1 );
  177.     $finder->find(\$safe);
  178.  
  179.     # Now process any macros.
  180.     my %macros = %{$self->{_macros}};
  181.     foreach my $key (keys %macros) {
  182.         my $value = $macros{$key};
  183.         if ( ref $value && ref $value eq 'CODE' ) {
  184.             $safe =~ s/$key/$value->($1, $2, $3, $4, $5, $6, $7, $8, $9)/eg;
  185.         } else {
  186.           $safe =~ s/$key/$value/g;
  187.         }
  188.     }
  189.  
  190.     # Finally set up config and call Text::WikiFormat.
  191.     my %format_opts = ( extended       => $self->{_extended_links},
  192.                         prefix         => $self->{_node_prefix},
  193.                         implicit_links => $self->{_implicit_links} );
  194.  
  195.     my %format_tags = (
  196.         # chromatic made most of the regex below.  I will document it when
  197.         # I understand it properly.
  198.         indent   => qr/^(?:\t+|\s{4,}|\s*\*?(?=\**\*+))/,
  199.         newline => "", # avoid bogus <br />
  200.         paragraph       => [ "<p>", "</p>\n", "", "\n", 1 ], # no bogus <br />
  201.         extended_link_delimiters => [ '[[', ']]' ],
  202.         blocks                   => {
  203.                          ordered         => qr/^\s*([\d]+)\.\s*/,
  204.                          unordered       => qr/^\s*\*\s*/,
  205.                          definition      => qr/^:\s*/
  206.                                     },
  207.         definition               => [ "<dl>\n", "</dl>\n", "<dt><dd>", "\n" ],
  208.         indented   => { definition => 0 }, 
  209.         blockorder => [ qw( header line ordered unordered code definition paragraph )],
  210.         nests      => { map { $_ => 1} qw( ordered unordered ) },
  211.         link                     => sub {
  212.             my ($link, $opts) = @_;
  213.             $opts ||= {};
  214.  
  215.             my $title;
  216.             ($link, $title) = split(/\|/, $link, 2) if $opts->{extended};
  217.             $title =~ s/^\s*// if $title; # strip leading whitespace
  218.             $title ||= $link;
  219.  
  220.             if ( $self->{_force_ucfirst_nodes} ) {
  221.                 $link = $self->_do_freeupper($link);
  222.             }
  223.             $link = $self->_munge_spaces($link);
  224.  
  225.             my $editlink_not_link = 0;
  226.             # See whether the linked-to node exists, if we can.
  227.             if ( $wiki && !$wiki->node_exists( $link ) ) {
  228.                 $editlink_not_link = 1;
  229.             }
  230.  
  231.             $link =~ s/ /_/g if $self->{_munge_urls};
  232.  
  233.             $link = uri_escape( $link );
  234.  
  235.             if ( $editlink_not_link ) {
  236.                 my $prefix = $self->{_edit_prefix};
  237.                 my $suffix = $self->{_edit_suffix};
  238.                 return qq|[$title]<a href="$prefix$link$suffix">?</a>|;
  239.             } else {
  240.                 my $prefix = $self->{_node_prefix};
  241.                 my $suffix = $self->{_node_suffix};
  242.                 return qq|<a href="$prefix$link$suffix">$title</a>|;
  243.             }
  244.         },
  245.     );
  246.  
  247.     return wikiformat($safe, \%format_tags, \%format_opts );
  248. }
  249.  
  250. # CGI.pm is sometimes awkward about actually performing CGI::escapeHTML
  251. # if there's a previous instantiation - in the calling script, for example.
  252. # So just do it here.
  253. sub _escape_HTML {
  254.     my ($self, $text) = @_;
  255.     $text =~ s{&}{&}gso;
  256.     $text =~ s{<}{<}gso;
  257.     $text =~ s{>}{>}gso;
  258.     $text =~ s{"}{"}gso;
  259.     return $text;
  260. }
  261.  
  262. =item B<find_internal_links> 
  263.  
  264.   my @links_to = $formatter->find_internal_links( $content ); 
  265.  
  266. Returns a list of all nodes that the supplied content links to. 
  267.  
  268. =cut 
  269.  
  270. sub find_internal_links { 
  271.     my ($self, $raw) = @_;
  272.  
  273.     @_links_found = (); 
  274.  
  275.     my %format_opts = ( extended       => $self->{_extended_links},
  276.                         prefix         => $self->{_node_prefix},
  277.                         implicit_links => $self->{_implicit_links} );
  278.  
  279.     my %format_tags = ( extended_link_delimiters => [ '[[', ']]' ],
  280.                         link => sub {
  281.                             my ($link, $opts) = @_;
  282.                             $opts ||= {};
  283.                             my $title;
  284.                             ($link, $title) = split(/\|/, $link, 2)
  285.                               if $opts->{extended};
  286.                             if ( $self->{_force_ucfirst_nodes} ) {
  287.                                 $link = $self->_do_freeupper($link);
  288.                             }
  289.                             $link = $self->_munge_spaces($link);
  290.                             push @CGI::Wiki::Formatter::UseMod::_links_found,
  291.                                                                          $link;
  292.                             return ""; # don't care about output
  293.                                      }
  294.     );
  295.  
  296.     my $foo = wikiformat($raw, \%format_tags, \%format_opts);
  297.  
  298.     my @links = @_links_found;
  299.     @_links_found = ();
  300.     return @links;
  301. }
  302.  
  303.  
  304. =item B<node_name_to_node_param>
  305.  
  306.   use URI::Escape;
  307.   $param = $formatter->node_name_to_node_param( "Recent Changes" );
  308.   my $url = "wiki.pl?" . uri_escape($param);
  309.  
  310. In usemod, the node name is encoded prior to being used as part of the
  311. URL. This method does this encoding (essentially, whitespace is munged
  312. into underscores). In addition, if C<force_ucfirst_nodes> is in action
  313. then the node names will be forced ucfirst if they weren't already.
  314.  
  315. Note that unless C<munge_urls> was set to true when C<new> was called,
  316. this method will do nothing.
  317.  
  318. =cut
  319.  
  320. sub node_name_to_node_param {
  321.     my ($self, $node_name) = @_;
  322.     return $node_name unless $self->{_munge_urls};
  323.     my $param = $node_name;
  324.     $param = $self->_munge_spaces($param);
  325.     $param = $self->_do_freeupper($param) if $self->{_force_ucfirst_nodes};
  326.     $param =~ s/ /_/g;
  327.  
  328.     return $param;
  329. }
  330.  
  331. =item B<node_param_to_node_name>
  332.  
  333.   my $node = $q->param('node') || "";
  334.   $node = $formatter->node_param_to_node_name( $node );
  335.  
  336. In usemod, the node name is encoded prior to being used as part of the
  337. URL, so we must decode it before we can get back the original node name.
  338.  
  339. Note that unless C<munge_urls> was set to true when C<new> was called,
  340. this method will do nothing.
  341.  
  342. =cut
  343.  
  344. sub node_param_to_node_name {
  345.     my ($self, $param) = @_;
  346.     return $param unless $self->{_munge_urls};
  347.  
  348.     # Note that this might not give us back exactly what we started with,
  349.     # since in the encoding we collapse and trim whitespace; but this is
  350.     # how usemod does it (as of 0.92) and usemod is what we're emulating.
  351.     $param =~ s/_/ /g;
  352.  
  353.     return $param;
  354. }
  355.  
  356. sub _do_freeupper {
  357.     my ($self, $node) = @_;
  358.  
  359.     # This is the FreeUpper usemod behaviour, slightly modified from
  360.     # their regexp, as we need to do it before we check whether the
  361.     # node exists ie before we substitute the spaces with underscores.
  362.     $node = ucfirst($node);
  363.     $node =~ s|([- _.,\(\)/])([a-z])|$1.uc($2)|ge;
  364.  
  365.     return $node;
  366. }
  367.  
  368. sub _munge_spaces {
  369.     my ($self, $node) = @_;
  370.  
  371.     # Yes, we really do only munge spaces, not all whitespace. This is
  372.     # how usemod does it (as of 0.92).
  373.     $node =~ s/ +/ /g;
  374.     $node =~ s/^ //;
  375.     $node =~ s/ $//;
  376.  
  377.     return $node
  378. }
  379.  
  380. =head1 AUTHOR
  381.  
  382. Kake Pugh (kake@earth.li).
  383.  
  384. =head1 COPYRIGHT
  385.  
  386.      Copyright (C) 2003 Kake Pugh.  All Rights Reserved.
  387.  
  388. This module is free software; you can redistribute it and/or modify it
  389. under the same terms as Perl itself.
  390.  
  391. =head1 CREDITS
  392.  
  393. The OpenGuides London team (L<http://openguides.org/london/>) sent
  394. some very helpful bug reports. A lot of the work of this module is
  395. done within chromatic's module, L<Text::WikiFormat>.
  396.  
  397. =head1 CAVEATS
  398.  
  399. This doesn't yet support all of UseMod's formatting features and
  400. options, by any means.  This really truly I<is> a 0.0* release. Please
  401. send bug reports, omissions, patches, and stuff, to me at
  402. C<kake@earth.li>.
  403.  
  404. =head1 NOTE ON USEMOD COMPATIBILITY
  405.  
  406. UseModWiki "encodes" node names before making them part of a URL, so
  407. for example a node about Wombat Defenestration will have a URL like
  408.  
  409.   http://example.com/wiki.cgi?Wombat_Defenestration
  410.  
  411. So if we want to emulate a UseModWiki exactly, we need to munge back
  412. and forth between node names as titles, and node names as CGI params.
  413.  
  414.   my $formatter = CGI::Wiki::Formatter::UseMod->new( munge_urls => 1 );
  415.   my $node_param = $q->param('id') || $q->param('keywords') || "";
  416.   my $node_name = $formatter->node_param_to_node_name( $node_param );
  417.  
  418.   use URI::Escape;
  419.   my $url = "http://example.com/wiki.cgi?"
  420.     . uri_escape(
  421.        $formatter->node_name_to_node_param( "Wombat Defenestration" )
  422.                  );
  423.  
  424. =head1 SEE ALSO
  425.  
  426. =over 4
  427.  
  428. =item * L<CGI::Wiki>
  429.  
  430. =item * L<Text::WikiFormat>
  431.  
  432. =item * UseModWiki (L<http://www.usemod.com/cgi-bin/wiki.pl>)
  433.  
  434. =back
  435.  
  436. =cut
  437.  
  438. 1;
  439.