tools/PM-Pod2html-snippet.pl

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5 use Carp;
   6 use Pod::Xhtml;
   7 use File::Copy;
   8 use File::Spec::Functions qw(rel2abs splitpath splitdir catpath catdir catfile canonpath);
   9
  10 my $input_path      = 'C:/SDL_perl/lib/pods';
  11    $input_path   = $ARGV[0] if $ARGV[0];
  12
  13 my ($volume, $dirs) = splitpath(rel2abs(__FILE__));
  14 my @directories     = splitdir(canonpath($dirs));
  15 pop(@directories);
  16 my $parent_dir      = catpath($volume, catdir(@directories));
  17 my $pages_path      = catdir($parent_dir, 'pages');
  18 my $assets_path     = catdir($parent_dir, 'htdocs/assets');
  19 my $parser          = Pod::Xhtml->new(FragmentOnly => 1, StringMode => 1, LinkParser => new LinkResolver());
  20 my %module_names    = ();
  21 my %thumbnails      = ();
  22 my %files           = ();
  23 my $fh;
  24
  25 read_file($input_path);
  26
  27 # creating index file
  28 open($fh, '>', File::Spec->catfile($pages_path, 'documentation.html-inc'));
  29 binmode($fh, ":utf8");
  30 print($fh "<div class=\"pod\">\n<h1>Documentation (latest development branch)</h1>");
  31 my $last_section = '';
  32 #for my $module_name (sort keys %module_names)
  33 for my $key (sort keys %files)
  34 {
  35         my $icon = defined $files{$key}{'thumb'}
  36                  ? sprintf('<img src="assets/%s" alt="thumb" />', $files{$key}{'thumb'})
  37                  : sprintf('<img src="assets/bubble-%d-mini.png" alt="thumb" />', int((rand() * 7) + 1));
  38
  39         my @matches = ( $files{$key}{'section'} =~ m/\w+/xg );
  40
  41         if($#matches)
  42         {
  43                 my $section_path = '';
  44                 my $doit = 1;
  45
  46                 for my $section (@matches)
  47                 {
  48                         last if $section eq $matches[$#matches];
  49
  50                         $section_path .= (length($section_path) ? ', ' : '') . $section;
  51
  52                         if($last_section =~ /^$section_path/)
  53                         {
  54                                 $doit = 0;
  55                         }
  56                 }
  57
  58                 if($doit)
  59                 {
  60                         my @this_matches = ( $section_path =~ m/\w+/xg );
  61                         my $i = 0;
  62                         for my $this_section (@this_matches)
  63                         {
  64                                 printf($fh '<table style="margin-left: %dpx; margin-top: 5px"><tr><td colspan="3"><strong style="font-size: 14px">%s</strong></td></tr>',
  65                                                    $i++ * 30, $this_section);
  66                         }
  67                 }
  68         }
  69
  70         if($last_section ne $files{$key}{'section'})
  71         {
  72                 print ($fh '</table>') if $last_section;
  73                 print ($fh '<br />')  if $last_section && !$#matches;
  74                 printf($fh '<table style="margin-left: %dpx; margin-top: 5px"><tr><td colspan="3"><strong style="font-size: 14px">%s</strong></td></tr>',
  75                            $#matches * 30, pop(@matches));
  76                 $last_section = $files{$key}{'section'};
  77         }
  78
  79         $files{$key}{'desc'} =~ s/^[\-\s]*/- / if $files{$key}{'desc'};
  80
  81         printf($fh '<tr><td>%s</td><td><a href="%s">%s</a></td><td>%s</td></tr>',
  82                    $icon, $files{$key}{'path'}, $files{$key}{'name'}, $files{$key}{'desc'});
  83 }
  84 print($fh "</table></div>\n");
  85 close($fh);
  86
  87 sub read_file
  88 {
  89         my $path = shift;
  90         my @files      = <$path/*>;
  91
  92         foreach(@files)
  93         {
  94                 read_file($_) if(-d $_);
  95                 if($_ =~ /\.pod$/i)
  96                 {
  97                         my $key         = '';
  98                         my $file_name   = $_;
  99                            $file_name   =~ s/^$input_path\/*//;
 100                         my $module_name = $file_name;
 101                            $module_name =~ s/\//::/g;
 102                            $module_name =~ s/(\.pm|\.pod)$//i;
 103                            $file_name   =~ s/\//-/g;
 104                            $file_name   =~ s/(\.pm|\.pod)$/.html-inc/i;
 105                         my $file_path   = $file_name;
 106                            $file_path   =~ s/\-inc$//;
 107                            $file_name   = File::Spec->catfile($pages_path, $file_name);
 108                         $parser->parse_from_file($_); #, $file_name);
 109
 110
 111
 112                         $key                    = $parser->asString =~ /<div id="CATEGORY_CONTENT">\s*<p>\s*([^<>]+)\s*<\/p>\s*<\/div>/
 113                                                 ? "$1 $_"
 114                                                 : "UNCATEGORIZED/$_";
 115                         $key                    = " $key" if $key =~ /^Core/;
 116                         $files{$key}{'path'}    = $file_path;
 117                         $files{$key}{'name'}    = $module_name;
 118                         $files{$key}{'desc'}    = $parser->asString =~ /<div id="NAME_CONTENT">\s*<p>\s*[^<>\-]+\-([^<>]+)\s*<\/p>\s*<\/div>/
 119                                                 ? $1
 120                                                 : '';
 121                         $files{$key}{'section'} = $parser->asString =~ /<div id="CATEGORY_CONTENT">\s*<p>\s*([^<>]+)\s*<\/p>\s*<\/div>/
 122                                                 ? $1
 123                                                 : 'UNCATEGORIZED';
 124
 125                         # handling images
 126                         my $image_path  = $_;
 127                            $image_path  =~ s/\.pod$//;
 128                         my @images = <$image_path*>;
 129
 130                         my $image_html = '';
 131
 132                         foreach my $image_file (@images)
 133                         {
 134                                 if($image_file =~ /^($image_path)(_\w+){0,1}\.(jpg|jpeg|png|gif)$/)
 135                                 {
 136                                         my (undef, undef, $image_file_name) = splitpath($image_file);
 137
 138                                         if($image_file_name =~ /_thumb\.(jpg|jpeg|png|gif)$/)
 139                                         {
 140                                                 $files{$key}{'thumb'} = $image_file_name;
 141                                         }
 142                                         else
 143                                         {
 144                                                 $image_html .= sprintf('<a href="assets/%s" target="_blank">'
 145                                                                          . '<img src="assets/%s" style="height: 160px" alt="%s"/>'
 146                                                                      . '</a>', $image_file_name, $image_file_name, $image_file_name);
 147                                         }
 148
 149                                         copy($image_file, File::Spec->catfile($assets_path, $image_file_name));
 150                                 }
 151                         }
 152
 153                         # modifying the html-snippet and insert the images
 154                         my $html = $parser->asString;
 155                            $html =~ s/<!-- INDEX END -->/<!-- INDEX END -->$image_html<hr \/>/ if $image_html;
 156
 157                         open($fh, '>', $file_name);
 158                         binmode($fh, ":utf8");
 159                         print($fh $html);
 160                         close($fh);
 161                 }
 162         }
 163 }
 164
 165 package LinkResolver;
 166 use Pod::ParseUtils;
 167 use base qw(Pod::Hyperlink);
 168
 169 sub new
 170 {
 171         my $class = shift;
 172         my $css = shift;
 173         my $self = $class->SUPER::new();
 174         return $self;
 175 }
 176
 177 sub node
 178 {
 179         my $self = shift;
 180         if($self->SUPER::type() eq 'page')
 181         {
 182                 my $page = $self->SUPER::page();
 183                 my $suff = '';
 184
 185                 if($page =~ /^SDL\b/)
 186                 {
 187                         $page =~ s/::([A-Z]+)/-$1/g;
 188                         $page =~ s/(.*)::(.*)/\/$1.html#$2/;
 189                         $page .= '.html' unless $page =~ /\.html/;
 190
 191                         return $page;
 192                 }
 193                 else
 194                 {
 195                         return "http://search.cpan.org/perldoc?$page";
 196                 }
 197         }
 198         $self->SUPER::node(@_);
 199 }
 200
 201 sub text
 202 {
 203         my $self = shift;
 204         return $self->SUPER::page() if($self->SUPER::type() eq 'page');
 205         $self->SUPER::text(@_);
 206 }
 207
 208 sub type
 209 {
 210         my $self = shift;
 211         return "hyperlink" if($self->SUPER::type() eq 'page');
 212         $self->SUPER::type(@_);
 213 }
 214
 215 1;
 216