Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

perldeltas - every perl*delta in one file

by Anonymous Monk
on Feb 12, 2011 at 23:14 UTC ( [id://887804]=CUFP: print w/replies, xml ) Need Help??

Save as perldeltas.pl, run, then open pod/perldeltas.html
#!/usr/bin/perl -- use strict; use warnings; use File::Spec; use File::Basename qw' dirname '; use autodie qw' chdir mkdir open close '; use LWP 5.837; use LWP::Simple 5.835 qw' mirror $ua '; use Getopt::Long::Descriptive qw' describe_options '; ## pick your poison, HTMLLegacy is better #~ use Pod::Html qw' pod2html '; use Pod::Simple::HTMLLegacy; BEGIN { *pod2html = *Pod::Simple::HTMLLegacy::pod2html; } our @MIRRORS = ( # only $MIRRORS[0] is used 'http://perl5.git.perl.org/perl.git/blob_plain/blead:/%s', 'https://github.com/mirrors/perl/raw/blead/%s', ); Main( dirname( File::Spec->rel2abs(__FILE__) ), @ARGV ); exit(0); sub Main { chdir shift; Rmain(@_); } sub Rmain { $| = 1; local @ARGV = @_; my ( $opt, $usage ) = describe_options( "$0\n" . "$0 [-r] [-f] [-h] \n", [ 'refresh|r', "downloads pod.lst/perldelta.pod and any new/missin +g deltas" ], [ 'force|f', "force download everything" ], [ 'help|h', "print usage message and exit" ], ); print( $usage->text ), exit if $opt->help; print TimeD(), "\n"; if ( not( -d 'pod' and -w _ ) ) { mkdir 'pod'; $opt->refresh(1); } if ( $opt->refresh or $opt->force ) { $opt->refresh(1); GetMirrorDeltas( $opt->force ); } my $infile = 'pod/perldeltas.pod'; my $outfile = 'pod/perldeltas.html'; if ( $opt->refresh ) { my $pd = GetDeltas(); #~ use DDS; Dump($pd); WritePerldeltas( $pd, $infile, $outfile, ); } ## end if ( $opt->refresh ) print " see every perl*delta in one file SEE $infile SEE $outfile "; } ## end sub Rmain sub WritePerldeltas { my ( $pd, $infile, $outfile ) = @_; print TimeD(), "\n"; print "\n"; { open my $out, '>:encoding(UTF-8)', $infile; print $out "=encoding utf8\n\n=head1 NAME\n\nperldeltas - every"; print $out " perl*delta in one file\n\n=cut\n\n\n"; for my $p (@$pd) { my ( $file, $d ) = @$p; print "\rprocessing $file "; my $parser = PodLinkHeadPrefixer->new( __prefix => "p$d-" ); $parser->parse_from_file( $file, $out ); undef $parser; print $out "\n\n"; } ## end for my $p (@$pd) print "\r" . ( ' ' x 78 ) . "\n"; close $out; } print TimeD(), "\n"; print "pod2html --infile=$infile --outfile=$outfile\n"; pod2html( "--infile=$infile", "--outfile=$outfile", '--title=perldeltas - every perl*delta in one file', ); print TimeD(), "\n"; } ## end sub WritePerldeltas sub GetDeltas { local $MIRRORS[0] = do { $ua->timeout(0.00001); 'http://127.6.6.6:666666666/%s' }; eval { $ua->remove_handler("response_done"); }; GetOrMirrorDeltas(@_); } ## end sub GetDeltas sub GetMirrorDeltas { eval { $ua->remove_handler("response_done"); }; $ua->add_handler( "response_done", sub { my ($res) = @_; my $request = $res->request; print $request->method, 'ing ', $request->uri, ': ', $res->messa +ge, "\n"; return; } ); GetOrMirrorDeltas(@_); } ## end sub GetMirrorDeltas sub GetOrMirrorDeltas { my ($Override) = @_; MirUrlFile( 'pod.lst', 'pod/pod.lst' ); my @del; open my ($lst), 'pod/pod.lst'; while (<$lst>) { if (/^(d)?\s+(perl(\d+)delta)\b/) { my $d = $3; my $file = sprintf( 'pod/%s.pod', $2 ); if ($1) { MirUrlFile( 'pod/perldelta.pod', $file ); } else { $Override || !-f $file and MirUrlFile( $file, $file ); } push @del, [ $file, $d ]; } ## end if (/^(d)?\s+(perl(\d+)delta)\b/) } ## end while (<$lst>) return \@del; } ## end sub GetOrMirrorDeltas sub MirUrlFile { my ( $urlfile, $file ) = @_; mirror( sprintf( $MIRRORS[0], $urlfile ), $file ); } sub TimeD { return scalar localtime; return scalar gmtime; return time - $^T; } BEGIN { package PodLinkHeadPrefixer; use parent qw' Pod::Parser '; sub command { my ( $self, $cmd, $text, $line_num, $pod_para ) = @_; my $d = $self->{__prefix}; if ( ( $cmd =~ /^head/ ) or ( $cmd eq 'item' and $text !~ /^(?:\s*\*|\s*\d+\.)/ ) ) { $pod_para->text("$d$text"); } ## Just treat this like a textblock $self->textblock( $pod_para->raw_text(), $line_num, $pod_para ); } ## end sub command sub interior_sequence { my ( $self, $seq_cmd, $seq_arg, $pod_seq ) = @_; my $raw = $pod_seq->raw_text; if ( $seq_cmd eq 'L' ) { use Pod::ParseLink qw' parselink '; my ( $text, $inferred, $name, $section, $type ) = parselink($seq +_arg); my $d = $self->{__prefix}; if ( $type eq 'pod' ) { if ($name) { # localize if ( $name =~ m!^perl(\d+)delta(?:.pod)?$! ) { $section = "p${1}-" . ( $section || 'NAME' ); $name = ""; } } else { # local link $section = "$d$section"; } if ( $section and not $name ) { $raw = 'L' . $pod_seq->left_delimiter . ( $text ? "$text|" : "" ) . ( $name || "" ) . ( $section ? qq!/"$section"! : "" ) . $pod_seq->right_delimiter; } ## end if ( $section and not ...) } ## end if ( $type eq 'pod' ) } ## end if ( $seq_cmd eq 'L' ) return $raw; } ## end sub interior_sequence $INC{'PodLinkHeadPrefixer.pm'} = __FILE__; # true } ## end BEGIN
Needs autodie LWP LWP::Simple Getopt::Long::Descriptive Pod::Parser Pod::ParseLink Pod::Simple::HTMLLegacy

Replies are listed 'Best First'.
Re: perldeltas - every perl*delta in one file
by Anonymous Monk on Apr 26, 2011 at 11:18 UTC
Re: perldeltas - every perl*delta in one file
by Anonymous Monk on Dec 06, 2011 at 11:03 UTC

    LOL, LOGIC BUG, Getopt::Long::Descriptive::Opts offers only accessors not mutators

    It works on first run, but the switches (refresh , force) don't. For updates, simply delete output directory before running.

    What perldeltas does is rewrite the links and headers, to add the perl version name, so the links work. Example from L</NAME> to L</p5136-NAME>.

Re: perldeltas - every perl*delta in one file (pod.lst)
by Anonymous Monk on Apr 11, 2013 at 02:51 UTC

    since pod.lst is no longer available, updated to work with MANIFEST and perl.pod . Code in spoiler tags.

    #!/usr/bin/perl -- use strict; use warnings; use File::Spec; use File::Basename qw' dirname '; use autodie qw' chdir mkdir open close '; use LWP 5.837; use LWP::Simple 5.835 qw' mirror $ua '; use Getopt::Long::Descriptive qw' describe_options '; use Data::Dump qw/ dd pp /; ## pick your poison, HTMLLegacy is better #~ use Pod::Html qw' pod2html '; use Pod::Simple::HTMLLegacy; BEGIN { *pod2html = *Pod::Simple::HTMLLegacy::pod2html; } our @MIRRORS = ( # only $MIRRORS[0] is used 'http://perl5.git.perl.org/perl.git/blob_plain/blead:/%s', 'https://github.com/mirrors/perl/raw/blead/%s', ); Main( dirname( File::Spec->rel2abs( __FILE__ ) ), @ARGV ); exit( 0 ); sub Main { chdir shift; #~ dd DeltasOrder(); Rmain( @_ ); } sub Rmain { $| = 1; local @ARGV = @_; my( $opt, $usage ) = describe_options( "$0\n" . "$0 [-r] [-f] [-h] \n", [ 'refresh|r', "downloads pod.lst/perldelta.pod and any new/missing delta +s" ], [ 'force|f', "force download everything" ], [ 'pdeltaforce|p', "write pod/perldeltas.* for sure" ], [ 'help|h', "print usage message and exit" ], ); print( $usage->text ), exit if $opt->help; print TimeD(), "\n"; if( not( -d 'pod' and -w _ ) ) { mkdir 'pod'; $opt->mu( 'refresh', 1 ); } if( $opt->refresh or $opt->force ) { $opt->mu( 'refresh', 1 ); GetMirrorDeltas( $opt->force ); } my $infile = 'pod/perldeltas.pod'; my $outfile = 'pod/perldeltas.html'; if( $opt->refresh or $opt->pdeltaforce ) { my $pd = GetDeltas(); #~ use DDS; Dump($pd); WritePerldeltas( $pd, $infile, $outfile, ); } print " see every perl*delta in one file SEE $infile SEE $outfile "; } ## end sub Rmain sub WritePerldeltas { my( $pd, $infile, $outfile ) = @_; print TimeD(), "\n"; print "\n"; { open my $out, '>:encoding(UTF-8)', $infile; print $out "=encoding utf8\n\n=head1 NAME\n\nperldeltas - ever +y"; print $out " perl*delta in one file\n\n=cut\n\n\n"; for my $p ( @$pd ) { my( $file, $d ) = @$p; print "\rprocessing $file "; my $parser = PodLinkHeadPrefixer->new( __prefix => "p$d-" +); $parser->parse_from_file( $file, $out ); undef $parser; print $out "\n\n"; } ## end for my $p (@$pd) print "\r" . ( ' ' x 78 ) . "\n"; close $out; } print TimeD(), "\n"; print "pod2html --infile=$infile --outfile=$outfile\n"; pod2html( "--infile=$infile", "--outfile=$outfile", '--title=perldeltas - every perl*delta in one file', ); print TimeD(), "\n"; } ## end sub WritePerldeltas sub GetDeltas { local $MIRRORS[0] = #~ do { $ua->timeout(0.00001); 'http://127.6.6.6:666666666/%s' }; do { $ua->timeout( 0.00000001 ); 'file:%s' }; eval { $ua->remove_handler( "response_done" ); }; GetOrMirrorDeltas( @_ ); } sub GetMirrorDeltas { eval { $ua->remove_handler( "response_done" ); }; $ua->add_handler( "response_done", sub { my( $res ) = @_; my $request = $res->request; print $request->method, 'ing ', $request->uri, ': ', $res- +>message, "\n"; return; } ); GetOrMirrorDeltas( @_ ); } ## end sub GetMirrorDeltas sub MirUrlFile { my( $urlfile, $file ) = @_; mirror( sprintf( $MIRRORS[0], $urlfile ), $file ); } sub TimeD { return scalar localtime; return scalar gmtime; return time - $^T; } BEGIN { package PodLinkHeadPrefixer; use parent qw' Pod::Parser '; sub command { my( $self, $cmd, $text, $line_num, $pod_para ) = @_; my $d = $self->{__prefix}; if( ( $cmd =~ /^head/ ) or( $cmd eq 'item' and $text !~ /^(?:\s*\*|\s*\d+\.)/ ) ) { $pod_para->text( "$d$text" ); } ## Just treat this like a textblock $self->textblock( $pod_para->raw_text(), $line_num, $pod_para +); } ## end sub command sub interior_sequence { my( $self, $seq_cmd, $seq_arg, $pod_seq ) = @_; my $raw = $pod_seq->raw_text; if( $seq_cmd eq 'L' ) { use Pod::ParseLink qw' parselink '; my( $text, $inferred, $name, $section, $type ) = parselink( $seq_arg ); my $d = $self->{__prefix}; if( $type eq 'pod' ) { if( $name ) { # localize if( $name =~ m!^perl(\d+)delta(?:.pod)?$! ) { $section = "p${1}-" . ( $section || 'NAME' ); $name = ""; } } else { # local link $section = "$d$section"; } if( $section and not $name ) { $raw = 'L' . $pod_seq->left_delimiter . ( $text ? "$text|" : "" ) . ( $name || "" ) . ( $section ? qq!/"$section"! : "" ) . $pod_seq->right_delimiter; } } ## end if( $type eq 'pod' ) } ## end if( $seq_cmd eq 'L' ) return $raw; } ## end sub interior_sequence $INC{'PodLinkHeadPrefixer.pm'} = __FILE__; # true } ## end BEGIN sub GetOrMirrorDeltas { my( $Override ) = @_; MirUrlFile( 'MANIFEST', 'pod/MANIFEST' ); MirUrlFile( 'pod/perl.pod', 'pod/perl.pod' ); open my( $lst ), 'pod/MANIFEST'; while( <$lst> ) { if( m{^(pod/perl(\d*)delta\.pod)\b} ) { my( $file, $d ) = ( $1, $2 ); $Override || !-f $file and MirUrlFile( $file, $file ); } } return DeltasOrder(); } ## end sub GetOrMirrorDeltas sub Getopt::Long::Descriptive::Opts::mu { package Getopt::Long::Descriptive::Opts; my( $self, $opt, @newval ) = @_; $self->can( $opt ) or Carp::croak "unrecognized $opt "; my $currval = $self->$opt; if( @newval ) { $self->{$opt} = @newval == 1 ? $newval[0] : \@newval; } return $currval; } ## end sub Getopt::Long::Descriptive::Opts::mu sub DeltasOrder { my @del; open my( $in ), '<', 'pod/perl.pod'; while( <$in> ) { /^\s+(perl(\d+)delta)\b/ and push @del, [ 'pod/' . $1 . '.pod', $2 ]; } close $in; open $in, '<', 'pod/perldelta.pod'; while( <$in> ) { if( /^perldelta - what is new for perl v(\S+)\s*$/m ) { my $first = $1; $first =~ s/\D//g; unshift @del, [ 'pod/perldelta.pod', $first ]; } } return \@del; } ## end sub DeltasOrder
A reply falls below the community's threshold of quality. You may see it by logging in.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://887804]
Approved by Corion
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others scrutinizing the Monastery: (5)
As of 2024-03-19 08:08 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found