Mercurial > repos > fgiacomoni > downloader_bank_hmdb
view lib/utils.pm @ 2:be504ccbc41c draft default tip
master branch Updating with tag :CI_COMMIT_TAG - - Fxx
author | fgiacomoni |
---|---|
date | Wed, 30 Nov 2022 16:14:27 +0000 |
parents | 7c9269bded0e |
children |
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 checkHttpUrl ## Description : check if a http url exists or not and warn/die ## Input : $url ## Output : $warn ## Usage : my ( $warn ) = checkHttpUrl ( $url ) ; =cut ## START of SUB sub checkHttpUrl { ## Retrieve Values my $self = shift ; my ( $url ) = @_; my ( $warn ) = ( undef ) ; my $ua = new LWP::UserAgent; ## just make different not existing/time out $ua->timeout(10); if ($ua->head($url)) { print "\t$url DOES EXIST\n"; } else { croak "\t$url DOES not exist or timeout\n";; } return ($warn) ; } ### 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; $ua->agent("Mozilla/5.0 (Macintosh; Intel Mac OS X 10.11; rv:64.0) Gecko/20100101 Firefox/64.0"); $ua->from('franck.giacomoni@inrae.fr'); $ua->ssl_opts(timeout => 100, verify_hostname => 0); my $result = $ua->head($url); for my $header_name ($result->header_field_names) { if ( ($header_name eq 'Last-Modified') or ($header_name eq 'last-Modified') or ($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 "\tVERSION IS: $version\n" ; } if (!$version) { croak "\t /!\\ the current version of the db is not findable !!" } 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 $hstatus = 404 ; # default if ( (defined $url ) and (defined $fileNameToGet ) ) { my $ua = LWP::UserAgent->new(); $ua->agent("Mozilla/5.0 (Macintosh; Intel Mac OS X 10.11; rv:64.0) Gecko/20100101 Firefox/64.0"); $ua->from('franck.giacomoni@inrae.fr'); $ua->ssl_opts(timeout => 100, verify_hostname => 0); # my $hstatus = getstore ($url, $fileNameToGet); my $response = $ua->get($url); if ($response->is_error) { $hstatus = $response->status_line ; print "\t\t$hstatus: ", status_message($hstatus), "\n"; carp $response->status_line, "\n"; } else { $hstatus = $response->status_line ; } open my $fh, '>', $fileNameToGet or die $!; binmode $fh; print $fh $response->decoded_content; # if($hstatus != HTTP_OK) { # print "\t\t$hstatus: ", status_message($hstatus), "\n"; # } # if (!-e $fileNameToGet) { carp "None file (should be $fileNameToGet) was download from the given url($url)\n" ; } } return($hstatus) ; } ## 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