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     undef $/;
  12     open(my $fh, '<', shift);
  13     if(my $whole_file = <$fh>) {
  14         return $whole_file;
  15     } else {
  16         return;
  17     }
  18 }
  19
  20 sub extract_synopsis {
  21     my $string = shift || return;
  22     my $head_or_cut = qr[head|cut]x;
  23     if($string=~m/^=head1 SYNOPSIS\n(.*?)^=$head_or_cut/sm) {
  24         return $1;
  25     } else {
  26         return;
  27     }
  28 }
  29
  30 sub normalize_indent {
  31     my $extracted = shift || return;
  32
  33     if($extracted=~m/([ \t]+)(\S+)/) {
  34         $extracted=~s/^$1//gsm;
  35         return $extracted;
  36     } else {
  37         return;
  38     }
  39 }
  40
  41 sub create_test_string {
  42     my $extracted = shift || return;
  43     return <<TEST
  44 use strict;
  45 use warnings FATAL => 'all';
  46 use Test::More qw(no_plan);
  47 $extracted
  48 TEST
  49 }
  50
  51 sub create_test_path_from_lib {
  52     my $module_name = shift;
  53     $module_name =~s/\.pm$//;
  54     return File::Spec->catfile($Bin, '..', 't', 'synopsis', lc($module_name).'.t');
  55 }
  56
  57 sub create_or_update_test {
  58     my ($string, $target) = @_;
  59     return unless $string && $target;
  60     print "Writing $target\n";
  61     open my $syn_test, '>', $target
  62       or die "Couldn't open $target - you screwed something up. Go fix it.\n";
  63     print $syn_test $string;
  64 }
  65
  66 find(sub {
  67     return unless $_=~/pm$/;
  68     my $test_string =
  69         create_test_string
  70         normalize_indent
  71         extract_synopsis
  72         slurp_file $File::Find::name;
  73
  74     create_or_update_test(
  75         $test_string,
  76         create_test_path_from_lib($_),
  77     );
  78 }, File::Spec->catfile($Bin, '..', 'lib'));
  79
  80