1898184e3Ssthen# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- 29f11ffb7Safresh1# vim:ts=8:sw=2:et:sta:sts=2:tw=78 3*3d61058aSafresh1package Module::Metadata; # git description: v1.000037-8-g92dec6c 4b8851fccSafresh1# ABSTRACT: Gather package and POD information from perl module files 5898184e3Ssthen 6898184e3Ssthen# Adapted from Perl-licensed code originally distributed with 7898184e3Ssthen# Module-Build by Ken Williams 8898184e3Ssthen 9898184e3Ssthen# This module provides routines to gather information about 10898184e3Ssthen# perl modules (assuming this may be expanded in the distant 11898184e3Ssthen# parrot future to look at other types of modules). 12898184e3Ssthen 13b8851fccSafresh1sub __clean_eval { eval $_[0] } 14898184e3Ssthenuse strict; 156fb12b70Safresh1use warnings; 166fb12b70Safresh1 17*3d61058aSafresh1our $VERSION = '1.000038'; 18898184e3Ssthen 19898184e3Ssthenuse Carp qw/croak/; 20898184e3Ssthenuse File::Spec; 21b8851fccSafresh1BEGIN { 22b8851fccSafresh1 # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl 23b8851fccSafresh1 eval { 24b8851fccSafresh1 require Fcntl; Fcntl->import('SEEK_SET'); 1; 25b8851fccSafresh1 } or *SEEK_SET = sub { 0 } 26b8851fccSafresh1} 27898184e3Ssthenuse version 0.87; 28898184e3SsthenBEGIN { 29898184e3Ssthen if ($INC{'Log/Contextual.pm'}) { 30b8851fccSafresh1 require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs 31b8851fccSafresh1 Log::Contextual->import('log_info', 32b8851fccSafresh1 '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }), 33b8851fccSafresh1 ); 34b8851fccSafresh1 } 35b8851fccSafresh1 else { 36898184e3Ssthen *log_info = sub (&) { warn $_[0]->() }; 37898184e3Ssthen } 38898184e3Ssthen} 39898184e3Ssthenuse File::Find qw(find); 40898184e3Ssthen 41898184e3Ssthenmy $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal 42898184e3Ssthen 436fb12b70Safresh1my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name 446fb12b70Safresh1 [a-zA-Z_] # the first word CANNOT start with a digit 456fb12b70Safresh1 (?: 466fb12b70Safresh1 [\w']? # can contain letters, digits, _, or ticks 476fb12b70Safresh1 \w # But, NO multi-ticks or trailing ticks 486fb12b70Safresh1 )* 496fb12b70Safresh1}x; 506fb12b70Safresh1 516fb12b70Safresh1my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name 526fb12b70Safresh1 \w # the 2nd+ word CAN start with digits 536fb12b70Safresh1 (?: 546fb12b70Safresh1 [\w']? # and can contain letters or ticks 556fb12b70Safresh1 \w # But, NO multi-ticks or trailing ticks 566fb12b70Safresh1 )* 576fb12b70Safresh1}x; 586fb12b70Safresh1 596fb12b70Safresh1my $PKG_NAME_REGEXP = qr{ # match a package name 60b8851fccSafresh1 (?: :: )? # a pkg name can start with arisdottle 616fb12b70Safresh1 $PKG_FIRST_WORD_REGEXP # a package word 626fb12b70Safresh1 (?: 63b8851fccSafresh1 (?: :: )+ ### arisdottle (allow one or many times) 646fb12b70Safresh1 $PKG_ADDL_WORD_REGEXP ### a package word 656fb12b70Safresh1 )* # ^ zero, one or many times 666fb12b70Safresh1 (?: 67b8851fccSafresh1 :: # allow trailing arisdottle 686fb12b70Safresh1 )? 696fb12b70Safresh1}x; 706fb12b70Safresh1 71898184e3Ssthenmy $PKG_REGEXP = qr{ # match a package declaration 72898184e3Ssthen ^[\s\{;]* # intro chars on a line 73898184e3Ssthen package # the word 'package' 74898184e3Ssthen \s+ # whitespace 756fb12b70Safresh1 ($PKG_NAME_REGEXP) # a package name 76898184e3Ssthen \s* # optional whitespace 77898184e3Ssthen ($V_NUM_REGEXP)? # optional version number 78*3d61058aSafresh1 \s* # optional whitespace 79898184e3Ssthen [;\{] # semicolon line terminator or block start (since 5.16) 80898184e3Ssthen}x; 81898184e3Ssthen 82*3d61058aSafresh1my $CLASS_REGEXP = qr{ # match a class declaration (core since 5.38) 83*3d61058aSafresh1 ^[\s\{;]* # intro chars on a line 84*3d61058aSafresh1 class # the word 'class' 85*3d61058aSafresh1 \s+ # whitespace 86*3d61058aSafresh1 ($PKG_NAME_REGEXP) # a package name 87*3d61058aSafresh1 \s* # optional whitespace 88*3d61058aSafresh1 ($V_NUM_REGEXP)? # optional version number 89*3d61058aSafresh1 \s* # optional whitespace 90*3d61058aSafresh1 [;\{] # semicolon line terminator or block start 91*3d61058aSafresh1}x; 92*3d61058aSafresh1 93898184e3Ssthenmy $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name 94898184e3Ssthen ([\$*]) # sigil - $ or * 95898184e3Ssthen ( 96898184e3Ssthen ( # optional leading package name 97b8851fccSafresh1 (?:::|\')? # possibly starting like just :: (a la $::VERSION) 98898184e3Ssthen (?:\w+(?:::|\'))* # Foo::Bar:: ... 99898184e3Ssthen )? 100898184e3Ssthen VERSION 101898184e3Ssthen )\b 102898184e3Ssthen}x; 103898184e3Ssthen 104898184e3Ssthenmy $VERS_REGEXP = qr{ # match a VERSION definition 105898184e3Ssthen (?: 106898184e3Ssthen \(\s*$VARNAME_REGEXP\s*\) # with parens 107898184e3Ssthen | 108898184e3Ssthen $VARNAME_REGEXP # without parens 109898184e3Ssthen ) 110898184e3Ssthen \s* 111b8851fccSafresh1 =[^=~>] # = but not ==, nor =~, nor => 112898184e3Ssthen}x; 113898184e3Ssthen 114898184e3Ssthensub new_from_file { 115898184e3Ssthen my $class = shift; 116898184e3Ssthen my $filename = File::Spec->rel2abs( shift ); 117898184e3Ssthen 118898184e3Ssthen return undef unless defined( $filename ) && -f $filename; 119898184e3Ssthen return $class->_init(undef, $filename, @_); 120898184e3Ssthen} 121898184e3Ssthen 122898184e3Ssthensub new_from_handle { 123898184e3Ssthen my $class = shift; 124898184e3Ssthen my $handle = shift; 125898184e3Ssthen my $filename = shift; 126898184e3Ssthen return undef unless defined($handle) && defined($filename); 127898184e3Ssthen $filename = File::Spec->rel2abs( $filename ); 128898184e3Ssthen 129898184e3Ssthen return $class->_init(undef, $filename, @_, handle => $handle); 130898184e3Ssthen 131898184e3Ssthen} 132898184e3Ssthen 133898184e3Ssthen 134898184e3Ssthensub new_from_module { 135898184e3Ssthen my $class = shift; 136898184e3Ssthen my $module = shift; 137898184e3Ssthen my %props = @_; 138898184e3Ssthen 139898184e3Ssthen $props{inc} ||= \@INC; 140898184e3Ssthen my $filename = $class->find_module_by_name( $module, $props{inc} ); 141898184e3Ssthen return undef unless defined( $filename ) && -f $filename; 142898184e3Ssthen return $class->_init($module, $filename, %props); 143898184e3Ssthen} 144898184e3Ssthen 145898184e3Ssthen{ 146898184e3Ssthen 147898184e3Ssthen my $compare_versions = sub { 148898184e3Ssthen my ($v1, $op, $v2) = @_; 149898184e3Ssthen $v1 = version->new($v1) 150898184e3Ssthen unless UNIVERSAL::isa($v1,'version'); 151898184e3Ssthen 152898184e3Ssthen my $eval_str = "\$v1 $op \$v2"; 153898184e3Ssthen my $result = eval $eval_str; 154898184e3Ssthen log_info { "error comparing versions: '$eval_str' $@" } if $@; 155898184e3Ssthen 156898184e3Ssthen return $result; 157898184e3Ssthen }; 158898184e3Ssthen 159898184e3Ssthen my $normalize_version = sub { 160898184e3Ssthen my ($version) = @_; 161898184e3Ssthen if ( $version =~ /[=<>!,]/ ) { # logic, not just version 162898184e3Ssthen # take as is without modification 163898184e3Ssthen } 164898184e3Ssthen elsif ( ref $version eq 'version' ) { # version objects 165898184e3Ssthen $version = $version->is_qv ? $version->normal : $version->stringify; 166898184e3Ssthen } 167898184e3Ssthen elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots 168898184e3Ssthen # normalize string tuples without "v": "1.2.3" -> "v1.2.3" 169898184e3Ssthen $version = "v$version"; 170898184e3Ssthen } 171898184e3Ssthen else { 172898184e3Ssthen # leave alone 173898184e3Ssthen } 174898184e3Ssthen return $version; 175898184e3Ssthen }; 176898184e3Ssthen 177898184e3Ssthen # separate out some of the conflict resolution logic 178898184e3Ssthen 179898184e3Ssthen my $resolve_module_versions = sub { 180898184e3Ssthen my $packages = shift; 181898184e3Ssthen 182898184e3Ssthen my( $file, $version ); 183898184e3Ssthen my $err = ''; 184898184e3Ssthen foreach my $p ( @$packages ) { 185898184e3Ssthen if ( defined( $p->{version} ) ) { 186898184e3Ssthen if ( defined( $version ) ) { 187898184e3Ssthen if ( $compare_versions->( $version, '!=', $p->{version} ) ) { 188898184e3Ssthen $err .= " $p->{file} ($p->{version})\n"; 189b8851fccSafresh1 } 190b8851fccSafresh1 else { 191898184e3Ssthen # same version declared multiple times, ignore 192898184e3Ssthen } 193b8851fccSafresh1 } 194b8851fccSafresh1 else { 195898184e3Ssthen $file = $p->{file}; 196898184e3Ssthen $version = $p->{version}; 197898184e3Ssthen } 198898184e3Ssthen } 199898184e3Ssthen $file ||= $p->{file} if defined( $p->{file} ); 200898184e3Ssthen } 201898184e3Ssthen 202898184e3Ssthen if ( $err ) { 203898184e3Ssthen $err = " $file ($version)\n" . $err; 204898184e3Ssthen } 205898184e3Ssthen 206898184e3Ssthen my %result = ( 207898184e3Ssthen file => $file, 208898184e3Ssthen version => $version, 209898184e3Ssthen err => $err 210898184e3Ssthen ); 211898184e3Ssthen 212898184e3Ssthen return \%result; 213898184e3Ssthen }; 214898184e3Ssthen 215898184e3Ssthen sub provides { 216898184e3Ssthen my $class = shift; 217898184e3Ssthen 218898184e3Ssthen croak "provides() requires key/value pairs \n" if @_ % 2; 219898184e3Ssthen my %args = @_; 220898184e3Ssthen 221898184e3Ssthen croak "provides() takes only one of 'dir' or 'files'\n" 222898184e3Ssthen if $args{dir} && $args{files}; 223898184e3Ssthen 224898184e3Ssthen croak "provides() requires a 'version' argument" 225898184e3Ssthen unless defined $args{version}; 226898184e3Ssthen 227898184e3Ssthen croak "provides() does not support version '$args{version}' metadata" 228b46d8ef2Safresh1 unless grep $args{version} eq $_, qw/1.4 2/; 229898184e3Ssthen 230898184e3Ssthen $args{prefix} = 'lib' unless defined $args{prefix}; 231898184e3Ssthen 232898184e3Ssthen my $p; 233898184e3Ssthen if ( $args{dir} ) { 234898184e3Ssthen $p = $class->package_versions_from_directory($args{dir}); 235898184e3Ssthen } 236898184e3Ssthen else { 237898184e3Ssthen croak "provides() requires 'files' to be an array reference\n" 238898184e3Ssthen unless ref $args{files} eq 'ARRAY'; 239898184e3Ssthen $p = $class->package_versions_from_directory($args{files}); 240898184e3Ssthen } 241898184e3Ssthen 242898184e3Ssthen # Now, fix up files with prefix 243898184e3Ssthen if ( length $args{prefix} ) { # check in case disabled with q{} 244898184e3Ssthen $args{prefix} =~ s{/$}{}; 245898184e3Ssthen for my $v ( values %$p ) { 246898184e3Ssthen $v->{file} = "$args{prefix}/$v->{file}"; 247898184e3Ssthen } 248898184e3Ssthen } 249898184e3Ssthen 250898184e3Ssthen return $p 251898184e3Ssthen } 252898184e3Ssthen 253898184e3Ssthen sub package_versions_from_directory { 254898184e3Ssthen my ( $class, $dir, $files ) = @_; 255898184e3Ssthen 256898184e3Ssthen my @files; 257898184e3Ssthen 258898184e3Ssthen if ( $files ) { 259898184e3Ssthen @files = @$files; 260b8851fccSafresh1 } 261b8851fccSafresh1 else { 262898184e3Ssthen find( { 263898184e3Ssthen wanted => sub { 264898184e3Ssthen push @files, $_ if -f $_ && /\.pm$/; 265898184e3Ssthen }, 266898184e3Ssthen no_chdir => 1, 267898184e3Ssthen }, $dir ); 268898184e3Ssthen } 269898184e3Ssthen 270898184e3Ssthen # First, we enumerate all packages & versions, 271898184e3Ssthen # separating into primary & alternative candidates 272898184e3Ssthen my( %prime, %alt ); 273898184e3Ssthen foreach my $file (@files) { 274b46d8ef2Safresh1 my $mapped_filename = File::Spec->abs2rel( $file, $dir ); 275b46d8ef2Safresh1 my @path = File::Spec->splitdir( $mapped_filename ); 276898184e3Ssthen (my $prime_package = join( '::', @path )) =~ s/\.pm$//; 277898184e3Ssthen 278898184e3Ssthen my $pm_info = $class->new_from_file( $file ); 279898184e3Ssthen 280898184e3Ssthen foreach my $package ( $pm_info->packages_inside ) { 281898184e3Ssthen next if $package eq 'main'; # main can appear numerous times, ignore 282898184e3Ssthen next if $package eq 'DB'; # special debugging package, ignore 283898184e3Ssthen next if grep /^_/, split( /::/, $package ); # private package, ignore 284898184e3Ssthen 285898184e3Ssthen my $version = $pm_info->version( $package ); 286898184e3Ssthen 28791f110e0Safresh1 $prime_package = $package if lc($prime_package) eq lc($package); 288898184e3Ssthen if ( $package eq $prime_package ) { 289898184e3Ssthen if ( exists( $prime{$package} ) ) { 290898184e3Ssthen croak "Unexpected conflict in '$package'; multiple versions found.\n"; 291b8851fccSafresh1 } 292b8851fccSafresh1 else { 29391f110e0Safresh1 $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename); 294898184e3Ssthen $prime{$package}{file} = $mapped_filename; 295898184e3Ssthen $prime{$package}{version} = $version if defined( $version ); 296898184e3Ssthen } 297b8851fccSafresh1 } 298b8851fccSafresh1 else { 299898184e3Ssthen push( @{$alt{$package}}, { 300898184e3Ssthen file => $mapped_filename, 301898184e3Ssthen version => $version, 302898184e3Ssthen } ); 303898184e3Ssthen } 304898184e3Ssthen } 305898184e3Ssthen } 306898184e3Ssthen 307898184e3Ssthen # Then we iterate over all the packages found above, identifying conflicts 308898184e3Ssthen # and selecting the "best" candidate for recording the file & version 309898184e3Ssthen # for each package. 310898184e3Ssthen foreach my $package ( keys( %alt ) ) { 311898184e3Ssthen my $result = $resolve_module_versions->( $alt{$package} ); 312898184e3Ssthen 313898184e3Ssthen if ( exists( $prime{$package} ) ) { # primary package selected 314898184e3Ssthen 315898184e3Ssthen if ( $result->{err} ) { 316898184e3Ssthen # Use the selected primary package, but there are conflicting 317898184e3Ssthen # errors among multiple alternative packages that need to be 318898184e3Ssthen # reported 319898184e3Ssthen log_info { 320898184e3Ssthen "Found conflicting versions for package '$package'\n" . 321898184e3Ssthen " $prime{$package}{file} ($prime{$package}{version})\n" . 322898184e3Ssthen $result->{err} 323898184e3Ssthen }; 324898184e3Ssthen 325b8851fccSafresh1 } 326b8851fccSafresh1 elsif ( defined( $result->{version} ) ) { 327898184e3Ssthen # There is a primary package selected, and exactly one 328898184e3Ssthen # alternative package 329898184e3Ssthen 330898184e3Ssthen if ( exists( $prime{$package}{version} ) && 331898184e3Ssthen defined( $prime{$package}{version} ) ) { 332898184e3Ssthen # Unless the version of the primary package agrees with the 333898184e3Ssthen # version of the alternative package, report a conflict 334898184e3Ssthen if ( $compare_versions->( 335898184e3Ssthen $prime{$package}{version}, '!=', $result->{version} 336898184e3Ssthen ) 337898184e3Ssthen ) { 338898184e3Ssthen 339898184e3Ssthen log_info { 340898184e3Ssthen "Found conflicting versions for package '$package'\n" . 341898184e3Ssthen " $prime{$package}{file} ($prime{$package}{version})\n" . 342898184e3Ssthen " $result->{file} ($result->{version})\n" 343898184e3Ssthen }; 344898184e3Ssthen } 345898184e3Ssthen 346b8851fccSafresh1 } 347b8851fccSafresh1 else { 348898184e3Ssthen # The prime package selected has no version so, we choose to 349898184e3Ssthen # use any alternative package that does have a version 350898184e3Ssthen $prime{$package}{file} = $result->{file}; 351898184e3Ssthen $prime{$package}{version} = $result->{version}; 352898184e3Ssthen } 353898184e3Ssthen 354b8851fccSafresh1 } 355b8851fccSafresh1 else { 356898184e3Ssthen # no alt package found with a version, but we have a prime 357898184e3Ssthen # package so we use it whether it has a version or not 358898184e3Ssthen } 359898184e3Ssthen 360b8851fccSafresh1 } 361b8851fccSafresh1 else { # No primary package was selected, use the best alternative 362898184e3Ssthen 363898184e3Ssthen if ( $result->{err} ) { 364898184e3Ssthen log_info { 365898184e3Ssthen "Found conflicting versions for package '$package'\n" . 366898184e3Ssthen $result->{err} 367898184e3Ssthen }; 368898184e3Ssthen } 369898184e3Ssthen 370898184e3Ssthen # Despite possible conflicting versions, we choose to record 371898184e3Ssthen # something rather than nothing 372898184e3Ssthen $prime{$package}{file} = $result->{file}; 373898184e3Ssthen $prime{$package}{version} = $result->{version} 374898184e3Ssthen if defined( $result->{version} ); 375898184e3Ssthen } 376898184e3Ssthen } 377898184e3Ssthen 378898184e3Ssthen # Normalize versions. Can't use exists() here because of bug in YAML::Node. 3796fb12b70Safresh1 # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18 380898184e3Ssthen for (grep defined $_->{version}, values %prime) { 381898184e3Ssthen $_->{version} = $normalize_version->( $_->{version} ); 382898184e3Ssthen } 383898184e3Ssthen 384898184e3Ssthen return \%prime; 385898184e3Ssthen } 386898184e3Ssthen} 387898184e3Ssthen 388898184e3Ssthen 389898184e3Ssthensub _init { 390898184e3Ssthen my $class = shift; 391898184e3Ssthen my $module = shift; 392898184e3Ssthen my $filename = shift; 393898184e3Ssthen my %props = @_; 394898184e3Ssthen 395898184e3Ssthen my $handle = delete $props{handle}; 396898184e3Ssthen my( %valid_props, @valid_props ); 39756d68f1eSafresh1 @valid_props = qw( collect_pod inc decode_pod ); 398898184e3Ssthen @valid_props{@valid_props} = delete( @props{@valid_props} ); 399898184e3Ssthen warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); 400898184e3Ssthen 401898184e3Ssthen my %data = ( 402898184e3Ssthen module => $module, 403898184e3Ssthen filename => $filename, 404898184e3Ssthen version => undef, 405898184e3Ssthen packages => [], 406898184e3Ssthen versions => {}, 407898184e3Ssthen pod => {}, 408898184e3Ssthen pod_headings => [], 409898184e3Ssthen collect_pod => 0, 410898184e3Ssthen 411898184e3Ssthen %valid_props, 412898184e3Ssthen ); 413898184e3Ssthen 414898184e3Ssthen my $self = bless(\%data, $class); 415898184e3Ssthen 416b8851fccSafresh1 if ( not $handle ) { 417b8851fccSafresh1 my $filename = $self->{filename}; 418b8851fccSafresh1 open $handle, '<', $filename 419b8851fccSafresh1 or croak( "Can't open '$filename': $!" ); 420b8851fccSafresh1 421b8851fccSafresh1 $self->_handle_bom($handle, $filename); 422b8851fccSafresh1 } 423898184e3Ssthen $self->_parse_fh($handle); 424898184e3Ssthen 4259f11ffb7Safresh1 @{$self->{packages}} = __uniq(@{$self->{packages}}); 4269f11ffb7Safresh1 427898184e3Ssthen unless($self->{module} and length($self->{module})) { 4289f11ffb7Safresh1 # CAVEAT (possible TODO): .pmc files not treated the same as .pm 4299f11ffb7Safresh1 if ($self->{filename} =~ /\.pm$/) { 430898184e3Ssthen my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); 431898184e3Ssthen $f =~ s/\..+$//; 4329f11ffb7Safresh1 my @candidates = grep /(^|::)$f$/, @{$self->{packages}}; 4339f11ffb7Safresh1 $self->{module} = shift(@candidates); # this may be undef 434898184e3Ssthen } 435898184e3Ssthen else { 4369f11ffb7Safresh1 # this seems like an atrocious heuristic, albeit marginally better than 4379f11ffb7Safresh1 # what was here before. It should be rewritten entirely to be more like 4389f11ffb7Safresh1 # "if it's not a .pm file, it's not require()able as a name, therefore 4399f11ffb7Safresh1 # name() should be undef." 4409f11ffb7Safresh1 if ((grep /main/, @{$self->{packages}}) 4419f11ffb7Safresh1 or (grep /main/, keys %{$self->{versions}})) { 442898184e3Ssthen $self->{module} = 'main'; 443898184e3Ssthen } 4449f11ffb7Safresh1 else { 4459f11ffb7Safresh1 # TODO: this should maybe default to undef instead 4469f11ffb7Safresh1 $self->{module} = $self->{packages}[0] || ''; 4479f11ffb7Safresh1 } 4489f11ffb7Safresh1 } 449898184e3Ssthen } 450898184e3Ssthen 451898184e3Ssthen $self->{version} = $self->{versions}{$self->{module}} 452898184e3Ssthen if defined( $self->{module} ); 453898184e3Ssthen 454898184e3Ssthen return $self; 455898184e3Ssthen} 456898184e3Ssthen 457898184e3Ssthen# class method 458898184e3Ssthensub _do_find_module { 459898184e3Ssthen my $class = shift; 460898184e3Ssthen my $module = shift || croak 'find_module_by_name() requires a package name'; 461898184e3Ssthen my $dirs = shift || \@INC; 462898184e3Ssthen 463898184e3Ssthen my $file = File::Spec->catfile(split( /::/, $module)); 464898184e3Ssthen foreach my $dir ( @$dirs ) { 465898184e3Ssthen my $testfile = File::Spec->catfile($dir, $file); 466898184e3Ssthen return [ File::Spec->rel2abs( $testfile ), $dir ] 467898184e3Ssthen if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp 4689f11ffb7Safresh1 # CAVEAT (possible TODO): .pmc files are not discoverable here 469b8851fccSafresh1 $testfile .= '.pm'; 470b8851fccSafresh1 return [ File::Spec->rel2abs( $testfile ), $dir ] 471b8851fccSafresh1 if -e $testfile; 472898184e3Ssthen } 473898184e3Ssthen return; 474898184e3Ssthen} 475898184e3Ssthen 476898184e3Ssthen# class method 477898184e3Ssthensub find_module_by_name { 478898184e3Ssthen my $found = shift()->_do_find_module(@_) or return; 479898184e3Ssthen return $found->[0]; 480898184e3Ssthen} 481898184e3Ssthen 482898184e3Ssthen# class method 483898184e3Ssthensub find_module_dir_by_name { 484898184e3Ssthen my $found = shift()->_do_find_module(@_) or return; 485898184e3Ssthen return $found->[1]; 486898184e3Ssthen} 487898184e3Ssthen 488898184e3Ssthen 489898184e3Ssthen# given a line of perl code, attempt to parse it if it looks like a 490898184e3Ssthen# $VERSION assignment, returning sigil, full name, & package name 491898184e3Ssthensub _parse_version_expression { 492898184e3Ssthen my $self = shift; 493898184e3Ssthen my $line = shift; 494898184e3Ssthen 495b8851fccSafresh1 my( $sigil, $variable_name, $package); 49691f110e0Safresh1 if ( $line =~ /$VERS_REGEXP/o ) { 497b8851fccSafresh1 ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); 498b8851fccSafresh1 if ( $package ) { 499b8851fccSafresh1 $package = ($package eq '::') ? 'main' : $package; 500b8851fccSafresh1 $package =~ s/::$//; 501898184e3Ssthen } 502898184e3Ssthen } 503898184e3Ssthen 504b8851fccSafresh1 return ( $sigil, $variable_name, $package ); 505898184e3Ssthen} 506898184e3Ssthen 50791f110e0Safresh1# Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream. 50891f110e0Safresh1# If there's one, then skip it and set the :encoding layer appropriately. 50991f110e0Safresh1sub _handle_bom { 51091f110e0Safresh1 my ($self, $fh, $filename) = @_; 51191f110e0Safresh1 512b8851fccSafresh1 my $pos = tell $fh; 51391f110e0Safresh1 return unless defined $pos; 51491f110e0Safresh1 51591f110e0Safresh1 my $buf = ' ' x 2; 516b8851fccSafresh1 my $count = read $fh, $buf, length $buf; 51791f110e0Safresh1 return unless defined $count and $count >= 2; 51891f110e0Safresh1 51991f110e0Safresh1 my $encoding; 52091f110e0Safresh1 if ( $buf eq "\x{FE}\x{FF}" ) { 52191f110e0Safresh1 $encoding = 'UTF-16BE'; 522b8851fccSafresh1 } 523b8851fccSafresh1 elsif ( $buf eq "\x{FF}\x{FE}" ) { 52491f110e0Safresh1 $encoding = 'UTF-16LE'; 525b8851fccSafresh1 } 526b8851fccSafresh1 elsif ( $buf eq "\x{EF}\x{BB}" ) { 52791f110e0Safresh1 $buf = ' '; 528b8851fccSafresh1 $count = read $fh, $buf, length $buf; 52991f110e0Safresh1 if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) { 53091f110e0Safresh1 $encoding = 'UTF-8'; 53191f110e0Safresh1 } 53291f110e0Safresh1 } 53391f110e0Safresh1 53491f110e0Safresh1 if ( defined $encoding ) { 53591f110e0Safresh1 if ( "$]" >= 5.008 ) { 53691f110e0Safresh1 binmode( $fh, ":encoding($encoding)" ); 53791f110e0Safresh1 } 538b8851fccSafresh1 } 539b8851fccSafresh1 else { 540b8851fccSafresh1 seek $fh, $pos, SEEK_SET 54191f110e0Safresh1 or croak( sprintf "Can't reset position to the top of '$filename'" ); 54291f110e0Safresh1 } 54391f110e0Safresh1 54491f110e0Safresh1 return $encoding; 54591f110e0Safresh1} 54691f110e0Safresh1 547898184e3Ssthensub _parse_fh { 548898184e3Ssthen my ($self, $fh) = @_; 549898184e3Ssthen 550898184e3Ssthen my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); 551b8851fccSafresh1 my( @packages, %vers, %pod, @pod ); 552b8851fccSafresh1 my $package = 'main'; 553898184e3Ssthen my $pod_sect = ''; 554898184e3Ssthen my $pod_data = ''; 5556fb12b70Safresh1 my $in_end = 0; 55656d68f1eSafresh1 my $encoding = ''; 557898184e3Ssthen 558898184e3Ssthen while (defined( my $line = <$fh> )) { 559898184e3Ssthen my $line_num = $.; 560898184e3Ssthen 561898184e3Ssthen chomp( $line ); 562898184e3Ssthen 56391f110e0Safresh1 # From toke.c : any line that begins by "=X", where X is an alphabetic 56491f110e0Safresh1 # character, introduces a POD segment. 56591f110e0Safresh1 my $is_cut; 56691f110e0Safresh1 if ( $line =~ /^=([a-zA-Z].*)/ ) { 56791f110e0Safresh1 my $cmd = $1; 56891f110e0Safresh1 # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic 56991f110e0Safresh1 # character (which includes the newline, but here we chomped it away). 57091f110e0Safresh1 $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/; 57191f110e0Safresh1 $in_pod = !$is_cut; 57291f110e0Safresh1 } 573898184e3Ssthen 57491f110e0Safresh1 if ( $in_pod ) { 575898184e3Ssthen 57691f110e0Safresh1 if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) { 577898184e3Ssthen push( @pod, $1 ); 578898184e3Ssthen if ( $self->{collect_pod} && length( $pod_data ) ) { 579898184e3Ssthen $pod{$pod_sect} = $pod_data; 580898184e3Ssthen $pod_data = ''; 581898184e3Ssthen } 582898184e3Ssthen $pod_sect = $1; 583898184e3Ssthen } 584b8851fccSafresh1 elsif ( $self->{collect_pod} ) { 58556d68f1eSafresh1 if ( $self->{decode_pod} && $line =~ /^=encoding ([\w-]+)/ ) { 58656d68f1eSafresh1 $encoding = $1; 58756d68f1eSafresh1 } 588b8851fccSafresh1 $pod_data .= "$line\n"; 589b8851fccSafresh1 } 590b8851fccSafresh1 next; 591b8851fccSafresh1 } 592b8851fccSafresh1 elsif ( $is_cut ) { 59391f110e0Safresh1 if ( $self->{collect_pod} && length( $pod_data ) ) { 59491f110e0Safresh1 $pod{$pod_sect} = $pod_data; 59591f110e0Safresh1 $pod_data = ''; 59691f110e0Safresh1 } 59791f110e0Safresh1 $pod_sect = ''; 598b8851fccSafresh1 next; 599b8851fccSafresh1 } 600898184e3Ssthen 6016fb12b70Safresh1 # Skip after __END__ 6026fb12b70Safresh1 next if $in_end; 6036fb12b70Safresh1 60491f110e0Safresh1 # Skip comments in code 60591f110e0Safresh1 next if $line =~ /^\s*#/; 60691f110e0Safresh1 60791f110e0Safresh1 # Would be nice if we could also check $in_string or something too 6086fb12b70Safresh1 if ($line eq '__END__') { 6096fb12b70Safresh1 $in_end++; 6106fb12b70Safresh1 next; 6116fb12b70Safresh1 } 612b8851fccSafresh1 6136fb12b70Safresh1 last if $line eq '__DATA__'; 614898184e3Ssthen 615898184e3Ssthen # parse $line to see if it's a $VERSION declaration 616b8851fccSafresh1 my( $version_sigil, $version_fullname, $version_package ) = 617b8851fccSafresh1 index($line, 'VERSION') >= 1 61891f110e0Safresh1 ? $self->_parse_version_expression( $line ) 61991f110e0Safresh1 : (); 620898184e3Ssthen 621*3d61058aSafresh1 if ( $line =~ /$PKG_REGEXP/o or $line =~ /$CLASS_REGEXP/ ) { 622b8851fccSafresh1 $package = $1; 623b8851fccSafresh1 my $version = $2; 624b8851fccSafresh1 push( @packages, $package ) unless grep( $package eq $_, @packages ); 625b8851fccSafresh1 $need_vers = defined $version ? 0 : 1; 626b8851fccSafresh1 627b8851fccSafresh1 if ( not exists $vers{$package} and defined $version ){ 628b8851fccSafresh1 # Upgrade to a version object. 629b8851fccSafresh1 my $dwim_version = eval { _dwim_version($version) }; 630b8851fccSafresh1 croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" 631b8851fccSafresh1 unless defined $dwim_version; # "0" is OK! 632b8851fccSafresh1 $vers{$package} = $dwim_version; 633b8851fccSafresh1 } 634b8851fccSafresh1 } 635898184e3Ssthen 636898184e3Ssthen # VERSION defined with full package spec, i.e. $Module::VERSION 637b8851fccSafresh1 elsif ( $version_fullname && $version_package ) { 638b8851fccSafresh1 # we do NOT save this package in found @packages 639b8851fccSafresh1 $need_vers = 0 if $version_package eq $package; 640898184e3Ssthen 641b8851fccSafresh1 unless ( defined $vers{$version_package} && length $vers{$version_package} ) { 642b8851fccSafresh1 $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); 643b8851fccSafresh1 } 644898184e3Ssthen } 645898184e3Ssthen 646898184e3Ssthen # first non-comment line in undeclared package main is VERSION 647b8851fccSafresh1 elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) { 648898184e3Ssthen $need_vers = 0; 649b8851fccSafresh1 my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); 650b8851fccSafresh1 $vers{$package} = $v; 651b8851fccSafresh1 push( @packages, 'main' ); 652b8851fccSafresh1 } 653898184e3Ssthen 654898184e3Ssthen # first non-comment line in undeclared package defines package main 655b8851fccSafresh1 elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) { 656898184e3Ssthen $need_vers = 1; 657898184e3Ssthen $vers{main} = ''; 658b8851fccSafresh1 push( @packages, 'main' ); 659b8851fccSafresh1 } 660898184e3Ssthen 661898184e3Ssthen # only keep if this is the first $VERSION seen 662b8851fccSafresh1 elsif ( $version_fullname && $need_vers ) { 663898184e3Ssthen $need_vers = 0; 664b8851fccSafresh1 my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); 665898184e3Ssthen 666b8851fccSafresh1 unless ( defined $vers{$package} && length $vers{$package} ) { 667b8851fccSafresh1 $vers{$package} = $v; 668898184e3Ssthen } 669898184e3Ssthen } 670b8851fccSafresh1 } # end loop over each line 671898184e3Ssthen 672898184e3Ssthen if ( $self->{collect_pod} && length($pod_data) ) { 673898184e3Ssthen $pod{$pod_sect} = $pod_data; 674898184e3Ssthen } 675898184e3Ssthen 67656d68f1eSafresh1 if ( $self->{decode_pod} && $encoding ) { 67756d68f1eSafresh1 require Encode; 67856d68f1eSafresh1 $_ = Encode::decode( $encoding, $_ ) for values %pod; 67956d68f1eSafresh1 } 68056d68f1eSafresh1 681898184e3Ssthen $self->{versions} = \%vers; 682b8851fccSafresh1 $self->{packages} = \@packages; 683898184e3Ssthen $self->{pod} = \%pod; 684898184e3Ssthen $self->{pod_headings} = \@pod; 685898184e3Ssthen} 686898184e3Ssthen 6879f11ffb7Safresh1sub __uniq (@) 6889f11ffb7Safresh1{ 6899f11ffb7Safresh1 my (%seen, $key); 690b46d8ef2Safresh1 grep !$seen{ $key = $_ }++, @_; 6919f11ffb7Safresh1} 6929f11ffb7Safresh1 693898184e3Ssthen{ 694898184e3Ssthenmy $pn = 0; 695898184e3Ssthensub _evaluate_version_line { 696898184e3Ssthen my $self = shift; 697b8851fccSafresh1 my( $sigil, $variable_name, $line ) = @_; 698898184e3Ssthen 699b8851fccSafresh1 # We compile into a local sub because 'use version' would cause 700898184e3Ssthen # compiletime/runtime issues with local() 701898184e3Ssthen $pn++; # everybody gets their own package 702b8851fccSafresh1 my $eval = qq{ my \$dummy = q# Hide from _packages_inside() 703b8851fccSafresh1 #; package Module::Metadata::_version::p${pn}; 704898184e3Ssthen use version; 705b8851fccSafresh1 sub { 706b8851fccSafresh1 local $sigil$variable_name; 707898184e3Ssthen $line; 708b8851fccSafresh1 return \$$variable_name if defined \$$variable_name; 709b8851fccSafresh1 return \$Module::Metadata::_version::p${pn}::$variable_name; 710898184e3Ssthen }; 711b8851fccSafresh1 }; 712898184e3Ssthen 7136fb12b70Safresh1 $eval = $1 if $eval =~ m{^(.+)}s; 7146fb12b70Safresh1 715898184e3Ssthen local $^W; 716898184e3Ssthen # Try to get the $VERSION 717b8851fccSafresh1 my $vsub = __clean_eval($eval); 718b8851fccSafresh1 # some modules say $VERSION <equal sign> $Foo::Bar::VERSION, but Foo::Bar isn't 719898184e3Ssthen # installed, so we need to hunt in ./lib for it 720898184e3Ssthen if ( $@ =~ /Can't locate/ && -d 'lib' ) { 721898184e3Ssthen local @INC = ('lib',@INC); 722b8851fccSafresh1 $vsub = __clean_eval($eval); 723898184e3Ssthen } 724898184e3Ssthen warn "Error evaling version line '$eval' in $self->{filename}: $@\n" 725898184e3Ssthen if $@; 726b8851fccSafresh1 727898184e3Ssthen (ref($vsub) eq 'CODE') or 728898184e3Ssthen croak "failed to build version sub for $self->{filename}"; 729b8851fccSafresh1 730898184e3Ssthen my $result = eval { $vsub->() }; 731b8851fccSafresh1 # FIXME: $eval is not the right thing to print here 732898184e3Ssthen croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" 733898184e3Ssthen if $@; 734898184e3Ssthen 735898184e3Ssthen # Upgrade it into a version object 736898184e3Ssthen my $version = eval { _dwim_version($result) }; 737898184e3Ssthen 738b8851fccSafresh1 # FIXME: $eval is not the right thing to print here 739898184e3Ssthen croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" 740898184e3Ssthen unless defined $version; # "0" is OK! 741898184e3Ssthen 742898184e3Ssthen return $version; 743898184e3Ssthen} 744898184e3Ssthen} 745898184e3Ssthen 746898184e3Ssthen# Try to DWIM when things fail the lax version test in obvious ways 747898184e3Ssthen{ 748898184e3Ssthen my @version_prep = ( 749898184e3Ssthen # Best case, it just works 750898184e3Ssthen sub { return shift }, 751898184e3Ssthen 752898184e3Ssthen # If we still don't have a version, try stripping any 753898184e3Ssthen # trailing junk that is prohibited by lax rules 754898184e3Ssthen sub { 755898184e3Ssthen my $v = shift; 756898184e3Ssthen $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b 757898184e3Ssthen return $v; 758898184e3Ssthen }, 759898184e3Ssthen 760898184e3Ssthen # Activestate apparently creates custom versions like '1.23_45_01', which 761898184e3Ssthen # cause version.pm to think it's an invalid alpha. So check for that 762898184e3Ssthen # and strip them 763898184e3Ssthen sub { 764898184e3Ssthen my $v = shift; 765898184e3Ssthen my $num_dots = () = $v =~ m{(\.)}g; 766898184e3Ssthen my $num_unders = () = $v =~ m{(_)}g; 767898184e3Ssthen my $leading_v = substr($v,0,1) eq 'v'; 768898184e3Ssthen if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) { 769898184e3Ssthen $v =~ s{_}{}g; 770898184e3Ssthen $num_unders = () = $v =~ m{(_)}g; 771898184e3Ssthen } 772898184e3Ssthen return $v; 773898184e3Ssthen }, 774898184e3Ssthen 775898184e3Ssthen # Worst case, try numifying it like we would have before version objects 776898184e3Ssthen sub { 777898184e3Ssthen my $v = shift; 778898184e3Ssthen no warnings 'numeric'; 779898184e3Ssthen return 0 + $v; 780898184e3Ssthen }, 781898184e3Ssthen 782898184e3Ssthen ); 783898184e3Ssthen 784898184e3Ssthen sub _dwim_version { 785898184e3Ssthen my ($result) = shift; 786898184e3Ssthen 787898184e3Ssthen return $result if ref($result) eq 'version'; 788898184e3Ssthen 789898184e3Ssthen my ($version, $error); 790898184e3Ssthen for my $f (@version_prep) { 791898184e3Ssthen $result = $f->($result); 792898184e3Ssthen $version = eval { version->new($result) }; 793898184e3Ssthen $error ||= $@ if $@; # capture first failure 794898184e3Ssthen last if defined $version; 795898184e3Ssthen } 796898184e3Ssthen 797898184e3Ssthen croak $error unless defined $version; 798898184e3Ssthen 799898184e3Ssthen return $version; 800898184e3Ssthen } 801898184e3Ssthen} 802898184e3Ssthen 803898184e3Ssthen############################################################ 804898184e3Ssthen 805898184e3Ssthen# accessors 806898184e3Ssthensub name { $_[0]->{module} } 807898184e3Ssthen 808898184e3Ssthensub filename { $_[0]->{filename} } 809898184e3Ssthensub packages_inside { @{$_[0]->{packages}} } 810898184e3Ssthensub pod_inside { @{$_[0]->{pod_headings}} } 8116fb12b70Safresh1sub contains_pod { 0+@{$_[0]->{pod_headings}} } 812898184e3Ssthen 813898184e3Ssthensub version { 814898184e3Ssthen my $self = shift; 815898184e3Ssthen my $mod = shift || $self->{module}; 816898184e3Ssthen my $vers; 817898184e3Ssthen if ( defined( $mod ) && length( $mod ) && 818898184e3Ssthen exists( $self->{versions}{$mod} ) ) { 819898184e3Ssthen return $self->{versions}{$mod}; 820b8851fccSafresh1 } 821b8851fccSafresh1 else { 822898184e3Ssthen return undef; 823898184e3Ssthen } 824898184e3Ssthen} 825898184e3Ssthen 826898184e3Ssthensub pod { 827898184e3Ssthen my $self = shift; 828898184e3Ssthen my $sect = shift; 829898184e3Ssthen if ( defined( $sect ) && length( $sect ) && 830898184e3Ssthen exists( $self->{pod}{$sect} ) ) { 831898184e3Ssthen return $self->{pod}{$sect}; 832b8851fccSafresh1 } 833b8851fccSafresh1 else { 834898184e3Ssthen return undef; 835898184e3Ssthen } 836898184e3Ssthen} 837898184e3Ssthen 838b8851fccSafresh1sub is_indexable { 839b8851fccSafresh1 my ($self, $package) = @_; 840b8851fccSafresh1 841b46d8ef2Safresh1 my @indexable_packages = grep $_ ne 'main', $self->packages_inside; 842b8851fccSafresh1 843b8851fccSafresh1 # check for specific package, if provided 844b46d8ef2Safresh1 return !! grep $_ eq $package, @indexable_packages if $package; 845b8851fccSafresh1 846b8851fccSafresh1 # otherwise, check for any indexable packages at all 847b8851fccSafresh1 return !! @indexable_packages; 848b8851fccSafresh1} 849b8851fccSafresh1 850898184e3Ssthen1; 851898184e3Ssthen 852b8851fccSafresh1__END__ 853b8851fccSafresh1 854b8851fccSafresh1=pod 855b8851fccSafresh1 856b8851fccSafresh1=encoding UTF-8 857b8851fccSafresh1 858898184e3Ssthen=head1 NAME 859898184e3Ssthen 860898184e3SsthenModule::Metadata - Gather package and POD information from perl module files 861898184e3Ssthen 862b8851fccSafresh1=head1 VERSION 863b8851fccSafresh1 864*3d61058aSafresh1version 1.000038 865b8851fccSafresh1 866898184e3Ssthen=head1 SYNOPSIS 867898184e3Ssthen 868898184e3Ssthen use Module::Metadata; 869898184e3Ssthen 870898184e3Ssthen # information about a .pm file 871898184e3Ssthen my $info = Module::Metadata->new_from_file( $file ); 872898184e3Ssthen my $version = $info->version; 873898184e3Ssthen 874898184e3Ssthen # CPAN META 'provides' field for .pm files in a directory 875898184e3Ssthen my $provides = Module::Metadata->provides( 876898184e3Ssthen dir => 'lib', version => 2 877898184e3Ssthen ); 878898184e3Ssthen 879898184e3Ssthen=head1 DESCRIPTION 880898184e3Ssthen 8816fb12b70Safresh1This module provides a standard way to gather metadata about a .pm file through 8826fb12b70Safresh1(mostly) static analysis and (some) code execution. When determining the 8836fb12b70Safresh1version of a module, the C<$VERSION> assignment is C<eval>ed, as is traditional 8846fb12b70Safresh1in the CPAN toolchain. 885898184e3Ssthen 886b8851fccSafresh1=head1 CLASS METHODS 887898184e3Ssthen 88856d68f1eSafresh1=head2 C<< new_from_file($filename, collect_pod => 1, decode_pod => 1) >> 889898184e3Ssthen 89091f110e0Safresh1Constructs a C<Module::Metadata> object given the path to a file. Returns 89191f110e0Safresh1undef if the filename does not exist. 89291f110e0Safresh1 89391f110e0Safresh1C<collect_pod> is a optional boolean argument that determines whether POD 894898184e3Ssthendata is collected and stored for reference. POD data is not collected by 89591f110e0Safresh1default. POD headings are always collected. 89691f110e0Safresh1 89791f110e0Safresh1If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then 89891f110e0Safresh1it is skipped before processing, and the content of the file is also decoded 89991f110e0Safresh1appropriately starting from perl 5.8. 900898184e3Ssthen 90156d68f1eSafresh1Alternatively, if C<decode_pod> is set, it will decode the collected pod 90256d68f1eSafresh1sections according to the C<=encoding> declaration. 90356d68f1eSafresh1 90456d68f1eSafresh1=head2 C<< new_from_handle($handle, $filename, collect_pod => 1, decode_pod => 1) >> 905898184e3Ssthen 906898184e3SsthenThis works just like C<new_from_file>, except that a handle can be provided 90791f110e0Safresh1as the first argument. 90891f110e0Safresh1 90991f110e0Safresh1Note that there is no validation to confirm that the handle is a handle or 91091f110e0Safresh1something that can act like one. Passing something that isn't a handle will 91191f110e0Safresh1cause a exception when trying to read from it. The C<filename> argument is 91291f110e0Safresh1mandatory or undef will be returned. 91391f110e0Safresh1 91491f110e0Safresh1You are responsible for setting the decoding layers on C<$handle> if 91591f110e0Safresh1required. 916898184e3Ssthen 91756d68f1eSafresh1=head2 C<< new_from_module($module, collect_pod => 1, inc => \@dirs, decode_pod => 1) >> 918898184e3Ssthen 91991f110e0Safresh1Constructs a C<Module::Metadata> object given a module or package name. 92091f110e0Safresh1Returns undef if the module cannot be found. 92191f110e0Safresh1 92256d68f1eSafresh1In addition to accepting the C<collect_pod> and C<decode_pod> arguments as 92356d68f1eSafresh1described above, this method accepts a C<inc> argument which is a reference to 92456d68f1eSafresh1an array of directories to search for the module. If none are given, the 92556d68f1eSafresh1default is @INC. 92691f110e0Safresh1 92791f110e0Safresh1If the file that contains the module begins by an UTF-8, UTF-16BE or 92891f110e0Safresh1UTF-16LE byte-order mark, then it is skipped before processing, and the 92991f110e0Safresh1content of the file is also decoded appropriately starting from perl 5.8. 930898184e3Ssthen 931b8851fccSafresh1=head2 C<< find_module_by_name($module, \@dirs) >> 932898184e3Ssthen 933898184e3SsthenReturns the path to a module given the module or package name. A list 934898184e3Ssthenof directories can be passed in as an optional parameter, otherwise 935898184e3Ssthen@INC is searched. 936898184e3Ssthen 937898184e3SsthenCan be called as either an object or a class method. 938898184e3Ssthen 939b8851fccSafresh1=head2 C<< find_module_dir_by_name($module, \@dirs) >> 940898184e3Ssthen 941898184e3SsthenReturns the entry in C<@dirs> (or C<@INC> by default) that contains 942898184e3Ssthenthe module C<$module>. A list of directories can be passed in as an 943898184e3Ssthenoptional parameter, otherwise @INC is searched. 944898184e3Ssthen 945898184e3SsthenCan be called as either an object or a class method. 946898184e3Ssthen 947b8851fccSafresh1=head2 C<< provides( %options ) >> 948898184e3Ssthen 949898184e3SsthenThis is a convenience wrapper around C<package_versions_from_directory> 950898184e3Ssthento generate a CPAN META C<provides> data structure. It takes key/value 951898184e3Ssthenpairs. Valid option keys include: 952898184e3Ssthen 953898184e3Ssthen=over 954898184e3Ssthen 955898184e3Ssthen=item version B<(required)> 956898184e3Ssthen 957898184e3SsthenSpecifies which version of the L<CPAN::Meta::Spec> should be used as 958898184e3Ssthenthe format of the C<provides> output. Currently only '1.4' and '2' 959898184e3Ssthenare supported (and their format is identical). This may change in 960898184e3Ssthenthe future as the definition of C<provides> changes. 961898184e3Ssthen 962898184e3SsthenThe C<version> option is required. If it is omitted or if 963898184e3Ssthenan unsupported version is given, then C<provides> will throw an error. 964898184e3Ssthen 965898184e3Ssthen=item dir 966898184e3Ssthen 967898184e3SsthenDirectory to search recursively for F<.pm> files. May not be specified with 968898184e3SsthenC<files>. 969898184e3Ssthen 970898184e3Ssthen=item files 971898184e3Ssthen 972898184e3SsthenArray reference of files to examine. May not be specified with C<dir>. 973898184e3Ssthen 974898184e3Ssthen=item prefix 975898184e3Ssthen 976898184e3SsthenString to prepend to the C<file> field of the resulting output. This defaults 977898184e3Ssthento F<lib>, which is the common case for most CPAN distributions with their 978898184e3SsthenF<.pm> files in F<lib>. This option ensures the META information has the 979898184e3Ssthencorrect relative path even when the C<dir> or C<files> arguments are 980898184e3Ssthenabsolute or have relative paths from a location other than the distribution 981898184e3Ssthenroot. 982898184e3Ssthen 983898184e3Ssthen=back 984898184e3Ssthen 985898184e3SsthenFor example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value 986898184e3Ssthenis a hashref of the form: 987898184e3Ssthen 988898184e3Ssthen { 989898184e3Ssthen 'Package::Name' => { 990898184e3Ssthen version => '0.123', 991898184e3Ssthen file => 'lib/Package/Name.pm' 992898184e3Ssthen }, 993898184e3Ssthen 'OtherPackage::Name' => ... 994898184e3Ssthen } 995898184e3Ssthen 996b8851fccSafresh1=head2 C<< package_versions_from_directory($dir, \@files?) >> 997898184e3Ssthen 998898184e3SsthenScans C<$dir> for .pm files (unless C<@files> is given, in which case looks 999898184e3Ssthenfor those files in C<$dir> - and reads each file for packages and versions, 1000898184e3Ssthenreturning a hashref of the form: 1001898184e3Ssthen 1002898184e3Ssthen { 1003898184e3Ssthen 'Package::Name' => { 1004898184e3Ssthen version => '0.123', 1005898184e3Ssthen file => 'Package/Name.pm' 1006898184e3Ssthen }, 1007898184e3Ssthen 'OtherPackage::Name' => ... 1008898184e3Ssthen } 1009898184e3Ssthen 1010898184e3SsthenThe C<DB> and C<main> packages are always omitted, as are any "private" 1011898184e3Ssthenpackages that have leading underscores in the namespace (e.g. 1012898184e3SsthenC<Foo::_private>) 1013898184e3Ssthen 1014898184e3SsthenNote that the file path is relative to C<$dir> if that is specified. 1015898184e3SsthenThis B<must not> be used directly for CPAN META C<provides>. See 1016898184e3Ssthenthe C<provides> method instead. 1017898184e3Ssthen 1018b8851fccSafresh1=head2 C<< log_info (internal) >> 1019898184e3Ssthen 1020898184e3SsthenUsed internally to perform logging; imported from Log::Contextual if 1021898184e3SsthenLog::Contextual has already been loaded, otherwise simply calls warn. 1022898184e3Ssthen 1023b8851fccSafresh1=head1 OBJECT METHODS 1024898184e3Ssthen 1025b8851fccSafresh1=head2 C<< name() >> 1026898184e3Ssthen 1027898184e3SsthenReturns the name of the package represented by this module. If there 1028b8851fccSafresh1is more than one package, it makes a best guess based on the 1029898184e3Ssthenfilename. If it's a script (i.e. not a *.pm) the package name is 1030898184e3Ssthen'main'. 1031898184e3Ssthen 1032b8851fccSafresh1=head2 C<< version($package) >> 1033898184e3Ssthen 1034898184e3SsthenReturns the version as defined by the $VERSION variable for the 1035898184e3Ssthenpackage as returned by the C<name> method if no arguments are 1036898184e3Ssthengiven. If given the name of a package it will attempt to return the 1037898184e3Ssthenversion of that package if it is specified in the file. 1038898184e3Ssthen 1039b8851fccSafresh1=head2 C<< filename() >> 1040898184e3Ssthen 1041898184e3SsthenReturns the absolute path to the file. 1042b8851fccSafresh1Note that this file may not actually exist on disk yet, e.g. if the module was read from an in-memory filehandle. 1043898184e3Ssthen 1044b8851fccSafresh1=head2 C<< packages_inside() >> 1045898184e3Ssthen 1046898184e3SsthenReturns a list of packages. Note: this is a raw list of packages 1047898184e3Ssthendiscovered (or assumed, in the case of C<main>). It is not 1048898184e3Ssthenfiltered for C<DB>, C<main> or private packages the way the 10496fb12b70Safresh1C<provides> method does. Invalid package names are not returned, 10506fb12b70Safresh1for example "Foo:Bar". Strange but valid package names are 10516fb12b70Safresh1returned, for example "Foo::Bar::", and are left up to the caller 10526fb12b70Safresh1on how to handle. 1053898184e3Ssthen 1054b8851fccSafresh1=head2 C<< pod_inside() >> 1055898184e3Ssthen 1056898184e3SsthenReturns a list of POD sections. 1057898184e3Ssthen 1058b8851fccSafresh1=head2 C<< contains_pod() >> 1059898184e3Ssthen 1060898184e3SsthenReturns true if there is any POD in the file. 1061898184e3Ssthen 1062b8851fccSafresh1=head2 C<< pod($section) >> 1063898184e3Ssthen 1064898184e3SsthenReturns the POD data in the given section. 1065898184e3Ssthen 1066b8851fccSafresh1=head2 C<< is_indexable($package) >> or C<< is_indexable() >> 1067b8851fccSafresh1 1068b8851fccSafresh1Available since version 1.000020. 1069b8851fccSafresh1 1070b8851fccSafresh1Returns a boolean indicating whether the package (if provided) or any package 1071b8851fccSafresh1(otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server. 1072b8851fccSafresh1Note This only checks for valid C<package> declarations, and does not take any 1073b8851fccSafresh1ownership information into account. 1074b8851fccSafresh1 1075b8851fccSafresh1=head1 SUPPORT 1076b8851fccSafresh1 1077b8851fccSafresh1Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Metadata> 1078b8851fccSafresh1(or L<bug-Module-Metadata@rt.cpan.org|mailto:bug-Module-Metadata@rt.cpan.org>). 1079b8851fccSafresh1 1080b8851fccSafresh1There is also a mailing list available for users of this distribution, at 1081b8851fccSafresh1L<http://lists.perl.org/list/cpan-workers.html>. 1082b8851fccSafresh1 1083b8851fccSafresh1There is also an irc channel available for users of this distribution, at 10849f11ffb7Safresh1L<C<#toolchain> on C<irc.perl.org>|irc://irc.perl.org/#toolchain>. 1085898184e3Ssthen 1086898184e3Ssthen=head1 AUTHOR 1087898184e3Ssthen 1088898184e3SsthenOriginal code from Module::Build::ModuleInfo by Ken Williams 1089898184e3Ssthen<kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org> 1090898184e3Ssthen 1091898184e3SsthenReleased as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with 1092898184e3Ssthenassistance from David Golden (xdg) <dagolden@cpan.org>. 1093898184e3Ssthen 1094b8851fccSafresh1=head1 CONTRIBUTORS 1095b8851fccSafresh1 1096*3d61058aSafresh1=for stopwords Karen Etheridge David Golden Vincent Pit Matt S Trout Chris Nehren Graham Knop Olivier Mengué Tomas Doran Christian Walde Craig A. Berry Tatsuhiko Miyagawa tokuhirom 'BinGOs' Williams Mitchell Steinbrunner Edward Zborowski Gareth Harper James Raspass Jerry D. Hedden Josh Jore Kent Fredric Leon Timmermans Peter Rabbitson Steve Hay 1097b8851fccSafresh1 1098b8851fccSafresh1=over 4 1099b8851fccSafresh1 1100b8851fccSafresh1=item * 1101b8851fccSafresh1 1102b8851fccSafresh1Karen Etheridge <ether@cpan.org> 1103b8851fccSafresh1 1104b8851fccSafresh1=item * 1105b8851fccSafresh1 1106b8851fccSafresh1David Golden <dagolden@cpan.org> 1107b8851fccSafresh1 1108b8851fccSafresh1=item * 1109b8851fccSafresh1 1110b8851fccSafresh1Vincent Pit <perl@profvince.com> 1111b8851fccSafresh1 1112b8851fccSafresh1=item * 1113b8851fccSafresh1 1114b8851fccSafresh1Matt S Trout <mst@shadowcat.co.uk> 1115b8851fccSafresh1 1116b8851fccSafresh1=item * 1117b8851fccSafresh1 1118b8851fccSafresh1Chris Nehren <apeiron@cpan.org> 1119b8851fccSafresh1 1120b8851fccSafresh1=item * 1121b8851fccSafresh1 1122*3d61058aSafresh1Graham Knop <haarg@haarg.org> 1123b8851fccSafresh1 1124b8851fccSafresh1=item * 1125b8851fccSafresh1 1126b8851fccSafresh1Olivier Mengué <dolmen@cpan.org> 1127b8851fccSafresh1 1128b8851fccSafresh1=item * 1129b8851fccSafresh1 1130*3d61058aSafresh1Tomas Doran <bobtfish@bobtfish.net> 113156d68f1eSafresh1 113256d68f1eSafresh1=item * 113356d68f1eSafresh1 1134b46d8ef2Safresh1Christian Walde <walde.christian@googlemail.com> 1135b46d8ef2Safresh1 1136b46d8ef2Safresh1=item * 1137b46d8ef2Safresh1 1138b8851fccSafresh1Craig A. Berry <cberry@cpan.org> 1139b8851fccSafresh1 1140b8851fccSafresh1=item * 1141b8851fccSafresh1 1142*3d61058aSafresh1Tatsuhiko Miyagawa <miyagawa@bulknews.net> 1143*3d61058aSafresh1 1144*3d61058aSafresh1=item * 1145*3d61058aSafresh1 1146*3d61058aSafresh1tokuhirom <tokuhirom@gmail.com> 1147*3d61058aSafresh1 1148*3d61058aSafresh1=item * 1149*3d61058aSafresh1 1150*3d61058aSafresh1Chris 'BinGOs' Williams <chris@bingosnet.co.uk> 11519f11ffb7Safresh1 11529f11ffb7Safresh1=item * 11539f11ffb7Safresh1 1154b8851fccSafresh1David Mitchell <davem@iabyn.com> 1155b8851fccSafresh1 1156b8851fccSafresh1=item * 1157b8851fccSafresh1 1158b8851fccSafresh1David Steinbrunner <dsteinbrunner@pobox.com> 1159b8851fccSafresh1 1160b8851fccSafresh1=item * 1161b8851fccSafresh1 1162b8851fccSafresh1Edward Zborowski <ed@rubensteintech.com> 1163b8851fccSafresh1 1164b8851fccSafresh1=item * 1165b8851fccSafresh1 1166b8851fccSafresh1Gareth Harper <gareth@broadbean.com> 1167b8851fccSafresh1 1168b8851fccSafresh1=item * 1169b8851fccSafresh1 1170b8851fccSafresh1James Raspass <jraspass@gmail.com> 1171b8851fccSafresh1 1172b8851fccSafresh1=item * 1173b8851fccSafresh1 1174*3d61058aSafresh1Jerry D. Hedden <jdhedden@cpan.org> 1175b8851fccSafresh1 1176b8851fccSafresh1=item * 1177b8851fccSafresh1 11789f11ffb7Safresh1Josh Jore <jjore@cpan.org> 1179b8851fccSafresh1 1180b46d8ef2Safresh1=item * 1181b46d8ef2Safresh1 1182b46d8ef2Safresh1Kent Fredric <kentnl@cpan.org> 1183b46d8ef2Safresh1 1184*3d61058aSafresh1=item * 1185*3d61058aSafresh1 1186*3d61058aSafresh1Leon Timmermans <fawaka@gmail.com> 1187*3d61058aSafresh1 1188*3d61058aSafresh1=item * 1189*3d61058aSafresh1 1190*3d61058aSafresh1Peter Rabbitson <ribasushi@cpan.org> 1191*3d61058aSafresh1 1192*3d61058aSafresh1=item * 1193*3d61058aSafresh1 1194*3d61058aSafresh1Steve Hay <steve.m.hay@googlemail.com> 1195*3d61058aSafresh1 1196b8851fccSafresh1=back 1197b8851fccSafresh1 119891f110e0Safresh1=head1 COPYRIGHT & LICENSE 1199898184e3Ssthen 1200898184e3SsthenOriginal code Copyright (c) 2001-2011 Ken Williams. 1201898184e3SsthenAdditional code Copyright (c) 2010-2011 Matt Trout and David Golden. 1202898184e3SsthenAll rights reserved. 1203898184e3Ssthen 1204898184e3SsthenThis library is free software; you can redistribute it and/or 1205898184e3Ssthenmodify it under the same terms as Perl itself. 1206898184e3Ssthen 1207898184e3Ssthen=cut 1208