From: David Golden <dagolden@cpan.org>
Date: Wed, 3 Aug 2011 01:17:27 +0000 (-0400)
Subject: Add new_from_handle method [RT #68875]
X-Git-Tag: release_1.0.5~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FModule-Metadata.git;a=commitdiff_plain;h=f33c0a6c2cb3a0cd474d9368d7cbec39e9fd04fe

Add new_from_handle method [RT #68875]
---

diff --git a/Changes b/Changes
index d588619..0280df0 100644
--- a/Changes
+++ b/Changes
@@ -1,6 +1,7 @@
 1.0.5 2011-08-01 08:24:00
   - Localize $package::VERSION during version discovery (MIYAGAWA)
   - Fix references to Module::Build::ModuleInfo [RT #66133] (DAGOLDEN)
+  - Added 'new_from_handle()' method [RT #68875] (DAGOLDEN)
 
 1.0.4 2011-02-03 07:55:00
   - Fix broken metadata.t when @INC has relative paths (JJORE)
diff --git a/lib/Module/Metadata.pm b/lib/Module/Metadata.pm
index bbbee35..8629a98 100644
--- a/lib/Module/Metadata.pm
+++ b/lib/Module/Metadata.pm
@@ -69,6 +69,18 @@ sub new_from_file {
   return $class->_init(undef, $filename, @_);
 }
 
+sub new_from_handle {
+  my $class    = shift;
+  my $handle   = shift;
+  my $filename = shift;
+  return undef unless defined($handle) && defined($filename);
+  $filename = File::Spec->rel2abs( $filename );
+
+  return $class->_init(undef, $filename, @_, handle => $handle);
+
+}
+
+
 sub new_from_module {
   my $class   = shift;
   my $module  = shift;
@@ -281,6 +293,7 @@ sub _init {
   my $filename = shift;
   my %props = @_;
 
+  my $handle = delete $props{handle};
   my( %valid_props, @valid_props );
   @valid_props = qw( collect_pod inc );
   @valid_props{@valid_props} = delete( @props{@valid_props} );
@@ -301,7 +314,12 @@ sub _init {
 
   my $self = bless(\%data, $class);
 
-  $self->_parse_file();
+  if ( $handle ) {
+    $self->_parse_fh($handle);
+  }
+  else {
+    $self->_parse_file();
+  }
 
   unless($self->{module} and length($self->{module})) {
     my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
@@ -658,6 +676,14 @@ argument C<collect_pod> which is a boolean that determines whether
 POD data is collected and stored for reference. POD data is not
 collected by default. POD headings are always collected.
 
+=item new_from_handle($handle, $filename, collect_pod => 1)
+
+This works just like C<new_from_file>, except that a handle can be provided
+as the first argument.  Note that there is no validation to confirm that the
+handle is a handle or something that can act like one.  Passing something that
+isn't a handle will cause a exception when trying to read from it.  The
+C<filename> argument is mandatory or undef will be returned.
+
 =item new_from_module($module, collect_pod => 1, inc => \@dirs)
 
 Construct a C<Module::Metadata> object given a module or package name. In addition
@@ -666,6 +692,7 @@ method accepts a C<inc> argument which is a reference to an array of
 of directories to search for the module. If none are given, the
 default is @INC.
 
+
 =item name()
 
 Returns the name of the package represented by this module. If there
diff --git a/t/metadata.t b/t/metadata.t
index f3d08aa..60cb316 100644
--- a/t/metadata.t
+++ b/t/metadata.t
@@ -4,6 +4,7 @@
 
 use strict;
 use lib 't/lib';
+use IO::File;
 use MBTest;
 
 # parse various module $VERSION lines
@@ -173,7 +174,7 @@ our $VERSION = '1.23_00_00';
 );
 my %modules = reverse @modules;
 
-plan tests => 37 + 2 * keys( %modules );
+plan tests => 39 + 2 * keys( %modules );
 
 require_ok('Module::Metadata');
 
@@ -210,6 +211,14 @@ $file = File::Spec->catfile( 'lib', split( /::/, $dist->name ) ) . '.pm';
 $pm_info = Module::Metadata->new_from_file( $file );
 ok( defined( $pm_info ), 'new_from_file() succeeds' );
 
+# construct from filehandle
+my $handle = IO::File->new($file);
+$pm_info = Module::Metadata->new_from_handle( $handle, $file );
+ok( defined( $pm_info ), 'new_from_handle() succeeds' );
+$pm_info = Module::Metadata->new_from_handle( $handle );
+is( $pm_info, undef, "new_from_handle() without filename returns undef" );
+
+
 # construct from module name, using custom include path
 $pm_info = Module::Metadata->new_from_module(
 	     $dist->name, inc => [ 'lib', @INC ] );