view lib/utils.pm @ 1:4373f936111d draft

" master branch Updating with tag :CI_COMMIT_TAG - - Fxx"
author fgiacomoni
date Tue, 21 Jan 2020 16:09:45 -0500
parents 7c9269bded0e
children be504ccbc41c
line wrap: on
line source

package utils ;

use strict;
use warnings ;
use Exporter ;
use Carp ;

use Data::Dumper ;
use LWP::UserAgent ;
use LWP::Simple ;
use HTTP::Status qw(:constants :is status_message);
use Archive::Zip ;
use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;

use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS);

our $VERSION = "1.0";
our @ISA = qw(Exporter);
our @EXPORT = qw( getHttpFileVersion getHttpFile unzipFile );
our %EXPORT_TAGS = ( ALL => [qw( getHttpFileVersion getHttpFile unzipFile )] );

=head1 NAME

My::Module - An example module

=head1 SYNOPSIS

    use My::Module;
    my $object = My::Module->new();
    print $object->as_string;

=head1 DESCRIPTION

This module does not really exist, it
was made for the sole purpose of
demonstrating how POD works.

=head1 METHODS

Methods are :

=head2 METHOD new

	## Description : new
	## Input : $self
	## Ouput : bless $self ;
	## Usage : new() ;

=cut

sub new {
    ## Variables
    my $self={};
    bless($self) ;
    return $self ;
}
### END of SUB

=head2 METHOD getHttpFileVersion

	## Description : fetch the version of a file from its http header
	## Input : $url
	## Output : $version
	## Usage : $version= getHttpFileVersion($url) ;
	
=cut
## START of SUB
sub getHttpFileVersion {
	## Retrieve Values
    my $self = shift ;
    my ( $url ) = @_ ;
    
    my ( $version ) = undef ;
    
    # based on https://stackoverflow.com/questions/36903905/extract-headers-from-http-request-in-perl
	my $ua = new LWP::UserAgent;
	my $result = $ua->head($url);
	
	for my $header_name ($result->header_field_names) {
		
		if ($header_name eq 'Last-Modified') {
#			print $result->header($header_name)."\n";
			if ($result->header($header_name) =~/[a-z|A-Z]+,\s(.*)\s[0-9]+:[0-9]+:[0-9]+\s[a-z|A-Z]+$/) {
				$version = $1 ;
				
				#version format is DD Month(3letters) YYYY (as "09 Jul 2018")
				if ($version =~/([0-9]+)\s([a-z|A-Z]+)\s([0-9]+)/) {
					$version = 'v'.$3.$2.$1 ;
				}
				else{
					warn "the current version format - DD Month(3letters) YYYY - doesn't match with template" ;
				}
			}
		}
		else {
    		next ;
		}
#    	print $version ;
	}

    return($version) ;
}
## END of SUB

=head2 METHOD getHttpFile

	## Description : fetch a file from http
	## Input : $url, $filename
	## Output : $file
	## Usage : $file= getHttpFile($url, $filename) ;
	
=cut
## START of SUB
sub getHttpFile {
	## Retrieve Values
    my $self = shift ;
    my ( $url, $fileNameToGet ) = @_ ;
    
    my ( $fileName ) = undef ;
    
    if ( (defined $url ) and (defined $fileNameToGet ) ) {
    	my $ua = LWP::UserAgent->new();
    	my $hstatus =  getstore ($url, $fileNameToGet);
			
		if($hstatus != HTTP_OK) {
			print "$hstatus: ", status_message($hstatus), "\n";
		}
			
		if (!-e $fileNameToGet) {
			croak "None file (should be $fileNameToGet) was download from the given url($url)\n" ;
		}
    }

    return(1) ;
}
## END of SUB

=head2 METHOD unzipFile

	## Description : unzip a wanted file from a zip archive
	## Input : $archive, $filePath, $fileName
	## Output : 1
	## Usage : unzipFile($archive, $filePath, $fileName) ;
	
=cut
sub unzipFile {
	## Retrieve Values
    my $self = shift ;
    my ($archive, $filePath, $fileName) = @_ ;
    
    my $zip = Archive::Zip->new($archive);
    
    if ( (defined $fileName) and (defined $filePath) ) {
    	
    	foreach my $file ($zip->members) {
        	next unless ($file->fileName eq $fileName);
        	$file->extractToFileNamed($filePath);
    	}
       
    	croak "There was a problem extracting $fileName from $archive" unless (-e $filePath);	
    }
    else {
    	croak "the given filePath or the filename are undef\n" ;
    }
    
    return 1;
} 
## END of SUB

=head2 METHOD gunzipFile

	## Description : unzip a wanted file from a zip archive
	## Input : $archive, $filePath, $fileName
	## Output : 1
	## Usage : gunzipFile($archive, $filePath, $fileName) ;
	
=cut
sub gunzipFile {
	## Retrieve Values
    my $self = shift ;
    my ($archive, $filePath, $fileName) = @_ ;
    
    if ( (defined $fileName) and (defined $filePath) ) {
    	
        gunzip $archive => $filePath
        or die "gunzip failed: $GunzipError\n";	
    }
    else {
    	croak "the given filePath or the filename are undef\n" ;
    }
    
    return 1;
} 
## END of SUB


=head2 METHOD cleanUnzip

	## Description : clean zip file if the unzip is successfully run
	## Input : $archive, $filePath
	## Output : 1
	## Usage : unzipFile($archive, $want, $dir) ;
	
=cut
sub cleanUnzip {
	## Retrieve Values
    my $self = shift ;
    my ($archive, $filePath ) = @_ ;
    
    if ( (defined $archive) and (defined $filePath) ) {
    	
    	croak "There was a problem extracting $filePath from $archive" unless (-e $filePath);
    	unlink $archive ;
    }
    else {
    	croak "Given filePath or the archive are undef\n" ;
    }
    
    return 1;
} 
## END of SUB

1 ;


__END__

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

 perldoc XXX.pm

=head1 Exports

=over 4

=item :ALL is ...

=back

=head1 AUTHOR

Franck Giacomoni E<lt>franck.giacomoni@clermont.inra.frE<gt>

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=head1 VERSION

version 1 : xx / xx / 201x

version 2 : ??

=cut