tools/PM-Pod2html-snippet.pl

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