diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Dist/Metadata.pm | 677 | ||||
| -rw-r--r-- | lib/Dist/Metadata/Archive.pm | 171 | ||||
| -rw-r--r-- | lib/Dist/Metadata/Dir.pm | 186 | ||||
| -rw-r--r-- | lib/Dist/Metadata/Dist.pm | 623 | ||||
| -rw-r--r-- | lib/Dist/Metadata/Struct.pm | 131 | ||||
| -rw-r--r-- | lib/Dist/Metadata/Tar.pm | 99 | ||||
| -rw-r--r-- | lib/Dist/Metadata/Zip.pm | 95 |
7 files changed, 1982 insertions, 0 deletions
diff --git a/lib/Dist/Metadata.pm b/lib/Dist/Metadata.pm new file mode 100644 index 0000000..a05414e --- /dev/null +++ b/lib/Dist/Metadata.pm @@ -0,0 +1,677 @@ +# vim: set ts=2 sts=2 sw=2 expandtab smarttab: +# +# This file is part of Dist-Metadata +# +# This software is copyright (c) 2011 by Randy Stauner. +# +# This is free software; you can redistribute it and/or modify it under +# the same terms as the Perl 5 programming language system itself. +# +use strict; +use warnings; + +package Dist::Metadata; +# git description: v0.925-17-g08a6891 + +our $AUTHORITY = 'cpan:RWSTAUNER'; +# ABSTRACT: Information about a perl module distribution +$Dist::Metadata::VERSION = '0.926'; +use Carp qw(croak carp); +use CPAN::Meta 2.1 (); +use List::Util qw(first); # core in perl v5.7.3 + +# something that is obviously not a real value +sub UNKNOWN () { '- unknown -' } # constant + + +sub new { + my $class = shift; + my $self = { + determine_packages => 1, + @_ == 1 ? %{ $_[0] } : @_ + }; + + my @formats = qw( dist file dir struct ); + croak(qq[A dist must be specified (one of ] . + join(', ', map { "'$_'" } @formats) . ')') + unless first { $self->{$_} } @formats; + + bless $self, $class; +} + + +sub dist { + my ($self) = @_; + return $self->{dist} ||= do { + my $dist; + if( my $struct = $self->{struct} ){ + require Dist::Metadata::Struct; + $dist = Dist::Metadata::Struct->new(%$struct); + } + elsif( my $dir = $self->{dir} ){ + require Dist::Metadata::Dir; + $dist = Dist::Metadata::Dir->new(dir => $dir); + } + elsif ( my $file = $self->{file} ){ + require Dist::Metadata::Archive; + $dist = Dist::Metadata::Archive->new(file => $file); + } + else { + # new() checks for one and dies without so we shouldn't get here + croak q[No dist format parameters found!]; + } + $dist; # return + }; +} + + +sub default_metadata { + my ($self) = @_; + + return { + # required + abstract => UNKNOWN, + author => [], + dynamic_config => 0, + generated_by => ( ref($self) || $self ) . ' version ' . ( $self->VERSION || 0 ), + license => ['unknown'], # this 'unknown' comes from CPAN::Meta::Spec + 'meta-spec' => { + version => '2', + url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', + }, + name => UNKNOWN, + + # strictly speaking, release_status is also required but + # CPAN::Meta will figure it out based on the version number. if + # we were to set it explicitly, then we would first need to + # examine the version number for '_' or 'TRIAL' or 'RC' etc. + + version => 0, + + # optional + no_index => { + # Ignore the same directories as PAUSE (https://github.com/andk/pause/blob/master/lib/PAUSE/dist.pm#L758): + # skip "t" - libraries in ./t are test libraries! + # skip "xt" - libraries in ./xt are author test libraries! + # skip "inc" - libraries in ./inc are usually install libraries + # skip "local" - somebody shipped his carton setup! + # skip 'perl5" - somebody shipped her local::lib! + # skip 'fatlib' - somebody shipped their fatpack lib! + directory => [qw( inc t xt local perl5 fatlib )], + }, + # provides => { package => { file => $file, version => $version } } + }; +} + + +sub determine_metadata { + my ($self) = @_; + + my $dist = $self->dist; + my $meta = $self->default_metadata; + + # get name and version from dist if dist was able to parse them + foreach my $att (qw(name version)) { + my $val = $dist->$att; + # if the dist could determine it that's better than the default + # but undef won't validate. value in $self will still override. + $meta->{$att} = $val + if defined $val; + } + + # any passed in values should take priority + foreach my $field ( keys %$meta ){ + $meta->{$field} = $self->{$field} + if exists $self->{$field}; + } + + return $meta; +} + + +sub determine_packages { + # meta must be passed to avoid infinite loop + my ( $self, $meta ) = @_; + # if not passed in, use defaults (we just want the 'no_index' property) + $meta ||= $self->meta_from_struct( $self->determine_metadata ); + + # should_index_file() expects unix paths + my @files = grep { + $meta->should_index_file( + $self->dist->path_classify_file($_)->as_foreign('Unix')->stringify + ); + } + $self->dist->perl_files; + + # TODO: should we limit packages to lib/ if it exists? + # my @lib = grep { m#^lib/# } @files; @files = @lib if @lib; + + return {} if not @files; + + my $packages = $self->dist->determine_packages(@files); + + + foreach my $pack ( keys %$packages ) { + + # Remove any packages that should not be indexed + if ( !$meta->should_index_package($pack) ) { + delete $packages->{$pack}; + next; + } + + unless( $self->{include_inner_packages} ){ + # PAUSE only considers packages that match the basename of the + # containing file. For example, file Foo.pm may only contain a + # package that matches /\bFoo$/. This is what PAUSE calls a + # "simile". All other packages in the file will be ignored. + + # capture file basename (without the extension) + my ($base) = ($packages->{$pack}->{file} =~ m!([^/]+)\.pm(?:\.PL)?$!); + # remove if file didn't match regexp or package doesn't match basename + delete $packages->{$pack} + if !$base || $pack !~ m{\b\Q$base\E$}; + } + } + + return $packages; +} + + +sub load_meta { + my ($self) = @_; + + my $dist = $self->dist; + my @files = $dist->list_files; + my ( $meta, $metafile ); + my $default_meta = $self->determine_metadata; + + # prefer json file (spec v2) + if ( $metafile = first { m#^META\.json$# } @files ) { + $meta = CPAN::Meta->load_json_string( $dist->file_content($metafile) ); + } + # fall back to yaml file (spec v1) + elsif ( $metafile = first { m#^META\.ya?ml$# } @files ) { + $meta = CPAN::Meta->load_yaml_string( $dist->file_content($metafile) ); + } + # no META file found in dist + else { + $meta = $self->meta_from_struct( $default_meta ); + } + + { + # always include (never index) the default no_index dirs + my $dir = ($meta->{no_index} ||= {})->{directory} ||= []; + my %seen = map { ($_ => 1) } @$dir; + unshift @$dir, + grep { !$seen{$_}++ } + @{ $default_meta->{no_index}->{directory} }; + } + + # Something has to be indexed, so if META has no (or empty) 'provides' + # attempt to determine packages unless specifically configured not to + if ( !keys %{ $meta->provides || {} } && $self->{determine_packages} ) { + # respect api/encapsulation + my $struct = $meta->as_struct; + $struct->{provides} = $self->determine_packages($meta); + $meta = $self->meta_from_struct($struct); + } + + return $meta; +} + + +sub meta { + my ($self) = @_; + return $self->{meta} ||= $self->load_meta; +} + + +sub meta_from_struct { + my ($self, $struct) = @_; + return CPAN::Meta->create( $struct, { lazy_validation => 1 } ); +} + + +sub package_versions { + my ($self) = shift; + my $provides = @_ ? shift : $self->provides; # || {} + return { + map { ($_ => $provides->{$_}{version}) } keys %$provides + }; +} + + +sub module_info { + my ($self, $opts) = @_; + my $provides = $opts->{provides} || $self->provides; + $provides = { %$provides }; # break reference + + my $checksums = $opts->{checksum} || $opts->{digest} || []; + $checksums = [ $checksums ] + unless ref($checksums) eq 'ARRAY'; + + my $digest_cache = {}; + foreach my $mod ( keys %$provides ){ + my $data = { %{ $provides->{ $mod } } }; # break reference + + foreach my $checksum ( @$checksums ){ + $data->{ $checksum } = + $digest_cache->{ $data->{file} }->{ $checksum } ||= + $self->dist->file_checksum($data->{file}, $checksum); + } + + # TODO: $opts->{callback}->($self, $mod, $data, sub { $self->dist->file_content($data->{file}) }); + + $provides->{ $mod } = $data; + } + + return $provides; +} + + +{ + no strict 'refs'; ## no critic (NoStrict) + foreach my $method ( qw( + name + provides + version + ) ){ + *$method = sub { $_[0]->meta->$method }; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=for :stopwords Randy Stauner ACKNOWLEDGEMENTS TODO dist dists dir unix checksum checksums +David Jeffrey Ryan Sawyer Steinbrunner Thalhammer X cpan testmatrix url +annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata +placeholders metacpan + +=head1 NAME + +Dist::Metadata - Information about a perl module distribution + +=head1 VERSION + +version 0.926 + +=head1 SYNOPSIS + + my $dist = Dist::Metadata->new(file => $path_to_archive); + + my $description = sprintf "Dist %s (%s)", $dist->name, $dist->version; + + my $provides = $dist->package_versions; + while( my ($package, $version) = each %$provides ){ + print "$description includes $package $version\n"; + } + +=head1 DESCRIPTION + +This module provides an easy interface for getting various metadata +about a Perl module distribution. + +It takes care of the common logic of: + +=over 4 + +=item * + +reading a tar file (L<Archive::Tar>) + +=item * + +finding and reading the correct META file if the distribution contains one (L<CPAN::Meta>) + +=item * + +and determining some of the metadata if there is no META file (L<Module::Metadata>, L<CPAN::DistnameInfo>) + +=back + +This is mostly a wrapper around L<CPAN::Meta> providing an easy interface +to find and load the meta file from a F<tar.gz> file. +A dist can also be represented by a directory or merely a structure of data. + +If the dist does not contain a meta file +the module will attempt to determine some of that data from the dist. + +B<NOTE>: This interface is still being defined. +Please submit any suggestions or concerns. + +=head1 METHODS + +=head2 new + + Dist::Metadata->new(file => $path); + +A dist can be represented by +a tar file, +a directory, +or a data structure. + +The format will be determined by the presence of the following options +(checked in this order): + +=over 4 + +=item * + +C<struct> - hash of data to build a mock dist; See L<Dist::Metadata::Struct>. + +=item * + +C<dir> - path to the root directory of a dist + +=item * + +C<file> - the path to a F<.tar.gz> file + +=back + +You can also slyly pass in your own object as a C<dist> parameter +in which case this module will just use that. +This can be useful if you need to use your own subclass +(perhaps while developing a new format). + +Other options that can be specified: + +=over 4 + +=item * + +C<name> - dist name + +=item * + +C<version> - dist version + +=item * + +C<determine_packages> - boolean to indicate whether dist should be searched +for packages if no META file is found. Defaults to true. + +=item * + +C<include_inner_packages> - When determining provided packages +the default behavior is to only include packages that match the name +of the file that defines them (like C<Foo::Bar> matches C<*/Bar.pm>). +This way only modules that can be loaded (via C<use> or C<require>) +will be returned (and "inner" packages will be ignored). +This mimics the behavior of PAUSE. +Set this to true to include any "inner" packages provided by the dist +(that are not otherwise excluded by another mechanism (such as C<no_index>)). + +=back + +=head2 dist + +Returns the dist object (subclass of L<Dist::Metadata::Dist>). + +=head2 default_metadata + +Returns a hashref of default values +used to initialize a L<CPAN::Meta> object +when a META file is not found. +Called from L</determine_metadata>. + +=head2 determine_metadata + +Examine the dist and try to determine metadata. +Returns a hashref which can be passed to L<CPAN::Meta/new>. +This is used when the dist does not contain a META file. + +=head2 determine_packages + + my $provides = $dm->determine_packages($meta); + +Attempt to determine packages provided by the dist. +This is used when the META file does not include a C<provides> +section and C<determine_packages> is not set to false in the constructor. + +If a L<CPAN::Meta> object is not provided a default one will be used. +Files contained in the dist and packages found therein will be checked against +the meta object's C<no_index> attribute +(see L<CPAN::Meta/should_index_file> +and L<CPAN::Meta/should_index_package>). +By default this ignores any files found in +F<inc/>, +F<t/>, +or F<xt/> +directories. + +=head2 load_meta + +Loads the metadata from the L</dist>. + +=head2 meta + +Returns the L<CPAN::Meta> instance in use. + +=head2 meta_from_struct + + $meta = $dm->meta_from_struct(\%struct); + +Passes the provided C<\%struct> to L<CPAN::Meta/create> +and returns the result. + +=head2 package_versions + + $pv = $dm->package_versions(); + # { 'Package::Name' => '1.0', 'Module::2' => '2.1' } + +Returns a simplified version of C<provides>: +a hashref with package names as keys and versions as values. + +This can also be called as a class method +which will operate on a passed in hashref. + + $pv = Dist::Metadata->package_versions(\%provides); + +=head2 module_info + +Returns a hashref of meta data for each of the packages provided by this dist. + +The hashref starts with the same data as L</provides> +but additional data can be added to the output by specifying options in a hashref: + +=over 4 + +=item C<checksum> + +Use the specified algorithm to compute a hex digest of the file. +The type you specify will be the key in the returned hashref. +You can use an arrayref to specify more than one type. + + $dm->module_info({checksum => ['sha256', 'md5']}); + # returns: + { + 'Mod::Name' => { + file => 'lib/Mod/Name.pm', + version => '0.1', + md5 => '258e88dcbd3cd44d8e7ab43f6ecb6af0', + sha256 => 'f22136124cd3e1d65a48487cecf310771b2fd1e83dc032e3d19724160ac0ff71', + }, + } + +See L<Dist::Metadata::Dist/file_checksum> for more information. + +=item C<provides> + +The default is to start with the hashref returned from L</provides> +but you can pass in an alternate hashref using this key. + +=back + +Other options may be added in the future. + +=head1 INHERITED METHODS + +The following methods are available on this object +and simply call the corresponding method on the L<CPAN::Meta> object. + +=over 4 + +=item * + +X<name> name + +=item * + +X<provides> provides + +=item * + +X<version> version + +=back + +=for Pod::Coverage name version provides +UNKNOWN + +=for test_synopsis my $path_to_archive; + +=head1 TODO + +=over 4 + +=item * + +More tests + +=item * + +C<trust_meta> option (to allow setting it to false) + +=item * + +Guess main module from dist name if no packages can be found + +=item * + +Determine abstract? + +=item * + +Add change log info (L<CPAN::Changes>)? + +=item * + +Subclass as C<CPAN::Dist::Metadata> just so that it has C<CPAN> in the name? + +=item * + +Use L<File::Find::Rule::Perl>? + +=back + +=head1 SEE ALSO + +=head2 Dependencies + +=over 4 + +=item * + +L<CPAN::Meta> + +=item * + +L<Module::Metadata> + +=item * + +L<CPAN::DistnameInfo> + +=back + +=head2 Related Modules + +=over 4 + +=item * + +L<MyCPAN::Indexer> + +=item * + +L<CPAN::ParseDistribution> + +=back + +=head1 SUPPORT + +=head2 Perldoc + +You can find documentation for this module with the perldoc command. + + perldoc Dist::Metadata + +=head2 Websites + +The following websites have more information about this module, and may be of help to you. As always, +in addition to those websites please use your favorite search engine to discover more resources. + +=over 4 + +=item * + +MetaCPAN + +A modern, open-source CPAN search engine, useful to view POD in HTML format. + +L<http://metacpan.org/release/Dist-Metadata> + +=back + +=head2 Bugs / Feature Requests + +Please report any bugs or feature requests by email to C<bug-dist-metadata at rt.cpan.org>, or through +the web interface at L<https://rt.cpan.org/Public/Bug/Report.html?Queue=Dist-Metadata>. You will be automatically notified of any +progress on the request by the system. + +=head2 Source Code + + +L<https://github.com/rwstauner/Dist-Metadata> + + git clone https://github.com/rwstauner/Dist-Metadata.git + +=head1 AUTHOR + +Randy Stauner <rwstauner@cpan.org> + +=head1 CONTRIBUTORS + +=for stopwords David Steinbrunner Jeffrey Ryan Thalhammer Sawyer X + +=over 4 + +=item * + +David Steinbrunner <dsteinbrunner@pobox.com> + +=item * + +Jeffrey Ryan Thalhammer <thaljef@cpan.org> + +=item * + +Sawyer X <xsawyerx@cpan.org> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2011 by Randy Stauner. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Dist/Metadata/Archive.pm b/lib/Dist/Metadata/Archive.pm new file mode 100644 index 0000000..cb0bb60 --- /dev/null +++ b/lib/Dist/Metadata/Archive.pm @@ -0,0 +1,171 @@ +# vim: set ts=2 sts=2 sw=2 expandtab smarttab: +# +# This file is part of Dist-Metadata +# +# This software is copyright (c) 2011 by Randy Stauner. +# +# This is free software; you can redistribute it and/or modify it under +# the same terms as the Perl 5 programming language system itself. +# +use strict; +use warnings; + +package Dist::Metadata::Archive; +our $AUTHORITY = 'cpan:RWSTAUNER'; +# ABSTRACT: Base class for Dist::Metadata archive files +$Dist::Metadata::Archive::VERSION = '0.926'; +use Carp (); # core +use parent 'Dist::Metadata::Dist'; + +push(@Dist::Metadata::CARP_NOT, __PACKAGE__); + + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + + if( $class eq __PACKAGE__ ){ + my $subclass = 'Dist::Metadata::' . + ( $self->{file} =~ /\.zip$/ ? 'Zip' : 'Tar' ); + + eval "require $subclass" + or Carp::croak $@; + + # rebless into format specific subclass + bless $self, $subclass; + } + + return $self; +} + +sub required_attribute { 'file' } + + +sub archive { + my ($self) = @_; + return $self->{archive} ||= do { + my $file = $self->file; + + Carp::croak "File '$file' does not exist" + unless -e $file; + + $self->read_archive($file); # return + }; +} + + +sub default_file_spec { 'Unix' } + + +sub determine_name_and_version { + my ($self) = @_; + $self->set_name_and_version( $self->parse_name_and_version( $self->file ) ); + return $self->SUPER::determine_name_and_version(@_); +} + + +sub file { + return $_[0]->{file}; +} + + +sub read_archive { + Carp::croak q[Method 'read_archive' not defined]; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=for :stopwords Randy Stauner ACKNOWLEDGEMENTS TODO dist dists dir unix checksum checksums +David Jeffrey Ryan Sawyer Steinbrunner Thalhammer X + +=head1 NAME + +Dist::Metadata::Archive - Base class for Dist::Metadata archive files + +=head1 VERSION + +version 0.926 + +=head1 SYNOPSIS + + my $dist = Dist::Metadata->new(file => $path_to_archive); + +=head1 DESCRIPTION + +This is a subclass of L<Dist::Metadata::Dist> +to enable determining the metadata from an archive file. + +It is a base class for archive file formats: + +=over 4 + +=item * + +L<Dist::Metadata::Tar> + +=item * + +L<Dist::Metadata::Zip> + +=back + +It's not useful on it's own +and should be used from L<Dist::Metadata/new>. + +=head1 METHODS + +=head2 new + + $dist = Dist::Metadata::Archive->new(file => $path); + +Accepts a single C<file> argument that should be a path to a file. + +If called from this base class +C<new()> will delegate to a subclass based on the filename +and return a blessed instance of that subclass. + +=head2 archive + +Returns an object representing the archive file. + +=head2 default_file_spec + +Returns C<Unix> since most archive files are be in unix format. + +=head2 determine_name_and_version + +Attempts to parse name and version from file name. + +=head2 file + +The C<file> attribute passed to the constructor, +used to load L</archive>. + +=head2 read_archive + + $dist->read_archive($file); + +Returns a format-specific object representing the specified file. + +This B<must> be defined by subclasses. + +=for test_synopsis my $path_to_archive; + +=head1 AUTHOR + +Randy Stauner <rwstauner@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2011 by Randy Stauner. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Dist/Metadata/Dir.pm b/lib/Dist/Metadata/Dir.pm new file mode 100644 index 0000000..78812a2 --- /dev/null +++ b/lib/Dist/Metadata/Dir.pm @@ -0,0 +1,186 @@ +# vim: set ts=2 sts=2 sw=2 expandtab smarttab: +# +# This file is part of Dist-Metadata +# +# This software is copyright (c) 2011 by Randy Stauner. +# +# This is free software; you can redistribute it and/or modify it under +# the same terms as the Perl 5 programming language system itself. +# +use strict; +use warnings; + +package Dist::Metadata::Dir; +our $AUTHORITY = 'cpan:RWSTAUNER'; +# ABSTRACT: Enable Dist::Metadata for a directory +$Dist::Metadata::Dir::VERSION = '0.926'; +use Carp qw(croak carp); # core +use File::Find (); # core +use Path::Class 0.24 (); +use parent 'Dist::Metadata::Dist'; + +push(@Dist::Metadata::CARP_NOT, __PACKAGE__); + + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + + # fix up dir (for example chop trailing slash if present) + $self->{dir} = $self->path_class_dir->new($self->{dir})->stringify; + + # TODO: croak if not -d $self->dir + + return $self; +} + +sub required_attribute { 'dir' } + + +sub determine_name_and_version { + my ($self) = @_; + # 'root' may be more accurate than 'dir' + $self->SUPER::determine_name_and_version(); + $self->set_name_and_version( $self->parse_name_and_version( $self->dir ) ); + return; +} + + +sub dir { + $_[0]->{dir}; +} + +# this shouldn't be called +sub extract_into { + croak q[A directory doesn't need to be extracted]; +} + + +sub file_content { + my ($self, $file) = @_; + # This is a directory so file spec will always be native + my $path = $self->path_class_file + ->new( $self->{dir}, $self->full_path($file) )->stringify; + + open(my $fh, '<', $path) + or croak "Failed to open file '$path': $!"; + + return do { local $/; <$fh> }; +} + + +sub find_files { + my ($self) = @_; + + my $dir = $self->{dir}; + my @files; + + File::Find::find( + { + wanted => sub { + push @files, $self->path_class_file->new($_)->relative($dir)->stringify + if -f $_; + }, + no_chdir => 1 + }, + $dir + ); + + return @files; +} + + +sub physical_directory { + my ($self, @files) = @_; + + # TODO: return absolute_path? + my @parts = $self->{dir}; + # go into root dir if there is one + push @parts, $self->root + if $self->root; + + my $dir = $self->path_class_dir->new(@parts)->absolute; + + return $dir->stringify unless wantarray; + + return map { $_->stringify } + ($dir, map { $dir->file( $_ ) } @files); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=for :stopwords Randy Stauner ACKNOWLEDGEMENTS TODO dist dists dir unix checksum checksums +David Jeffrey Ryan Sawyer Steinbrunner Thalhammer X + +=head1 NAME + +Dist::Metadata::Dir - Enable Dist::Metadata for a directory + +=head1 VERSION + +version 0.926 + +=head1 SYNOPSIS + + my $dm = Dist::Metadata->new(dir => $path_to_dir); + +=head1 DESCRIPTION + +This is a subclass of L<Dist::Metadata::Dist> +to enable getting the dists metadata from a directory. + +This can be useful if you already have a dist extracted into a directory. + +It's probably not very useful on it's own though, +and should be used from L<Dist::Metadata/new>. + +=head1 METHODS + +=head2 new + + $dist = Dist::Metadata::Struct->new(dir => $path); + +Accepts a single 'dir' argument that should be a path to a directory. + +=head2 determine_name_and_version + +Attempts to parse name and version from directory name. + +=head2 dir + +Returns the C<dir> attribute specified in the constructor. + +=head2 file_content + +Returns the content for the specified file. + +=head2 find_files + +Returns a list of the file names beneath the directory +(relative to the directory). + +=head2 physical_directory + +Returns the C<dir> attribute since this is already a directory +containing the desired files. + +=for test_synopsis my $path_to_dir; + +=head1 AUTHOR + +Randy Stauner <rwstauner@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2011 by Randy Stauner. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Dist/Metadata/Dist.pm b/lib/Dist/Metadata/Dist.pm new file mode 100644 index 0000000..063affd --- /dev/null +++ b/lib/Dist/Metadata/Dist.pm @@ -0,0 +1,623 @@ +# +# This file is part of Dist-Metadata +# +# This software is copyright (c) 2011 by Randy Stauner. +# +# This is free software; you can redistribute it and/or modify it under +# the same terms as the Perl 5 programming language system itself. +# +use strict; +use warnings; + +package Dist::Metadata::Dist; +our $AUTHORITY = 'cpan:RWSTAUNER'; +# ABSTRACT: Base class for format-specific implementations +$Dist::Metadata::Dist::VERSION = '0.926'; +use Carp qw(croak carp); # core +use CPAN::DistnameInfo 0.12 (); +use Path::Class 0.24 (); +use Try::Tiny 0.09; + + +sub new { + my $class = shift; + my $self = { + @_ == 1 ? %{ $_[0] } : @_ + }; + + bless $self, $class; + + my $req = $class->required_attribute; + croak qq['$req' parameter required] + if $req && !$self->{$req}; + + if ( exists $self->{file_spec} ) { + # we just want the OS name ('Unix' or '') + $self->{file_spec} =~ s/^File::Spec(::)?// + if $self->{file_spec}; + # blank is no good, use "Native" hack + $self->{file_spec} = 'Native' + if !$self->{file_spec}; + } + + return $self; +} + + +sub default_file_spec { 'Native' } + + +sub determine_name_and_version { + my ($self) = @_; + $self->set_name_and_version( $self->parse_name_and_version( $self->root ) ); + return; +} + + +sub determine_packages { + my ($self, @files) = @_; + + my $determined = try { + my @dir_and_files = $self->physical_directory(@files); + + # return + $self->packages_from_directory(@dir_and_files); + } + catch { + carp("Error determining packages: $_[0]"); + +{}; # return + }; + + return $determined; +} + + +sub extract_into { + my ($self, $dir, @files) = @_; + + @files = $self->list_files + unless @files; + + require File::Basename; + + my @disk_files; + foreach my $file (@files) { + my $ff = $self->path_class_file->new_foreign( $self->file_spec, $file ); + # Translate dist format (relative path) to disk/OS format and prepend $dir. + # This dir_list + basename hack is probably ok because the paths in a dist + # should always be relative (if there *was* a volume we wouldn't want it). + my $path = $self->path_class_file + ->new( $dir, $ff->dir->dir_list, $ff->basename ); + + $path->dir->mkpath(0, oct(700)); + + my $full_path = $path->stringify; + open(my $fh, '>', $full_path) + or croak "Failed to open '$full_path' for writing: $!"; + print $fh $self->file_content($file); + + # do we really want full path or do we want relative? + push(@disk_files, $full_path); + } + + return (wantarray ? ($dir, @disk_files) : $dir); +} + + +sub file_content { + croak q[Method 'file_content' not defined]; +} + + +sub file_checksum { + my ($self, $file, $type) = @_; + $type ||= 'md5'; + + require Digest; # core + + # md5 => MD5, sha256 => SHA-256 + (my $impl = uc $type) =~ s/^(SHA|CRC)([0-9]+)$/$1-$2/; + + my $digest = Digest->new($impl); + + $digest->add( $self->file_content($file) ); + return $digest->hexdigest; +} + + +sub find_files { + croak q[Method 'find_files' not defined]; +} + + +sub file_spec { + my ($self) = @_; + + $self->{file_spec} = $self->default_file_spec + if !exists $self->{file_spec}; + + return $self->{file_spec}; +} + + +sub full_path { + my ($self, $file) = @_; + + return $file + unless my $root = $self->root; + + # don't re-add the root if it's already there + return $file + # FIXME: this regexp is probably not cross-platform... + # FIXME: is there a way to do this with File::Spec? + if $file =~ m@^\Q${root}\E[\\/]@; + + # FIXME: does this foreign_file work w/ Dir ? + return $self->path_class_file + ->new_foreign($self->file_spec, $root, $file)->stringify; +} + + +sub list_files { + my ($self) = @_; + + $self->{_list_files} = do { + my @files = sort $self->find_files; + my ($root, @rel) = $self->remove_root_dir(@files); + $self->{root} = $root; + \@rel; # return + } + unless $self->{_list_files}; + + return @{ $self->{_list_files} }; +} + + +{ + no strict 'refs'; ## no critic (NoStrict) + foreach my $method ( qw( + name + version + ) ){ + *$method = sub { + my ($self) = @_; + + $self->determine_name_and_version + if !exists $self->{ $method }; + + return $self->{ $method }; + }; + } +} + + +sub packages_from_directory { + my ($self, $dir, @files) = @_; + + my @pvfd = ($dir); + # M::M::p_v_f_d expects full paths for \@files + push @pvfd, [map { + $self->path_class_file->new($_)->is_absolute + ? $_ : $self->path_class_file->new($dir, $_)->stringify + } @files] + if @files; + + require Module::Metadata; + + my $provides = try { + my $packages = Module::Metadata->package_versions_from_directory(@pvfd); + while ( my ($pack, $pv) = each %$packages ) { + # M::M::p_v_f_d returns files in native OS format (obviously); + # CPAN::Meta expects file paths in Unix format + $pv->{file} = $self->path_class_file + ->new($pv->{file})->as_foreign('Unix')->stringify; + } + $packages; # return + } + catch { + carp("Failed to determine packages: $_[0]"); + +{}; # return + }; + return $provides || {}; +} + + +sub parse_name_and_version { + my ($self, $path) = @_; + my ( $name, $version ); + if ( $path ){ + # try a simple regexp first + $path =~ m! + ([^\\/]+) # name (anything below final directory) + - # separator + (v?[0-9._]+) # version + (?: # possible file extensions + \.t(?:ar\.)?gz + )? + $ + !x and + ( $name, $version ) = ( $1, $2 ); + + # attempt to improve data with CPAN::DistnameInfo (but ignore any errors) + # TODO: also grab maturity and cpanid ? + # release_status = $dist->maturity eq 'released' ? 'stable' : 'unstable'; + # -(TRIAL|RC) => 'testing', '_' => 'unstable' + eval { + # DistnameInfo expects any directories in unix format (thanks jeroenl) + my $dnifile = $self->path_class_file + ->new($path)->as_foreign('Unix')->stringify; + # if it doesn't appear to have an extension fake one to help DistnameInfo + $dnifile .= '.tar.gz' unless $dnifile =~ /\.[a-z]\w+$/; + + my $dni = CPAN::DistnameInfo->new($dnifile); + my $dni_name = $dni->dist; + my $dni_version = $dni->version; + # if dni matched both name and version, or previous regexp didn't match + if ( $dni_name && $dni_version || !$name ) { + $name = $dni_name if $dni_name; + $version = $dni_version if $dni_version; + } + }; + warn $@ if $@; + } + return ($name, $version); +} + + +sub path_class_dir { $_[0]->{path_class_dir} ||= 'Path::Class::Dir' } +sub path_class_file { $_[0]->{path_class_file} ||= 'Path::Class::File' } + + +sub path_classify_dir { + my ($self, $dir) = @_; + $self->path_class_dir->new_foreign($self->file_spec, $dir) +} + +sub path_classify_file { + my ($self, $file) = @_; + $self->path_class_file->new_foreign($self->file_spec, $file) +} + + +sub perl_files { + return + grep { /\.pm$/ } + $_[0]->list_files; +} + + +sub physical_directory { + my ($self, @files) = @_; + + require File::Temp; + # dir will be removed when return value goes out of scope (in caller) + my $dir = File::Temp->newdir(); + + return $self->extract_into($dir, @files); +} + + +sub remove_root_dir { + my ($self, @files) = @_; + return unless @files; + + # FIXME: can we use File::Spec for these regexp's instead of [\\/] ? + + # grab the root dir from the first file + $files[0] =~ m{^([^\\/]+)[\\/]} + # if not matched quit now + or return (undef, @files); + + my $dir = $1; + my @rel; + + # strip $dir from each file + for (@files) { + + m{^\Q$dir\E[\\/](.+)$} + # if the match failed they're not all under the same root so just return now + or return (undef, @files); + + push @rel, $1; + } + + return ($dir, @rel); + +} + + +sub required_attribute { return } + + +sub root { + my ($self) = @_; + + # call list_files instead of find_files so that it caches the result + $self->list_files + unless exists $self->{root}; + + return $self->{root}; +} + + +sub set_name_and_version { + my ($self, @values) = @_; + my @fields = qw( name version ); + + foreach my $i ( 0 .. $#fields ){ + $self->{ $fields[$i] } = $values[$i] + if !exists $self->{ $fields[$i] } && defined $values[$i]; + } + return; +} + + +# version() defined with name() + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=for :stopwords Randy Stauner ACKNOWLEDGEMENTS TODO dist dists dir unix checksum checksums +David Jeffrey Ryan Sawyer Steinbrunner Thalhammer X + +=head1 NAME + +Dist::Metadata::Dist - Base class for format-specific implementations + +=head1 VERSION + +version 0.926 + +=head1 SYNOPSIS + + # don't use this, use a subclass + +=head1 DESCRIPTION + +This is a base class for different dist formats. + +The following methods B<must> be defined by subclasses: + +=over 4 + +=item * + +L</file_content> + +=item * + +L</find_files> + +=back + +=head1 METHODS + +=head2 new + +Simple constructor that subclasses can inherit. +Ensures the presence of L</required_attribute> +if defined by the subclass. + +=head2 default_file_spec + +Defaults to C<'Native'> in the base class +which will let L<File::Spec> determine the value. + +=head2 determine_name_and_version + +Some dist formats may define a way to determine the name and version. + +=head2 determine_packages + + $packages = $dist->determine_packages(@files); + +Search the specified files (or all files if unspecified) +for perl packages. + +Extracts the files to a temporary directory if necessary +and uses L<Module::Metadata> to discover package names and versions. + +=head2 extract_into + + $ddir = $dist->extract_into($dir); + ($ddir, @dfiles) = $dist->extract_into($dir, @files); + +Extracts the specified files (or all files if not specified) +into the specified directory. + +In list context this returns a list of the directory +(which may be a subdirectory of the C<$dir> passed in) +and the files extracted (in native OS (on-disk) format). + +In scalar context just the directory is returned. + +=head2 file_content + +Returns the content for the specified file from the dist. + +This B<must> be defined by subclasses. + +=head2 file_checksum + + $dist->file_checksum('lib/Mod/Name.pm', 'sha256'); + +Returns a checksum (hex digest) of the file content. + +The L<Digest> module is used to generate the checksums. +The value specified should be one accepted by C<< Digest->new >>. +A small effort is made to translate simpler names like +C<md5> into C<MD5> and C<sha1> into C<SHA-1> +(which are the names L<Digest> expects). + +If the type of checksum is not specified C<md5> will be used. + +=head2 find_files + +Determine the files contained in the dist. + +This is called from L</list_files> and cached on the object. + +This B<must> be defined by subclasses. + +=head2 file_spec + +Returns the OS name of the L<File::Spec> module used for this format. +This is mostly so subclasses can define a specific one +(as L</default_file_spec>) if necessary. + +A C<file_spec> attribute can be passed to the constructor +to override the default. + +B<NOTE>: This is used for the internal format of the dist. +Tar archives, for example, are always in unix format. +For operations outside of the dist, +the format determined by L<File::Spec> will always be used. + +=head2 full_path + + $dist->full_path("lib/Mod.pm"); # "root-dir/lib/Mod.pm" + +Used internally to put the L</root> directory back onto the file. + +=head2 list_files + +Returns a list of the files in the dist starting at the dist root. + +This calls L</find_files> to get a listing of the contents of the dist, +determines (and caches) the root directory (if any), +caches and returns the list of files with the root dir stripped. + + @files = $dist->list_files; + # something like qw( README META.yml lib/Mod.pm ) + +=head2 name + +The dist name if it could be determined. + +=head2 packages_from_directory + + $provides = $dist->packages_from_directory($dir, @files); + +Determines the packages provided by the perl modules found in a directory. +This is thin wrapper around +L<Module::Metadata/package_versions_from_directory>. +It returns a hashref like L<CPAN::Meta::Spec/provides>. + +B<NOTE>: C<$dir> must be a physical directory on the disk, +therefore C<@files> (if specified) must be in native OS format. +This function is called internally from L</determine_packages> +(which calls L<physical_directory> (which calls L</extract_into>)) +which manages these requirements. + +=head2 parse_name_and_version + + ($name, $version) = $dist->parse_name_and_version($path); + +Attempt to parse name and version from the provided string. +This will work for dists named like "Dist-Name-1.0". + +=head2 path_class_dir + +Returns the class name used for L<Path::Class::Dir> objects. + +=head2 path_class_file + +Returns the class name used for L<Path::Class::File> objects. + +=head2 path_classify_dir + +This is a shortcut for returning an object representing the provided +dir utilizing L</path_class_dir> and L</file_spec>. + +=head2 path_classify_file + +This is a shortcut for returning an object representing the provided +file utilizing L</path_class_file> and L</file_spec>. + +=head2 perl_files + +Returns the subset of L</list_files> that look like perl files. +Currently returns anything matching C</\.pm$/> + +B<TODO>: This should probably be customizable. + +=head2 physical_directory + + $dir = $dist->physical_directory(); + ($dir, @dir_files) = $dist->physical_directory(@files); + +Returns the path to a physical directory on the disk +where the specified files (if any) can be found. + +For in-memory formats this will make a temporary directory +and write the specified files (or all files) into it. + +The return value is the same as L</extract_into>: +In scalar context the path to the directory is returned. +In list context the (possibly adjusted) paths to any specified files +are appended to the return value. + +=head2 remove_root_dir + + my ($dir, @rel) = $dm->remove_root_dir(@files); + +If all the C<@files> are beneath the same root directory +(as is normally the case) this will strip the root directory off of each file +and return a list of the root directory and the stripped files. + +If there is no root directory the first element of the list will be C<undef>. + +=head2 required_attribute + +A single attribute that is required by the class. +Subclasses can define this to make L</new> C<croak> if it isn't present. + +=head2 root + +Returns the root directory of the dist (if there is one). + +=head2 set_name_and_version + +This is a convenience method for setting the name and version +if they haven't already been set. +This is often called by L</determine_name_and_version>. + +=head2 version + +Returns the version if it could be determined from the dist. + +=head1 SEE ALSO + +=over 4 + +=item * + +L<Dist::Metadata::Tar> - for examining a tar file + +=item * + +L<Dist::Metadata::Dir> - for a directory already on the disk + +=item * + +L<Dist::Metadata::Struct> - for mocking up a dist with perl data structures + +=back + +=head1 AUTHOR + +Randy Stauner <rwstauner@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2011 by Randy Stauner. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Dist/Metadata/Struct.pm b/lib/Dist/Metadata/Struct.pm new file mode 100644 index 0000000..bca5578 --- /dev/null +++ b/lib/Dist/Metadata/Struct.pm @@ -0,0 +1,131 @@ +# vim: set ts=2 sts=2 sw=2 expandtab smarttab: +# +# This file is part of Dist-Metadata +# +# This software is copyright (c) 2011 by Randy Stauner. +# +# This is free software; you can redistribute it and/or modify it under +# the same terms as the Perl 5 programming language system itself. +# +use strict; +use warnings; + +package Dist::Metadata::Struct; +our $AUTHORITY = 'cpan:RWSTAUNER'; +# ABSTRACT: Enable Dist::Metadata for a data structure +$Dist::Metadata::Struct::VERSION = '0.926'; +use Carp qw(croak carp); # core +use parent 'Dist::Metadata::Dist'; + +push(@Dist::Metadata::CARP_NOT, __PACKAGE__); + + +sub required_attribute { 'files' } + + +sub default_file_spec { 'Unix' } + + +sub file_content { + my ($self, $file) = @_; + # TODO: should we croak if not found? would be consistent with Dir + my $content = $self->{files}{ $self->full_path($file) }; + + # 5.10: given(ref($content)) + + if( my $ref = ref $content ){ + local $/; # do this here because of perl bug prior to perl 5.15 (7c2d9d0) + return $ref eq 'SCALAR' + # allow a scalar ref + ? $$content + # or an IO-like object + : $content->getline; + } + # else a simple string + return $content; +} + + +sub find_files { + my ($self) = @_; + + return keys %{ $self->{files} }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=for :stopwords Randy Stauner ACKNOWLEDGEMENTS TODO dist dists dir unix checksum checksums +David Jeffrey Ryan Sawyer Steinbrunner Thalhammer X + +=head1 NAME + +Dist::Metadata::Struct - Enable Dist::Metadata for a data structure + +=head1 VERSION + +version 0.926 + +=head1 SYNOPSIS + + my $dm = Dist::Metadata->new(struct => { + files => { + 'lib/Mod.pm' => 'package Mod; sub something { ... }', + 'README' => 'this is a fake dist, useful for testing', + } + }); + +=head1 DESCRIPTION + +This is a subclass of L<Dist::Metadata::Dist> +to enable mocking up a dist from perl data structures. + +This is mostly used for testing +but might be useful if you already have an in-memory representation +of a dist that you'd like to examine. + +It's probably not very useful on it's own though, +and should be used from L<Dist::Metadata/new>. + +=head1 METHODS + +=head2 new + + $dist = Dist::Metadata::Struct->new(files => { + 'lib/Mod.pm' => 'package Mod; sub something { ... }', + }); + +Accepts a C<files> parameter that should be a hash of +C<< { name => content, } >>. +Content can be a string, a reference to a string, or an IO object. + +=head2 default_file_spec + +C<Unix> is the default for consistency/simplicity +but C<file_spec> can be overridden in the constructor. + +=head2 file_content + +Returns the string content for the specified name. + +=head2 find_files + +Returns the keys of the C<files> hash. + +=head1 AUTHOR + +Randy Stauner <rwstauner@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2011 by Randy Stauner. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Dist/Metadata/Tar.pm b/lib/Dist/Metadata/Tar.pm new file mode 100644 index 0000000..bc89f49 --- /dev/null +++ b/lib/Dist/Metadata/Tar.pm @@ -0,0 +1,99 @@ +# vim: set ts=2 sts=2 sw=2 expandtab smarttab: +# +# This file is part of Dist-Metadata +# +# This software is copyright (c) 2011 by Randy Stauner. +# +# This is free software; you can redistribute it and/or modify it under +# the same terms as the Perl 5 programming language system itself. +# +use strict; +use warnings; + +package Dist::Metadata::Tar; +our $AUTHORITY = 'cpan:RWSTAUNER'; +# ABSTRACT: Enable Dist::Metadata for tar files +$Dist::Metadata::Tar::VERSION = '0.926'; +use Archive::Tar 1 (); # 0.07 isn't good enough +use Carp (); # core +use parent 'Dist::Metadata::Archive'; + +push(@Dist::Metadata::CARP_NOT, __PACKAGE__); + +sub file_content { + my ( $self, $file ) = @_; + return $self->archive->get_content( $self->full_path($file) ); +} + +sub find_files { + my ($self) = @_; + return + map { $_->full_path } + grep { $_->is_file } + $self->archive->get_files; +} + +sub read_archive { + my ($self, $file) = @_; + + my $archive = Archive::Tar->new(); + $archive->read($file); + + return $archive; +} + +sub tar { + warn __PACKAGE__ . '::tar() is deprecated. Use archive() instead.'; + return $_[0]->archive; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=for :stopwords Randy Stauner ACKNOWLEDGEMENTS TODO dist dists dir unix checksum checksums +David Jeffrey Ryan Sawyer Steinbrunner Thalhammer X + +=head1 NAME + +Dist::Metadata::Tar - Enable Dist::Metadata for tar files + +=head1 VERSION + +version 0.926 + +=head1 SYNOPSIS + + my $dist = Dist::Metadata->new(file => $path_to_archive); + +=head1 DESCRIPTION + +This is a subclass of L<Dist::Metadata::Dist> +(actually of L<Dist::Metadata::Archive>) +to enable determining the metadata from a tar file. + +This is probably the most useful subclass. + +It's probably not very useful on it's own though, +and should be used from L<Dist::Metadata/new>. + +=for Pod::Coverage tar + +=for test_synopsis my $path_to_archive; + +=head1 AUTHOR + +Randy Stauner <rwstauner@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2011 by Randy Stauner. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Dist/Metadata/Zip.pm b/lib/Dist/Metadata/Zip.pm new file mode 100644 index 0000000..ba136b2 --- /dev/null +++ b/lib/Dist/Metadata/Zip.pm @@ -0,0 +1,95 @@ +# vim: set ts=2 sts=2 sw=2 expandtab smarttab: +# +# This file is part of Dist-Metadata +# +# This software is copyright (c) 2011 by Randy Stauner. +# +# This is free software; you can redistribute it and/or modify it under +# the same terms as the Perl 5 programming language system itself. +# +use strict; +use warnings; + +package Dist::Metadata::Zip; +our $AUTHORITY = 'cpan:RWSTAUNER'; +# ABSTRACT: Enable Dist::Metadata for zip files +$Dist::Metadata::Zip::VERSION = '0.926'; +use Archive::Zip 1.30 (); +use Carp (); # core + +use parent 'Dist::Metadata::Archive'; + +push(@Dist::Metadata::CARP_NOT, __PACKAGE__); + +sub file_content { + my ($self, $file) = @_; + my ($content, $status) = $self->archive->contents( $self->full_path($file) ); + Carp::croak "Failed to get content of '$file' from archive" + if $status != Archive::Zip::AZ_OK(); + return $content; +} + +sub find_files { + my ($self) = @_; + return + map { $_->fileName } + grep { !$_->isDirectory } + $self->archive->members; +} + +sub read_archive { + my ($self, $file) = @_; + + my $archive = Archive::Zip->new(); + $archive->read($file) == Archive::Zip::AZ_OK() + or Carp::croak "Failed to read zip file!"; + + return $archive; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=for :stopwords Randy Stauner ACKNOWLEDGEMENTS TODO dist dists dir unix checksum checksums +David Jeffrey Ryan Sawyer Steinbrunner Thalhammer X + +=head1 NAME + +Dist::Metadata::Zip - Enable Dist::Metadata for zip files + +=head1 VERSION + +version 0.926 + +=head1 SYNOPSIS + + my $dist = Dist::Metadata->new(file => $path_to_archive); + +=head1 DESCRIPTION + +This is a subclass of L<Dist::Metadata::Dist> +(actually of L<Dist::Metadata::Archive>) +to enable determining the metadata from a zip file. + +It's probably not very useful on it's own +and should be used from L<Dist::Metadata/new>. + +=for test_synopsis my $path_to_archive; + +=head1 AUTHOR + +Randy Stauner <rwstauner@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2011 by Randy Stauner. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut |