package CPAN::Access::AdHoc::Archive::Null; use 5.008; use strict; use warnings; use base qw{ CPAN::Access::AdHoc::Archive }; use CPAN::Access::AdHoc::Util qw{ :carp }; use File::Path 2.07 (); use File::Spec (); use HTTP::Date (); use IO::File (); use IO::Uncompress::Bunzip2 (); use IO::Uncompress::Gunzip (); our $VERSION = '0.000_06'; my %decode = ( gzip => sub { my ( $content ) = @_; my $rslt; IO::Uncompress::Gunzip::gunzip( $content, \$rslt ); return $rslt; }, 'x-bzip2' => sub { my ( $content ) = @_; my $rslt; IO::Uncompress::Bunzip2::bunzip2( $content, \$rslt ); return $rslt; }, ); sub new { my ( $class, %arg ) = @_; my $self = bless {}, ref $class || $class; my $attr = $self->__attr(); ref $arg{content} or defined $arg{path} or $arg{path} = $arg{content}; if ( defined( my $content = delete $arg{content} ) ) { my $mtime = delete $arg{mtime}; if ( my $encoding = delete $arg{encoding} ) { $decode{$encoding} or __wail( "Unsupported encoding '$encoding'" ); $content = $decode{$encoding}->( $content ); } elsif ( ! ref $content ) { local $/ = undef; # Slurp mode open my $fh, '<', $content or __wail( "Unable to open $content: $!" ); my @stat = stat $fh; $content = <$fh>; close $fh; @stat and $mtime = $stat[9]; } elsif ( 'SCALAR' eq ref $content ) { $content = ${ $content }; } my ( $base_dir, $file_name ); if ( $arg{path} ) { ( undef, $base_dir, $file_name ) = File::Spec->splitpath( $arg{path} ); $base_dir =~ s{ \A authors/id/ ([^/]) / ( \1 [^/] ) / \2 [^/]* / }{}smx; $file_name =~ s/ [.] (?: gz | bz2 ) \z //smx; } else { ( $base_dir, $file_name ) = ( '', 'unknown' ); } $attr->{base_dir} = $base_dir; $attr->{contents}{$file_name} = { content => $content, mtime => $mtime, }; $self->archive( undef ); } $self->path( delete $arg{path} ); return $self; } sub base_directory { my ( $self ) = @_; my $attr = $self->__attr(); return $attr->{base_dir}; } sub extract { my ( $self ) = @_; my $attr = $self->__attr(); my @dirs = grep { defined $_ and '' ne $_ } File::Spec->splitdir( $self->base_directory() ); my $where; foreach my $dir ( @dirs ) { $where = defined $where ? File::Spec->catdir( $where, $dir ) : $dir; -d $where or mkdir $where or __wail( "Unable to mkdir $where: $!" ); } foreach my $name ( keys %{ $attr->{contents} } ) { my $path = File::Spec->catfile( $where, $name ); my $fh = IO::File->new( $path, '>' ) or __wail( "Unable to open $path for output: $!" ); print { $fh } $attr->{contents}{$name}{content}; close $fh; my $mtime = $attr->{contents}{$name}{mtime}; utime $mtime, $mtime, $path; } return $self; } sub get_item_content { my ( $self, $file ) = @_; my $attr = $self->__attr(); defined $file or ( $file ) = keys %{ $attr->{contents} }; return $attr->{contents}{$file}{content}; } sub get_item_mtime { my ( $self, $file ) = @_; my $attr = $self->__attr(); defined $file or ( $file ) = keys %{ $attr->{contents} }; return $attr->{contents}{$file}{mtime}; } { my %handled = map { $_ => 1 } qw{ application/octet-stream }; sub handle_http_response { __whinge( join ' ', 'handle_http_response() is deprecated in favor of', '__handle_http_response()', ); goto &__handle_http_response; } sub __handle_http_response { my ( $class, $rslt ) = @_; my $content_type = $rslt->header( 'Content-Type' ); $handled{ $content_type } or $content_type =~ m{ \A text/ }smx or return; my $mtime = HTTP::Date::str2time( scalar $rslt->header( 'Last-Modified' ) ); return $class->new( content => \( scalar $rslt->content() ), encoding => scalar $rslt->header( 'Content-Encoding' ), mtime => $mtime, path => scalar $rslt->header( 'Content-Location' ), ); } } sub item_present { my ( $self, $item ) = @_; my $attr = $self->__attr(); return defined $attr->{contents}{$item}; } sub list_contents { my ( $self ) = @_; my $attr = $self->__attr(); return ( sort keys %{ $attr->{contents} } ); } 1; __END__ =head1 NAME CPAN::Access::AdHoc::Archive::Null - Archive-like wrapper for un-archived data. =head1 SYNOPSIS use CPAN::Access::AdHoc::Archive::Null; use LWP::UserAgent; my $ua = LWP::UserAgent->new(); my $resp = $ua->get( ... ); my $tar = CPAN::Access::AdHoc::Archive::Null->new( content => \( $resp->content() ), encoding => $resp->header( 'Content-Encoding' ), ); =head1 DESCRIPTION This class wraps an un-archived file or text block, providing a C<CPAN::Access::AdHoc::Archive>-compliant interface. It is private to the C<CPAN-Access-AdHoc> package. =head1 METHODS This class supports the following public methods: =head2 new This static method instantiates the object, and possibly loads it. The supported arguments are: =over =item content This is the content to be loaded into the object. A scalar reference is assumed to be the literal content. A non-reference is assumed to be the file name. Any other value is unsupported. If this argument is a scalar reference, the file name is set to 'unknown', and the contents are accessed under that name. =item encoding This is the MIME encoding of the content. It is ignored if the content is not present. =item mtime This is the modification time of the content. If the content is not a reference, it is taken as a file name, so this argument is ignored and the modification time of the file is used instead. =item path This is intended to be a path to the content. If not specified, and the content argument is a file name (i.e. not a reference), this defaults to the content argument. =back =head2 base_directory Because there is no real distribution inside this wrapper, we have no real place to get a base directory. So we have to invent one. For files that appear to be single-file unpackaged distributions (that is, with paths like F<authors/id/T/TO/TOMC/scripts/whenon.dir/LastLog/File.pm.gz>), the base directory is taken to be the directory portion of the path which is to the right of the author directory; that is, F<scripts/whenon.dir/LastLog/> in the above example. For other files, the base directory is simply the directory portion of the file path relative to the base of the CPAN mirror. =head2 extract Because there is no real distribution inside this wrapper, we have to do our own extract functionality. This simply creates the base directory tree and then extracts the file into it. =head2 get_item_content This method returns the content of the named item in the archive. Because there can only ever be one file in the pseudo-archive, if the argument is C<undef>, the content of that file is returned. =head2 list_contents This method lists the contents of the archive. It always returns exactly one name. =head1 SUPPORT Support is by the author. Please file bug reports at L<http://rt.cpan.org>, or in electronic mail to the author. =head1 AUTHOR Thomas R. Wyant, III F<wyant at cpan dot org> =head1 COPYRIGHT AND LICENSE Copyright (C) 2012 by Thomas R. Wyant, III This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. This program is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. =cut # ex: set textwidth=72 :