Mercurial > repos > fgiacomoni > downloader_bank_hmdb
comparison lib/utils.pm @ 0:7c9269bded0e draft
Init repository for [downloader_bank_hmdb]
author | fgiacomoni |
---|---|
date | Tue, 14 Jan 2020 05:21:23 -0500 |
parents | |
children | be504ccbc41c |
comparison
equal
deleted
inserted
replaced
-1:000000000000 | 0:7c9269bded0e |
---|---|
1 package utils ; | |
2 | |
3 use strict; | |
4 use warnings ; | |
5 use Exporter ; | |
6 use Carp ; | |
7 | |
8 use Data::Dumper ; | |
9 use LWP::UserAgent ; | |
10 use LWP::Simple ; | |
11 use HTTP::Status qw(:constants :is status_message); | |
12 use Archive::Zip ; | |
13 use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; | |
14 | |
15 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS); | |
16 | |
17 our $VERSION = "1.0"; | |
18 our @ISA = qw(Exporter); | |
19 our @EXPORT = qw( getHttpFileVersion getHttpFile unzipFile ); | |
20 our %EXPORT_TAGS = ( ALL => [qw( getHttpFileVersion getHttpFile unzipFile )] ); | |
21 | |
22 =head1 NAME | |
23 | |
24 My::Module - An example module | |
25 | |
26 =head1 SYNOPSIS | |
27 | |
28 use My::Module; | |
29 my $object = My::Module->new(); | |
30 print $object->as_string; | |
31 | |
32 =head1 DESCRIPTION | |
33 | |
34 This module does not really exist, it | |
35 was made for the sole purpose of | |
36 demonstrating how POD works. | |
37 | |
38 =head1 METHODS | |
39 | |
40 Methods are : | |
41 | |
42 =head2 METHOD new | |
43 | |
44 ## Description : new | |
45 ## Input : $self | |
46 ## Ouput : bless $self ; | |
47 ## Usage : new() ; | |
48 | |
49 =cut | |
50 | |
51 sub new { | |
52 ## Variables | |
53 my $self={}; | |
54 bless($self) ; | |
55 return $self ; | |
56 } | |
57 ### END of SUB | |
58 | |
59 =head2 METHOD getHttpFileVersion | |
60 | |
61 ## Description : fetch the version of a file from its http header | |
62 ## Input : $url | |
63 ## Output : $version | |
64 ## Usage : $version= getHttpFileVersion($url) ; | |
65 | |
66 =cut | |
67 ## START of SUB | |
68 sub getHttpFileVersion { | |
69 ## Retrieve Values | |
70 my $self = shift ; | |
71 my ( $url ) = @_ ; | |
72 | |
73 my ( $version ) = undef ; | |
74 | |
75 # based on https://stackoverflow.com/questions/36903905/extract-headers-from-http-request-in-perl | |
76 my $ua = new LWP::UserAgent; | |
77 my $result = $ua->head($url); | |
78 | |
79 for my $header_name ($result->header_field_names) { | |
80 | |
81 if ($header_name eq 'Last-Modified') { | |
82 # print $result->header($header_name)."\n"; | |
83 if ($result->header($header_name) =~/[a-z|A-Z]+,\s(.*)\s[0-9]+:[0-9]+:[0-9]+\s[a-z|A-Z]+$/) { | |
84 $version = $1 ; | |
85 | |
86 #version format is DD Month(3letters) YYYY (as "09 Jul 2018") | |
87 if ($version =~/([0-9]+)\s([a-z|A-Z]+)\s([0-9]+)/) { | |
88 $version = 'v'.$3.$2.$1 ; | |
89 } | |
90 else{ | |
91 warn "the current version format - DD Month(3letters) YYYY - doesn't match with template" ; | |
92 } | |
93 } | |
94 } | |
95 else { | |
96 next ; | |
97 } | |
98 # print $version ; | |
99 } | |
100 | |
101 return($version) ; | |
102 } | |
103 ## END of SUB | |
104 | |
105 =head2 METHOD getHttpFile | |
106 | |
107 ## Description : fetch a file from http | |
108 ## Input : $url, $filename | |
109 ## Output : $file | |
110 ## Usage : $file= getHttpFile($url, $filename) ; | |
111 | |
112 =cut | |
113 ## START of SUB | |
114 sub getHttpFile { | |
115 ## Retrieve Values | |
116 my $self = shift ; | |
117 my ( $url, $fileNameToGet ) = @_ ; | |
118 | |
119 my ( $fileName ) = undef ; | |
120 | |
121 if ( (defined $url ) and (defined $fileNameToGet ) ) { | |
122 my $ua = LWP::UserAgent->new(); | |
123 my $hstatus = getstore ($url, $fileNameToGet); | |
124 | |
125 if($hstatus != HTTP_OK) { | |
126 print "$hstatus: ", status_message($hstatus), "\n"; | |
127 } | |
128 | |
129 if (!-e $fileNameToGet) { | |
130 croak "None file (should be $fileNameToGet) was download from the given url($url)\n" ; | |
131 } | |
132 } | |
133 | |
134 return(1) ; | |
135 } | |
136 ## END of SUB | |
137 | |
138 =head2 METHOD unzipFile | |
139 | |
140 ## Description : unzip a wanted file from a zip archive | |
141 ## Input : $archive, $filePath, $fileName | |
142 ## Output : 1 | |
143 ## Usage : unzipFile($archive, $filePath, $fileName) ; | |
144 | |
145 =cut | |
146 sub unzipFile { | |
147 ## Retrieve Values | |
148 my $self = shift ; | |
149 my ($archive, $filePath, $fileName) = @_ ; | |
150 | |
151 my $zip = Archive::Zip->new($archive); | |
152 | |
153 if ( (defined $fileName) and (defined $filePath) ) { | |
154 | |
155 foreach my $file ($zip->members) { | |
156 next unless ($file->fileName eq $fileName); | |
157 $file->extractToFileNamed($filePath); | |
158 } | |
159 | |
160 croak "There was a problem extracting $fileName from $archive" unless (-e $filePath); | |
161 } | |
162 else { | |
163 croak "the given filePath or the filename are undef\n" ; | |
164 } | |
165 | |
166 return 1; | |
167 } | |
168 ## END of SUB | |
169 | |
170 =head2 METHOD gunzipFile | |
171 | |
172 ## Description : unzip a wanted file from a zip archive | |
173 ## Input : $archive, $filePath, $fileName | |
174 ## Output : 1 | |
175 ## Usage : gunzipFile($archive, $filePath, $fileName) ; | |
176 | |
177 =cut | |
178 sub gunzipFile { | |
179 ## Retrieve Values | |
180 my $self = shift ; | |
181 my ($archive, $filePath, $fileName) = @_ ; | |
182 | |
183 if ( (defined $fileName) and (defined $filePath) ) { | |
184 | |
185 gunzip $archive => $filePath | |
186 or die "gunzip failed: $GunzipError\n"; | |
187 } | |
188 else { | |
189 croak "the given filePath or the filename are undef\n" ; | |
190 } | |
191 | |
192 return 1; | |
193 } | |
194 ## END of SUB | |
195 | |
196 | |
197 =head2 METHOD cleanUnzip | |
198 | |
199 ## Description : clean zip file if the unzip is successfully run | |
200 ## Input : $archive, $filePath | |
201 ## Output : 1 | |
202 ## Usage : unzipFile($archive, $want, $dir) ; | |
203 | |
204 =cut | |
205 sub cleanUnzip { | |
206 ## Retrieve Values | |
207 my $self = shift ; | |
208 my ($archive, $filePath ) = @_ ; | |
209 | |
210 if ( (defined $archive) and (defined $filePath) ) { | |
211 | |
212 croak "There was a problem extracting $filePath from $archive" unless (-e $filePath); | |
213 unlink $archive ; | |
214 } | |
215 else { | |
216 croak "Given filePath or the archive are undef\n" ; | |
217 } | |
218 | |
219 return 1; | |
220 } | |
221 ## END of SUB | |
222 | |
223 1 ; | |
224 | |
225 | |
226 __END__ | |
227 | |
228 =head1 SUPPORT | |
229 | |
230 You can find documentation for this module with the perldoc command. | |
231 | |
232 perldoc XXX.pm | |
233 | |
234 =head1 Exports | |
235 | |
236 =over 4 | |
237 | |
238 =item :ALL is ... | |
239 | |
240 =back | |
241 | |
242 =head1 AUTHOR | |
243 | |
244 Franck Giacomoni E<lt>franck.giacomoni@clermont.inra.frE<gt> | |
245 | |
246 =head1 LICENSE | |
247 | |
248 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. | |
249 | |
250 =head1 VERSION | |
251 | |
252 version 1 : xx / xx / 201x | |
253 | |
254 version 2 : ?? | |
255 | |
256 =cut |