view release on metacpan or  search on metacpan

lib/Pod/PXML.pm  view on Meta::CPAN

  
  # And a few that we have to make completely sure are present.
  $Char2xmlent{ord '"'} = '"' ;
  $Char2xmlent{ord '<'} = '&lt;'   ;
  $Char2xmlent{ord '>'} = '&gt;'   ;
  $Char2podent{ord '<'} = 'E<lt>'  ;
  $Char2podent{ord '>'} = 'E<gt>'  ;
}

#print STDERR "Sanity:  214 is ", $Char2podent{214}, "\n";

#------------------------------------------------------------------------

sub pod2xml ($) {
  require Pod::Tree;
  
  my $content = $_[0];

  my $tree = Pod::Tree->new;
  if(ref($content) eq 'SCALAR') {
    $tree->load_string($$content);
  } else {
    $tree->load_file($content);
  }
  unless($tree->loaded) { croak("Couldn't load pod") }
  return _pod_tree_as_xml($tree);
}

#------------------------------------------------------------------------
# Real work:

sub _pod_tree_as_xml {
  my $root = $_[0]->get_root;
  DEBUG > 2 and print "TREE DUMP: <<\n", $_[0]->dump, ">>\n\n";
  
  return "<!-- no pod -->\n\n" unless $root;
  my $out = '';

  my $trav;
  my $x; # scratch
  $trav = sub {
    my $it = $_[0];
    my $type = $it->get_type;
    my $post = '';
    DEBUG and print "Hitting $type\n";
    if($type eq 'root') {
      $out .= join "\n", 
        qq{<?xml version="1.0" encoding="UTF-8" ?>},
        qq{<!DOCTYPE pod PUBLIC "-//Sean Michael Burke//DTD PXML 0.01//EN"},
        qq{ "$XMLNS">},
        qq{<pod xmlns=\"$XMLNS\">},
        "<!-- (translated from pod, by " . __PACKAGE__ . " v$VERSION) -->",
        '',
        '',
      ;

      $post = "</pod>\n";  # harmless newline, I figure.
      
    } elsif($type eq 'for') {
      $out .= "<for target=\"" . xml_attr_escape($it->get_arg) . "\">";
      $out .= xml_escape_maybe_cdata($it->get_text);
      $out .= "</for>\n\n";
      return;
      
    } elsif($type eq 'sequence') {
      $type = lc($it->get_letter);
      DEBUG and print "Sequence type \"$type\"\n";
      if($type eq 'e') {
        # An unresolved entity.
        $x = $it->get_children;
        if($x and @$x ==1 and $x->[0]->get_type eq 'text') {
          $x = $x->[0]->get_text;
          die "Impossible entity name \"$x\"" if $x =~ m/[ \t<>]/s;
            # minimal sanity
          $out .= '&' . $x . ';';
        } else {
          # $out .= '&WHAT;';
          die "Aberrant E<..> content \"", $it->get_deep_text, "\"";
        }
        return;
      } elsif($type eq 'l') {
        # At time of writing, Pod::Tree is less than sterling in its
        #  treatment of L<...> sequences.

        #use Data::Dumper;
        #print "LINK DUMP: {{\n", Dumper($it), "}}\n";
        
        # Some special treatment...
        my $target = $it->get_target || die 'targetless link?';
                
        my($page, $section);
        $out .= "<link";
        $page = xml_attr_escape( $target->get_page );
        $out .= " page=\"$page\"" if length $page;
        $section = xml_attr_escape( $target->get_section );
        $out .= " section=\"$section\"" if length $section;
        $out .= ">";
        
        #if(!$LINK_TEXT_INFER and not(($x = $target->get_children) and @$x)) {
        unless(($x = $target->get_children) and @$x) {
          # There was no gloss (i.e., the bit after the "|").
          if(! $LINK_TEXT_INFER) {
            # subvert the normal processing of children of this sequence.
            $out .= "</link>";
            return;
          } else {
            # Infer the text instead.
            my $ch;
            if(($ch = $it->get_children) and @$ch == 1
               and $ch->[0]->get_type eq 'text'
            ) {
              # So this /is/ just some text bit that Pod::Tree implicated.

              # To replicate Pod::Text's inscrutible weirdness as
              #  best we can, for sake of continuity if not actual
              #  good sense or clarity.

              # The moral of the story is to always have L<text|...> !!!

              $x = '';
              if (!length $section) {

lib/Pod/PXML.pm  view on Meta::CPAN

              } else {
                  $section =~ s/^\"\s*//;
                  $section =~ s/\s*\"$//;
                  $x .= 'the section on "' . $section . '"';
                  $x .= " in the $page manpage" if length $page;
              }
              $out .= "$x</link>";
              return; # subvert the usual processing.
            }
             # Else it's complicated and scary.  Fall thru.
          }
        }
        $post = '</link>';
        
      } else {
        # Unknown sequence.  Ahwell, pass thru.
        $out .= "<$type>";
        $post = "</$type>";
      }
    } elsif($type eq 'list') {
      $x = xml_attr_escape($it->get_arg);
      $out .= length($x) ? "<list indent=\"$x\">\n\n" : "<list>\n\n";

      # used to have:
      #   sprintf "<list type=\"%s\" indent=\"%s\">\n\n",
      #     xml_attr_escape($it->get_list_type),
      #     xml_attr_escape($it->get_arg) ;

      $post = "</list>\n\n";

    } elsif($type eq 'ordinary') {
      $out .= "<p>";
      $post = "</p>\n\n";

    } elsif($type eq 'command') {
      $x = $it->get_command();
      if($x =~ m/^head[1234]$/is) {
        $x = lc($x);
        $out .= "<$x>";
        $post = "</$x>\n\n";
      } else {
        die "Unknown POD command \"$x\"";
      }
      
    } elsif($type eq 'item') {
      # Needs special recursion!
      $out .= '<item>';
      # used to have: sprintf '<item type="%s">',
      #           xml_attr_escape($it->get_item_type);

      # Recurse for the item's children:
      foreach my $c (@{ $it->get_children || $nil }) { $trav->($c) }
      $out .= "</item>\n\n";

      # Then recurse for the bastards further down...
      
    } elsif($type eq 'verbatim') {
      ( $FUSE_ADJACENT_PRES and $out =~ s/<\/pre>\n\n$//s )
       or $out .= "<pre>";
       # possibly combine adjacent verbatims into a single 'pre'
      $out .= xml_escape_maybe_cdata("\n" . $it->get_text . "\n");
      $out =~ s/]]><!\[CDATA\[// if $out =~ m/]]>$/s;
       # combining adjacent CDATA sections is nice, and always harmless
      $out .= "</pre>\n\n";
      return;
      
    } elsif($type eq 'text') {
      $out .= xml_escape($it->get_text);
      return;
      
    } else {
      $out .= "\n<!-- unknown podtree node type \"$type\" -->\n";
      return;
    }

    foreach my $c (@{    # Recurse...
      (($type eq 'item') ? $it->get_siblings() : $it->get_children())
      || $nil
    }) { $trav->($c) }

    $out .= $post;
    return;
  };
  $trav->($root);
  undef $trav;  # break cyclicity
  print "\n\n" if DEBUG;

  sanitize_newlines($out);

  return $out;
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

sub xml_escape_maybe_cdata {  # not destructive
  my $x;
  $x = '' unless defined($x = $_[0]);
  if($x =~ m/[&<>]/ and not $x =~ m/[^\x00-\x80]/) {
    # CDATA only if uses those [&<>], and does not use anything highbit.
    $x =~ s/]]>/]]>]]&gt;<!\[CDATA\[/g;  # "escape" any ]]'s
    $x = "<![CDATA[" . $x . "]]>";
  } else {
    # Otherwise escape things.
    $x =~ s/&/&amp;/g;
    $x =~ s/</&lt;/g;
    $x =~ s/>/&gt;/g;
    
    #$x =~ s/([^\x00-\x7E])/$Char2xmlent{ord $1} or "&#".ord($1).";"/eg;
    $x =~ s/([^\x00-\x7E])/"&#".ord($1).";"/eg unless $HIGH_BIT_OK;
    
    # Why care about highbittyness?  Even tho we're declaring this content
    #  to be in UTF8, might as well entitify what we can.
  }
  return $x;
}

