perl/demo/pod.pm

   1 #!/usr/bin/perl
   2 use strict;
   3 # ----------------------------------------------------------------------------
   4 # A dummy example to demonstrate perl filters for zebra. This is going to
   5 # extract information from the .pm perl module files.
   6 # ----------------------------------------------------------------------------
   7 package pod;
   8
   9 use IDZebra::Filter;
  10 use IDZebra::Data1;
  11 use Pod::Text;
  12 use Symbol qw(gensym);
  13 our @ISA=qw(IDZebra::Filter);
  14 1;
  15
  16
  17 sub init {
  18     # Initialization code may come here
  19 }
  20
  21 sub process {
  22     my ($self, $d1) = @_;
  23
  24     my $tempfile_in = "/tmp/strucc.in";
  25     my $tempfile_out = "/tmp/strucc.out";
  26     my $parser = Pod::Text->new (sentence => 0, width => 78);
  27
  28     my $r1=$d1->mk_root('pod');
  29     my $root=$d1->mk_tag($r1,'pod');
  30
  31     # Get the input "file handle"
  32     my $inf = $self->get_fh;
  33
  34     # Create a funny output "file handle"
  35     my $outf = gensym;
  36     tie (*$outf,'MemFile');
  37
  38     $parser->parse_from_filehandle ($inf, $outf);
  39
  40     my $section;
  41     my $data;
  42     while(<$outf>) {
  43         chomp;
  44         if (/^([A-Z]+)\s*$/) {
  45             my $ss = $1;
  46             if ($section) {
  47                 my $tag = $d1->mk_tag($root,$section);
  48                 $d1->mk_text($tag,$data) if ($data);
  49             }
  50             $section = $ss;
  51             $data = "";
  52             next;
  53         }
  54         s/^\s+|\s+$//g;
  55         $data.="$_\n";
  56     }
  57
  58     if ($section) {
  59         my $tag = $d1->mk_tag($root,$section);
  60         $d1->mk_text($tag,$data) if ($data);
  61     }
  62     return ($r1);
  63 }
  64
  65 # ----------------------------------------------------------------------------
  66 # Package to collect data as an output file from stupid modules, who can only
  67 # write to files...
  68 # ----------------------------------------------------------------------------
  69 package MemFile;
  70
  71 sub TIEHANDLE {
  72     my $class = shift;
  73     my $self = {};
  74     bless ($self,$class);
  75     $self->{buff} = "";
  76     return ($self);
  77 }
  78
  79 sub PRINT {
  80     my $self = shift;
  81     for (@_) {
  82         $self->{buff} .= $_;
  83     }
  84 }
  85
  86 sub READLINE {
  87     my $self = shift;
  88     my $res;
  89     return (undef) unless ($self->{buff});
  90     ($res,$self->{buff}) = split (/\n/,$self->{buff},2);
  91     return ($res."\n");
  92 }