maint/synopsis-extractor

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use FindBin qw($Bin);
   7 use File::Find;
   8 use File::Spec;
   9
  10 sub slurp_file {
  11     local (@ARGV, $/) = ($_[0]); <>
  12 }
  13
  14 sub extract_synopsis {
  15     my $string = shift || return;
  16     my $head_or_cut = qr[head|cut]x;
  17     if($string=~m/^=head1 SYNOPSIS\n(.*?)^=$head_or_cut/sm) {
  18         my $extracted = $1;
  19         my $begin_end = qr[begin|end]x;
  20         $extracted=~s/\n^=$begin_end testinfo\n\n//smg; # remove test block
  21         $extracted=~s/^\S.+?$//smg; # wipe out non code lines in pod
  22         return $extracted;
  23     } else {
  24         return;
  25     }
  26 }
  27
  28 sub normalize_indent {
  29     my $extracted = shift || return;
  30         if($extracted=~m/([ \t]+)(\S+)/) {
  31         $extracted=~s/^$1//gsm;
  32         return $extracted;
  33     } else {
  34         return;
  35     }
  36 }
  37
  38 sub create_test_string {
  39     my $extracted = shift || return;
  40     return <<TEST
  41 use strict;
  42 use warnings FATAL => 'all';
  43 use Test::More qw(no_plan);
  44 $extracted
  45 TEST
  46 }
  47
  48 sub create_test_path_from_lib {
  49     my $module_name = shift;
  50     $module_name =~s/\.pm$//;
  51     return File::Spec->catfile($Bin, '..', 't', 'synopsis', lc($module_name).'.t');
  52 }
  53
  54 sub create_or_update_test_file {
  55     my ($target, $synopsis_string) = @_;
  56     return unless $synopsis_string && $target;
  57     print "Writing $target\n";
  58     open my $syn_test, '>', $target
  59       or die "Couldn't open $target - you screwed something up. Go fix it.\n";
  60     print $syn_test $synopsis_string;
  61 }
  62
  63 sub wanted {
  64     my $target_path =
  65         create_test_path_from_lib $_;
  66     my $synopsis_string =
  67         create_test_string
  68         normalize_indent
  69         extract_synopsis
  70         slurp_file $File::Find::name;
  71     create_or_update_test_file
  72         $target_path,
  73         $synopsis_string,
  74 }
  75
  76 find(\&wanted, File::Spec->catfile($Bin, '..', 'lib'));
  77