sub xml_escape {  # not destructive
  my $x;
  return '' unless defined($x = $_[0]);
  if($HIGH_BIT_OK) {
    $x =~ s/([&<>])/$Char2xmlent{ord $1} or "&#".ord($1).";"/eg;
       # Encode '&', and '<' and '>'
  } else {
    $x =~ s/([^\cm\cj\f\t !-%'-;=?-~])/$Char2xmlent{ord $1} or "&#".ord($1).";"/eg;
       # Encode control chars, high bit chars, '&', and '<' and '>'
  }
  return $x;
}

sub xml_attr_escape {  # not destructive
  my $x;
  return '' unless defined($x = $_[0]);

  if($HIGH_BIT_OK) {
    $x =~ s/([&<>"])/$Char2xmlent{ord $1} or "&#".ord($1).";"/eg;
       # Encode '&', '"', and '<' and '>'
  } else {
    $x =~ s/([^\cm\cj\f\t !\#-\%'-;=?-~])/$Char2xmlent{ord $1} or "&#".ord($1).";"/eg;
       # Encode control chars, high bit chars, '"', '&', and '<' and '>'
  }
  return $x;
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub sanitize_newlines {   # DESTRUCTIVE
  if("\n" eq "\cm") {
    $_[0] =~ s/\cm?\cj/\n/g;  # turn \cj and \cm\cj into \n
  } elsif("\n" eq "\cj") {
    $_[0] =~ s/\cm\cj/\n/g;  # turn \cm and \cm\cj into \n
  } else {
    $_[0] =~ s/(?:(?:\cm?\cj)|\cm)/\n/g;
      # turn \cm\cj, \cj, or \cm  into \n
  }
  return;
}

###########################################################################
###########################################################################

use vars qw(%Acceptable_children);
{
  # This just recapitulates what's in the DTD:
  my $style  = {map{;$_,1} qw(b   i   c   x   f   s   link)};
  my $pstyle = {'#PCDATA',1, %$style};
  my $pcdata = {'#PCDATA',1};
  %Acceptable_children = (
   'pod'  => {map{;$_,1} qw(head1 head2 head3 head4 p pre list for)},
   map(($_=>$pstyle), qw(head1 head2 head3 head4 p)),
   'pre'  => $pcdata,
   'list' => {map{;$_,1} qw(item p pre list for)},
   'item' => $pstyle,
   'for' => $pcdata,
   map(($_=>$pstyle), qw(link b i c f x s)),
  );
}

sub xml2pod ($) {
  my $content = $_[0];
  require XML::Parser;
  
  my $out;
  my($gi, %attr, $text, $cm_set); # scratch
  
  my(@stack);
  my @paragraph_stack;
    # pop/pushed only by paragraph-containing elements, and link
  my @for_stack;  # kept by 'for' elements
  my @link_stack;   # kept by 'link' elements
  my $xml = XML::Parser->new( 'Handlers' => {

     ##
    ##
    ## On the way in...
    
    'Start' => sub {
      (undef, $gi, %attr) = @_;
      push @stack, $gi;
      DEBUG > 1 and print ' ', join('.', @stack), "+\n";
      
      if($XML_VALIDATE) {
        if(@stack < 2) {
          unless($gi eq 'pod') {
            # I think XML::Parser would catch this, but anyway.
            die "Can't have a childless \"$gi\" element, in $content";
          }
        } elsif(defined($cm_set = $Acceptable_children{$stack[-2]})) {
          die "Can't have a \"$gi\" in a \"$stack[-2]\", in $content (stack @stack)"
           unless $cm_set->{$gi};
        } else {
          die "Unknown element \"$gi\"";
        }
        # TODO: attribute validation!
      }
      
      if($gi =~ m/^[bicxfs]$/s) {
        $paragraph_stack[-1] .= "\U$gi<";
      } elsif($gi eq 'p' or $gi eq 'pre') {
        push @paragraph_stack, '';
      } elsif($gi eq 'for') {
        $text = $attr{'target'} || '????';
        push @for_stack, $text;
        push @paragraph_stack, '';
      } elsif($gi eq 'list') {
        $text = $attr{'indent'};
        $out .= (defined($text) && length($text))
                 ? "=over $text\n\n" : "=over\n\n";
      } elsif($gi eq 'item') {
        $out .= '=item ';
        push @paragraph_stack, '';
      } elsif($gi =~ m/^head[1234]$/s) {
        push @paragraph_stack, '=' . $gi . ' ';
      } elsif($gi eq 'link') {  # a hack