| 1 | # Testing of Pod::Find |
| 2 | # Author: Marek Rouchal <marek@saftsack.fs.uni-bayreuth.de> |
| 3 | |
| 4 | $| = 1; |
| 5 | |
| 6 | BEGIN { |
| 7 | if ($^O eq 'VMS') { |
| 8 | print "1..0 # needs upstream patch from https://rt.cpan.org/Ticket/Display.html?id=55121"; |
| 9 | exit 0; |
| 10 | } |
| 11 | } |
| 12 | |
| 13 | use Test::More tests => 4; |
| 14 | |
| 15 | BEGIN { |
| 16 | # 1. load successful |
| 17 | use_ok('Pod::Find', qw(pod_find pod_where)); |
| 18 | } |
| 19 | |
| 20 | use File::Spec; |
| 21 | |
| 22 | require Cwd; |
| 23 | my $THISDIR = Cwd::cwd(); |
| 24 | my $VERBOSE = $ENV{PERL_CORE} ? 0 : ($ENV{TEST_VERBOSE} || 0); |
| 25 | my $lib_dir = File::Spec->catdir($THISDIR,'lib'); |
| 26 | |
| 27 | my $vms_unix_rpt = 0; |
| 28 | my $vms_efs = 0; |
| 29 | my $unix_mode = 1; |
| 30 | |
| 31 | if ($^O eq 'VMS') { |
| 32 | $lib_dir = VMS::Filespec::unixify(File::Spec->catdir($THISDIR,'-','lib','pod')); |
| 33 | $Qlib_dir = $lib_dir; |
| 34 | $Qlib_dir =~ s#\/#::#g; |
| 35 | |
| 36 | $unix_mode = 0; |
| 37 | if (eval 'require VMS::Feature') { |
| 38 | $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); |
| 39 | $vms_efs = VMS::Feature::current("efs_charset"); |
| 40 | } else { |
| 41 | my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; |
| 42 | my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; |
| 43 | $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; |
| 44 | $vms_efs = $efs_charset =~ /^[ET1]/i; |
| 45 | } |
| 46 | |
| 47 | # Traditional VMS mode only if VMS is not in UNIX compatible mode. |
| 48 | $unix_mode = ($vms_efs && $vms_unix_rpt); |
| 49 | } |
| 50 | |
| 51 | print "### 2. searching $lib_dir\n"; |
| 52 | my %pods = pod_find($lib_dir); |
| 53 | my $result = join(',', sort values %pods); |
| 54 | print "### found $result\n"; |
| 55 | my $compare = join(',', sort qw( |
| 56 | Pod::Checker |
| 57 | Pod::Find |
| 58 | Pod::InputObjects |
| 59 | Pod::ParseUtils |
| 60 | Pod::Parser |
| 61 | Pod::PlainText |
| 62 | Pod::Select |
| 63 | Pod::Usage |
| 64 | )); |
| 65 | if ($^O eq 'VMS') { |
| 66 | $compare = lc($compare); |
| 67 | my $undollared = $Qlib_dir; |
| 68 | $undollared =~ s/\$/\\\$/g; |
| 69 | $undollared =~ s/\-/\\\-/g; |
| 70 | $result =~ s/$undollared/pod::/g; |
| 71 | $result =~ s/\$//g; |
| 72 | my $count = 0; |
| 73 | my @result = split(/,/,$result); |
| 74 | my @compare = split(/,/,$compare); |
| 75 | foreach(@compare) { |
| 76 | $count += grep {/$_/} @result; |
| 77 | } |
| 78 | is($count/($#result+1)-1,$#compare); |
| 79 | } |
| 80 | elsif (File::Spec->case_tolerant || $^O eq 'dos') { |
| 81 | is(lc $result,lc $compare); |
| 82 | } |
| 83 | else { |
| 84 | is($result,$compare); |
| 85 | } |
| 86 | |
| 87 | print "### 3. searching for File::Find\n"; |
| 88 | $result = pod_where({ -inc => 1, -verbose => $VERBOSE }, 'File::Find') |
| 89 | || 'undef - pod not found!'; |
| 90 | print "### found $result\n"; |
| 91 | |
| 92 | require Config; |
| 93 | if ($^O eq 'VMS') { # privlib is perl_root:[lib] OK but not under mms |
| 94 | if ($unix_mode) { |
| 95 | $compare = "../lib/File/Find.pm"; |
| 96 | } else { |
| 97 | $compare = "lib.File]Find.pm"; |
| 98 | } |
| 99 | $result =~ s/perl_root:\[\-?\.?//i; |
| 100 | $result =~ s/\[\-?\.?//i; # needed under `mms test` |
| 101 | is($result,$compare); |
| 102 | } |
| 103 | else { |
| 104 | $compare = $ENV{PERL_CORE} ? |
| 105 | File::Spec->catfile(File::Spec->updir, File::Spec->updir, 'lib','File','Find.pm') |
| 106 | : File::Spec->catfile($Config::Config{privlibexp},"File","Find.pm"); |
| 107 | my $resfile = _canon($result); |
| 108 | my $cmpfile = _canon($compare); |
| 109 | if($^O =~ /dos|win32/i && $resfile =~ /~\d(?=\\|$)/) { |
| 110 | # we have ~1 short filenames |
| 111 | $resfile = quotemeta($resfile); |
| 112 | $resfile =~ s/\\~\d(?=\\|$)/[^\\\\]+/g; |
| 113 | ok($cmpfile =~ /^$resfile$/, "pod_where found File::Find (with long filename matching)") || |
| 114 | diag("'$cmpfile' does not match /^$resfile\$/"); |
| 115 | } else { |
| 116 | is($resfile,$cmpfile,"pod_where found File::Find"); |
| 117 | } |
| 118 | } |
| 119 | |
| 120 | # Search for a documentation pod rather than a module |
| 121 | my $searchpod = 'Stuff'; |
| 122 | print "### 4. searching for $searchpod.pod\n"; |
| 123 | $result = pod_where( |
| 124 | { -dirs => [ File::Spec->catdir( qw(t), 'pod', 'testpods', 'lib', 'Pod') ], |
| 125 | -verbose => $VERBOSE }, $searchpod) |
| 126 | || "undef - $searchpod.pod not found!"; |
| 127 | print "### found $result\n"; |
| 128 | |
| 129 | $compare = File::Spec->catfile( |
| 130 | qw(t), 'pod', 'testpods', 'lib', 'Pod' ,'Stuff.pm'); |
| 131 | is(_canon($result),_canon($compare)); |
| 132 | |
| 133 | |
| 134 | # make the path as generic as possible |
| 135 | sub _canon |
| 136 | { |
| 137 | my ($path) = @_; |
| 138 | $path = File::Spec->canonpath($path); |
| 139 | my @comp = File::Spec->splitpath($path); |
| 140 | my @dir = File::Spec->splitdir($comp[1]); |
| 141 | $comp[1] = File::Spec->catdir(@dir); |
| 142 | $path = File::Spec->catpath(@comp); |
| 143 | $path = uc($path) if File::Spec->case_tolerant; |
| 144 | print "### general path: $path\n" if $VERBOSE; |
| 145 | $path; |
| 146 | } |
| 147 | |