source: main/trunk/greenstone2/perllib/servercontrol.pm@ 32826

Last change on this file since 32826 was 32826, checked in by ak19, 5 years ago

GLI build log display removes lines starting with unrecognised elements/tags, but when we wget a webpage when activating/deactivating and print out that webpage's contents for debugging, we'd like to see the lines starting with tags too since they can be the most useful. Don't want to make GLI behave differently, so servercontrol changes such tags to be embedded in [] instead of <> so that GLI still dispklays the informative lines
File size: 26.1 KB
Line 
1#############################################################################
2#
3# activate.pm -- functions to get the GS library URL, ping the library URL,
4# activate and deactivate a collection.
5#
6# A component of the Greenstone digital library software
7# from the New Zealand Digital Library Project at the
8# University of Waikato, New Zealand.
9#
10# Copyright (C) 1999 New Zealand Digital Library Project
11#
12# This program is free software; you can redistribute it and/or modify
13# it under the terms of the GNU General Public License as published by
14# the Free Software Foundation; either version 2 of the License, or
15# (at your option) any later version.
16#
17# This program is distributed in the hope that it will be useful,
18# but WITHOUT ANY WARRANTY; without even the implied warranty of
19# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20# GNU General Public License for more details.
21#
22# You should have received a copy of the GNU General Public License
23# along with this program; if not, write to the Free Software
24# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25#
26###############################################################################
27
28package servercontrol;
29
30
31use strict;
32no strict 'refs'; # allow filehandles to be variables and vice versa
33no strict 'subs'; # allow barewords (eg STDERR) as function arguments
34
35# Greenstone includes
36use printusage;
37use parse2;
38
39
40# The perl library imports below are used by deprecated methods config_old(), is_URL_active() and pingHost()
41# If the following library imports are not supported by your perl installation, comment out these
42# imports and move the methods config_old(), is_URL_active() and pingHost() out to a temporary file.
43use HTTP::Response;
44use LWP::Simple qw($ua !head); # import useragent object as $ua from the full LWP to use along with LWP::Simple
45 # don't import LWP::Simple's head function by name since it can conflict with CGI:head())
46#use CGI qw(:standard); # then only CGI.pm defines a head()
47use Net::Ping;
48use URI;
49
50
51sub new
52{
53 my $class = shift(@_);
54
55 my ($qualified_collection, $site, $verbosity, $build_dir, $index_dir, $collect_dir, $library_url, $library_name) = @_;
56
57 # library_url: to be specified on the cmdline if not using a GS-included web server
58 # the GSDL_LIBRARY_URL env var is useful when running cmdline buildcol.pl in the linux package manager versions of GS3
59
60 my $self = {'build_dir' => $build_dir,
61 'index_dir' => $index_dir,
62 'collect_dir' => $collect_dir,
63 'site' => $site,
64 'qualified_collection' => $qualified_collection,
65 #'is_persistent_server' => undef,
66 'library_url' => $library_url || $ENV{'GSDL_LIBRARY_URL'} || undef, # to be specified on the cmdline if not using a GS-included web server
67 'library_name' => $library_name,
68 #'gs_mode' => "gs2",
69 'verbosity' => $verbosity || 2
70 };
71
72 if ((defined $site) && ($site ne "")) { # GS3
73 $self->{'gs_mode'} = "gs3";
74 } else {
75 $self->{'gs_mode'} = "gs2";
76 }
77
78 return bless($self, $class);
79}
80
81## TODO: gsprintf to $self->{'out'} in these 2 print functions
82## See buildcolutils.pm new() for setting up $out
83
84sub print_task_msg {
85 my $self = shift(@_);
86 my ($task_msg, $verbosity_setting) = @_;
87
88 $verbosity_setting = $self->{'verbosity'} unless $verbosity_setting;
89 #$verbosity_setting = 1 unless defined $verbosity;
90 if($verbosity_setting >= 1) {
91 print STDERR "\n";
92 print STDERR "************************\n";
93 print STDERR "* $task_msg\n";
94 print STDERR "************************\n";
95 }
96}
97
98# Prints messages if the verbosity is right. Does not add new lines.
99sub print_msg {
100 my $self = shift(@_);
101 my ($msg, $min_verbosity, $verbosity_setting) = @_;
102
103 # only display error messages if the current
104 # verbosity setting >= the minimum verbosity level
105 # needed for that message to be displayed.
106
107 $verbosity_setting = $self->{'verbosity'} unless defined $verbosity_setting;
108 $min_verbosity = 1 unless defined $min_verbosity;
109 if($verbosity_setting >= $min_verbosity) { # by default display all 1 messages
110 print STDERR "$msg";
111 }
112}
113
114# Method to send a command to a GS2 or GS3 library_URL
115# the commands used in this script can be activate, deactivate, ping,
116# and is-persistent (is-persistent only implemented for GS2).
117sub config {
118 my $self = shift(@_);
119 my ($command, $check_message_against_regex, $expected_error_code, $silent) = @_;
120
121 my $library_url = $self->get_library_URL(); #$self->{'library_url'};
122
123
124 # Gatherer.java's configGS3Server doesn't use the site variable
125 # so we don't have to either
126
127 # for GS2, getting the HTTP status isn't enough, we need to read the output
128 # since this is what CollectionManager.config() stipulates.
129 # Using LWP::UserAgent::get($url) for this
130
131 if(!defined $library_url) {
132 return 0;
133 }
134 else {
135 # ampersands need to be escaped
136 # - with single quotes around it for linux for the cmd to run in bash subshell
137 # - with a ^ before it on windows for the cmd to run in a DOS prompt subshell
138 # - or the entire wget command should be nested in double quotes (single quotes don't work on windows)
139 my $wgetCommand = $command;
140
141 my $wget_file_path = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, "bin", $ENV{'GSDLOS'}, "wget");
142 my $tmpfilename = &util::get_tmp_filename(".html"); # random file name with html extension in tmp location in which we'll store the HTML page retrieved by wget
143
144 # https://www.gnu.org/software/wget/manual/wget.html
145 # output-document set to - (STDOUT), so page is streamed to STDOUT
146 # timeout: 5 seconds, tries: 1
147 # wget sends status information and response code to STDERR, so redirect it to STDOUT
148 # Searching for "perl backtick operator redirect stderr to stdout":
149 # http://www.perlmonks.org/?node=How%20can%20I%20capture%20STDERR%20from%20an%20external%20command%3F
150 ##$wgetCommand = "\"$wget_file_path\" --spider -T 5 -t 1 \"$library_url$wgetCommand\" 2>&1"; # won't save page
151 #$wgetCommand = "\"$wget_file_path\" --output-document=- -T 5 -t 1 \"$library_url$wgetCommand\" 2>&1"; # THIS CAN MIX UP STDERR WITH STDOUT IN THE VERY LINE WE REGEX TEST AGAINST EXPECTED OUTPUT!!
152 $wgetCommand = "\"$wget_file_path\" --output-document=\"$tmpfilename\" -T 5 -t 1 \"$library_url$wgetCommand\" 2>&1"; # keep stderr (response code, response_content) separate from html page content
153
154 ##print STDERR "@@@@ $wgetCommand\n";
155
156 my $response_content = "";
157 my $response_code = undef;
158 #my $response_content = `$wgetCommand`; # Dr Bainbridge advises against using backticks for running a process. If capturing std output, use open():
159 if (open(PIN, "$wgetCommand |")) {
160 while (defined (my $perl_output_line = <PIN>)) {
161 $response_content = $response_content . $perl_output_line;
162 }
163 close(PIN);
164 } else {
165 print STDERR "servercontrol.pm::config() failed to run $wgetCommand\n";
166 }
167
168
169 my @lines = split( /\n/, $response_content );
170 foreach my $line (@lines) {
171 #print STDERR "@@@@ LINE: $line\n";
172 if($line =~ m@failed: Connection timed out.$@) { # linux
173 $response_code = "failed: Connection timed out.";
174 last; # break keyword in perl = last
175 }
176 elsif($line =~ m@Giving up.$@) { # windows (unless -T 5 -t 1 is not passed in)
177 $response_code = "failed: Giving up.";
178 last; # break keyword in perl = last
179 }
180 elsif($line =~ m@failed: Connection refused.$@) {
181 $response_code = "failed: Connection refused.";
182 last; # break keyword in perl = last
183 }
184 elsif($line =~ m@HTTP request sent, @) {
185 $response_code = $line;
186 $response_code =~ s@[^\d]*(.*)$@$1@;
187 last;
188 }
189 }
190
191 if($command =~ m@ping@ && $response_code =~ m@failed: (Connection refused|Giving up)@) {
192 # server not running
193 $self->print_msg("*** Server not running. $library_url$command\n", 3);
194 &FileUtils::removeFiles($tmpfilename); # get rid of the ping response's temporary html file we downloaded
195 return 0;
196 }
197 if($response_code && (index($response_code, "200") != -1)) {
198 $self->print_msg("*** Command $library_url$command\n", 3);
199 $self->print_msg("*** HTTP Response Status: $response_code - Complete.", 3);
200
201 # check the page content is as expected
202 #my $resultstr = $response_content;
203
204 # The following file reading section is a candidate to use FileUtils::readUTF8File()
205 # in place of calling sysread() directly. But only if we can reason we'd be working with UTF8
206 open(FIN,"<$tmpfilename") or die "servercontrol.pm: Unable to open $tmpfilename to read ping response page...ERROR: $!\n";
207 my $resultstr;
208 # Read in the entire contents of the file in one hit
209 ##sysread(FIN, $resultstr, -s FIN);
210 # GLI GBuildProgressMonitor.hasSignalledStop() removes any lines that start with elements it doesn't recognise
211 # but we want to see the lines with HTML tags as they are the most interesting: they embed success/failure messages
212 # So read line by line from the downloaded web page and replace <> with [] so that GLI can display these lines too
213 while (my $line = <FIN>) {
214 chomp $line;
215 $line =~ s@<@[@g;
216 $line =~ s@>@]@g;
217 $resultstr .= "$line\n";
218 }
219 close(FIN);
220 &FileUtils::removeFiles($tmpfilename); # get rid of the ping response's temporary html file we downloaded
221
222
223 #$resultstr =~ s@.*gs_content\"\>@@s; ## only true for default library servlet
224 #$resultstr =~ s@</div>.*@@s;
225 if($resultstr =~ m/$check_message_against_regex/) {
226 $self->print_msg(" Response as expected.\n", 3);
227 $self->print_msg("@@@@@@ Got result:\n$resultstr\n", 4);
228 return 1;
229 } else {
230 # if we expect the collection to be inactive, then we'd be in silent mode: if so,
231 # don't print out the "ping did not succeed" response, but print out any other messages
232
233 # So we only suppress the ping col "did not succeed" response if we're in silent mode
234 # But if any message other than ping "did not succeed" is returned, we always print it
235 if($resultstr !~ m/did not succeed/ || !$silent) {
236 $self->print_msg("\n\tBUT: command $library_url$command response UNEXPECTED.\n", 3);
237 $self->print_msg("*** Got message:\n$response_content.\n", 4);
238 $self->print_msg("*** Got result:\n$resultstr\n", 3);
239 }
240 return 0; # ping on a collection may "not succeed."
241 }
242 }
243 elsif($response_code && $response_code =~ m@^(4|5)\d\d@) { # client side errors start with 4xx, server side with 5xx
244 # check the page content is as expected
245 if(defined $expected_error_code && $response_code =~ m@^$expected_error_code@) {
246 $self->print_msg(" Response status $response_code as expected.\n", 3);
247 } else {
248 $self->print_msg("*** Command $library_url$command\n");
249 $self->print_msg("*** Unexpected error type 1. HTTP Response Status: $response_code - Failed.\n");
250 }
251 return 0; # return false, since the response_code was an error, expected or not
252 }
253 else { # also if response_code is still undefined, as can happen with connection timing out
254 $self->print_msg("*** Command $library_url$command\n");
255 if(defined $response_code) {
256 $self->print_msg("*** Unexpected error type 2. HTTP Response Status: $response_code - Failed.\n");
257 } else {
258 $self->print_msg("*** Unexpected error type 3. Failed:\n\n$response_content\n\n");
259 }
260 return 0;
261 }
262 #print STDERR "********** WgetCommand: $wgetCommand\n\n";
263 #print STDERR "********** Response_content:\n$response_content\n\n";
264 #print STDERR "********** Response_CODE: $response_code\n";
265
266 }
267}
268
269sub deactivate_collection {
270 my $self = shift(@_);
271
272 my $gs_mode = $self->{'gs_mode'};
273 my $qualified_collection = $self->{'qualified_collection'};
274
275 if($gs_mode eq "gs2") {
276 my $DEACTIVATE_COMMAND = "?a=config&cmd=release-collection&c=";
277 my $check_message_against_regex = q/configured release-collection/;
278 $self->config($DEACTIVATE_COMMAND.$qualified_collection, $check_message_against_regex);
279 }
280 elsif ($gs_mode eq "gs3") {
281 my $DEACTIVATE_COMMAND = "?a=s&sa=d&st=collection&sn=";
282 my $check_message_against_regex = "collection: $qualified_collection deactivated";
283 $self->config($DEACTIVATE_COMMAND.$qualified_collection, $check_message_against_regex);
284 }
285}
286
287sub activate_collection {
288 my $self = shift(@_);
289
290 my $gs_mode = $self->{'gs_mode'};
291 my $qualified_collection = $self->{'qualified_collection'};
292
293 if($gs_mode eq "gs2") {
294 my $ACTIVATE_COMMAND = "?a=config&cmd=add-collection&c=";
295 my $check_message_against_regex = q/configured add-collection/;
296 $self->config($ACTIVATE_COMMAND.$qualified_collection, $check_message_against_regex);
297 }
298 elsif ($gs_mode eq "gs3") {
299 my $ACTIVATE_COMMAND = "?a=s&sa=a&st=collection&sn=";
300 my $check_message_against_regex = "collection: $qualified_collection activated";
301 $self->config($ACTIVATE_COMMAND.$qualified_collection, $check_message_against_regex);
302 }
303}
304
305sub ping {
306 my $self = shift(@_);
307 my $command = shift(@_);
308 my $silent = shift(@_);
309
310 # If the GS server is not running, we *expect* to see a "500" status code.
311 # If the GS server is running, then "Ping" ... "succeeded" is expected on success.
312 # When pinging an inactive collection, it will say it did "not succeed". This is
313 # a message of interest to return.
314 my $check_responsemsg_against_regex = q/(succeeded)/;
315 my $expected_error_code = 500;
316
317 $self->print_msg("*** COMMAND WAS: |$command| ***\n", 4);
318
319 return $self->config($command, $check_responsemsg_against_regex, $expected_error_code, $silent);
320}
321
322# send a pingaction to the GS library. General server-level ping.
323sub ping_library {
324 my $self = shift(@_);
325
326 my $gs_mode = $self->{'gs_mode'};
327
328 my $command = "";
329 if($gs_mode eq "gs2") {
330 $command = "?a=ping";
331 }
332 elsif ($gs_mode eq "gs3") {
333 $command = "?a=s&sa=ping";
334 }
335 return $self->ping($command);
336}
337
338
339# send a pingaction to a collection in GS library to check if it's active
340sub ping_library_collection {
341 my $self = shift(@_);
342 my $silent = shift(@_);
343
344 my $gs_mode = $self->{'gs_mode'};
345 my $qualified_collection = $self->{'qualified_collection'};
346
347 my $command = "";
348 if($gs_mode eq "gs2") {
349 $command = "?a=ping&c=$qualified_collection";
350 }
351 elsif ($gs_mode eq "gs3") {
352 $command = "?a=s&sa=ping&st=collection&sn=$qualified_collection";
353 }
354 return $self->ping($command, $silent);
355}
356
357# return true if server is persistent, by calling is-persistent on library_url
358# this is only for GS2, since the GS3 server is always persistent
359sub is_persistent {
360 my $self = shift(@_);
361
362 if($self->{'gs_mode'} eq "gs3") { # GS3 server is always persistent
363 return 1;
364 }
365
366 my $command = "?a=is-persistent";
367 my $check_responsemsg_against_regex = q/true/; # isPersistent: true versus isPersistent: false
368 return $self->config($command, $check_responsemsg_against_regex);
369}
370
371sub set_library_URL {
372 my $self = shift(@_);
373 my $library_url = shift(@_);
374 $self->{'library_url'} = $library_url;
375}
376
377sub get_library_URL {
378 my $self = shift(@_);
379
380 # For web servers that are external to a Greenstone installation,
381 # the user can pass in their web server's library URL.
382 if($self->{'library_url'}) {
383 return $self->{'library_url'};
384 }
385
386 # For web servers included with GS (like tomcat for GS3 and server.exe
387 # and apache for GS2), we work out the library URL:
388 my ($gs_mode, $lib_name); # gs_mode can be gs3 or gs2, lib_name is the custom servlet name
389 $gs_mode = $self->{'gs_mode'};
390 $lib_name = $self->{'library_name'};
391
392 # If we get here, we are dealing with a server included with GS.
393 # For GS3, we ask ant for the library URL.
394 # For GS2, we derive the URL from the llssite.cfg file.
395
396 # note that unless we pass in $get_public_url=1, we now get the local http URL
397 # by default (e.g. http://127.0.0.1:httpPort/greenstone/library)
398 my $url = &util::get_full_greenstone_url_prefix($gs_mode, $lib_name); # found largely identical method copied
399 # into util.pm. Don't want duplicates, so calling that from here.
400
401 # either the url is still undef or it is now set
402 #print STDERR "\n@@@@@ final URL:|$url|\n" if $url;
403 #print STDERR "\n@@@@@ URL still undef\n" if !$url;
404
405 if (defined $url) {
406 $self->{'library_url'} = $url;
407 }
408
409 return $url;
410}
411
412sub do_deactivate {
413 my $self = shift(@_);
414
415 # 1. Get library URL
416
417 # For web servers that are external to a Greenstone installation,
418 # the user can pass in their web server's library URL.
419 # For web servers included with GS (like tomcat for GS3 and server.exe
420 # and apache for GS2), we work out the library URL:
421
422 # Can't do $self->{'library_url'}, because it may not yet be set
423 my $library_url = $self->get_library_URL(); # returns undef if no valid server URL
424
425 if(!defined $library_url) { # undef if no valid server URL
426 return; # can't do any deactivation without a valid server URL
427 }
428
429 my $is_persistent_server = $self->{'is_persistent_server'};
430 my $qualified_collection = $self->{'qualified_collection'};
431
432 # CollectionManager's installCollection phase in GLI
433 # 2. Ping the library URL, and if it's a persistent server and running, release the collection
434
435 $self->print_msg("Pinging $library_url\n");
436 if ($self->ping_library()) { # server running
437
438 # server is running, so release the collection if
439 # the server is persistent and the collection is active
440
441 # don't need to work out persistency of server more than once, since the libraryURL hasn't changed
442 if (!defined $is_persistent_server) {
443 $self->print_msg("Checking if Greenstone server is persistent\n");
444 $is_persistent_server = $self->is_persistent();
445 $self->{'is_persistent_server'} = $is_persistent_server;
446 }
447
448 if ($is_persistent_server) { # only makes sense to issue activate and deactivate cmds to a persistent server
449
450 $self->print_msg("Checking if the collection $qualified_collection is already active\n");
451 my $collection_active = $self->ping_library_collection();
452
453 if ($collection_active) {
454 $self->print_msg("De-activating collection $qualified_collection\n");
455 $self->deactivate_collection();
456 }
457 else {
458 $self->print_msg("Collection is not active => No need to deactivate\n");
459 }
460 }
461 else {
462 $self->print_msg("Server is not persistent => No need to deactivate collection\n");
463 }
464 }
465 else {
466 $self->print_msg("No response to Ping => Taken to mean server is not running\n");
467 }
468
469 return $is_persistent_server;
470}
471
472sub do_activate {
473 my $self = shift @_;
474
475 my $library_url = $self->get_library_URL(); # Can't do $self->{'library_url'}; as it may not be set yet
476
477 if(!defined $library_url) { # undef if no valid server URL
478 return; # nothing to activate if without valid server URL
479 }
480
481 my $is_persistent_server = $self->{'is_persistent_server'};
482 my $qualified_collection = $self->{'qualified_collection'};
483
484 $self->print_msg("Pinging $library_url\n");
485 if ($self->ping_library()) { # server running
486
487 # don't need to work out persistency of server more than once, since the libraryURL hasn't changed
488 if (!defined $is_persistent_server) {
489 $self->print_msg("Checking if Greenstone server is persistent\n");
490 $is_persistent_server = $self->is_persistent();
491 $self->{'is_persistent_server'} = $is_persistent_server;
492 }
493
494 if ($is_persistent_server) { # persistent server, so can try activating collection
495
496 $self->print_msg("Checking if the collection $qualified_collection is not already active\n");
497
498 # Since we could have deactivated the collection at this point,
499 # it is likely that it is not yet active. When pinging the collection
500 # a "ping did not succeed" message is expected, therefore tell the ping
501 # to proceed silently
502 my $silent = 1;
503 my $collection_active = $self->ping_library_collection($silent);
504
505 if (!$collection_active) {
506 $self->print_msg(" Collection is not active.\n");
507 $self->print_msg("Activating collection $qualified_collection\n");
508 $self->activate_collection();
509
510 # unless an error occurred, the collection should now be active:
511 $collection_active = $self->ping_library_collection(); # not silent if ping did not succeed
512 if(!$collection_active) {
513 $self->print_msg("ERROR: collection $qualified_collection did not get activated\n");
514 }
515 }
516 else {
517 $self->print_msg("Collection is already active => No need to activate\n");
518 }
519 }
520 else {
521 $self->print_msg("Server is not persistent => No need to activate collection\n");
522 }
523 }
524 else {
525 $self->print_msg("No response to Ping => Taken to mean server is not running\n");
526 }
527
528 return $is_persistent_server;
529}
530
531
532#########################################################
533### UNUSED METHODS - CAN BE HANDY
534
535
536# This method uses the perl libraries we're advised to use in place of wget for pinging and retrieving web
537# pages. The problem is that not all perl installations may support these libraries. So we now use the new
538# config() method further above, which uses the wget included in Greenstone binary installations.
539# If the library imports at page top conflict, comment out those imports and move the methods config_old(),
540# is_URL_active() and pingHost() out to a temporary file.
541#
542# If for some reason you can't use wget, then rename the config() method to config_old(), and rename the
543# method below to config() and things should work as before.
544sub config_old {
545 my $self = shift(@_);
546 my ($command, $check_message_against_regex, $expected_error_code, $silent) = @_;
547
548 my $library_url = $self->get_library_URL(); #$self->{'library_url'};
549
550
551 # Gatherer.java's configGS3Server doesn't use the site variable
552 # so we don't have to either
553
554 # for GS2, getting the HTTP status isn't enough, we need to read the output
555 # since this is what CollectionManager.config() stipulates.
556 # Using LWP::UserAgent::get($url) for this
557
558 if(!defined $library_url) {
559 return 0;
560 }
561 else {
562 $ua->timeout(5); # set LWP useragent to 5s max timeout for testing the URL
563 # Need to set this, else it takes I don't know how long to timeout
564 # http://www.perlmonks.org/?node_id=618534
565
566 # http://search.cpan.org/~gaas/libwww-perl-6.04/lib/LWP/UserAgent.pm
567 # use LWP::UserAgent's get($url) since it returns an HTTP::Response code
568
569 my $response_obj = $ua->get($library_url.$command);
570
571 # $response_obj->content stores the content and $response_obj->code the HTTP response code
572 my $response_code = $response_obj->code();
573
574 if(LWP::Simple::is_success($response_code)) {# $response_code eq RC_OK) { # LWP::Simple::is_success($response_code)
575 $self->print_msg("*** Command $library_url$command\n", 3);
576 $self->print_msg("*** HTTP Response Status: $response_code - Complete.", 3);
577
578 # check the page content is as expected
579 my $response_content = $response_obj->content;
580 my $resultstr = $response_content;
581 $resultstr =~ s@.*gs_content\"\>@@s;
582 $resultstr =~ s@</div>.*@@s;
583
584 if($resultstr =~ m/$check_message_against_regex/) {#if($response_content =~ m/$check_message_against_regex/) {
585 $self->print_msg(" Response as expected.\n", 3);
586 $self->print_msg("@@@@@@ Got result:\n$resultstr\n", 4);
587 return 1;
588 } else {
589 # if we expect the collection to be inactive, then we'd be in silent mode: if so,
590 # don't print out the "ping did not succeed" response, but print out any other messages
591
592 # So we only suppress the ping col "did not succeed" response if we're in silent mode
593 # But if any message other than ping "did not succeed" is returned, we always print it
594 if($resultstr !~ m/did not succeed/ || !$silent) {#if($response_content !~ m/did not succeed/ || !$silent) {
595 $self->print_msg("\n\tBUT: command $library_url$command response UNEXPECTED.\n", 3);
596 $self->print_msg("*** Got message:\n$response_content.\n", 4);
597 $self->print_msg("*** Got result:\n$resultstr\n", 3);
598 }
599 return 0; # ping on a collection may "not succeed."
600 }
601 }
602 elsif(LWP::Simple::is_error($response_code)) { # method exported by LWP::Simple, along with HTTP::Status constants
603 # check the page content is as expected
604 if(defined $expected_error_code && $response_code == $expected_error_code) {
605 $self->print_msg(" Response status $response_code as expected.\n", 3);
606 } else {
607 $self->print_msg("*** Command $library_url$command\n");
608 $self->print_msg("*** Unexpected error. HTTP Response Status: $response_code - Failed.\n");
609 }
610 return 0; # return false, since the response_code was an error, expected or not
611 }
612 else {
613 $self->print_msg("*** Command $library_url$command\n");
614 $self->print_msg("*** Unexpected error. HTTP Response Status: $response_code - Failed.\n");
615 return 0;
616 }
617 }
618}
619
620# This method is now unused. Using ping_library instead to send the ping action to a
621# GS2/GS3 server. This method can be used more generally to test whether a URL is alive.
622# http://search.cpan.org/dist/libwww-perl/lib/LWP/Simple.pm
623# and http://www.perlmonks.org/?node_id=618534
624sub is_URL_active {
625 my $url = shift(@_); # gs3 or gs2 URL
626
627 my $status = 0;
628 if(defined $url) {
629 $ua->timeout(10); # set LWP useragent to 5s max timeout for testing the URL
630 # Need to set this, else it takes I don't know how long to timeout
631 # http://www.perlmonks.org/?node_id=618534
632
633 $status = LWP::Simple::head($url); # returns empty list of headers if it fails
634 # LWP::Simple::get($url) is more intensive, so don't need to do that
635 #print STDERR "**** $url is alive.\n" if $status;
636 }
637 return $status;
638}
639
640# Pinging seems to always return true, so this method doesn't work
641sub pingHost {
642 my $url = shift(@_); # gs3 or gs2 URL
643
644 my $status = 0;
645 if(defined $url) {
646 # Get just the domain. "http://localhost/gsdl?uq=332033495" becomes "localhost"
647 # "http://localhost/greenstone/cgi-bin/library.cgi" becomes "localhost" too
648
649 #my $host = $url;
650 #$host =~ s@^https?:\/\/(www.)?@@;
651 #$host =~ s@\/.*@@;
652 #print STDERR "**** HOST: $host\n";
653
654 # More robust way
655 # http://stackoverflow.com/questions/827024/how-do-i-extract-the-domain-out-of-an-url
656 my $uri = URI->new( $url );
657 my $host = $uri->host;
658
659 # Ping the host. http://perldoc.perl.org/Net/Ping.html
660 my $p = Net::Ping->new();
661 $status = $p->ping($host); # || 0. Appears to set to undef rather than 0
662 print STDERR "**** $host is alive.\n" if $status; #print "$host is alive.\n" if $p->ping($host);
663 $p->close();
664 }
665 # return whether pinging was a success or failure
666 return $status;
667}
668
6691;
Note: See TracBrowser for help on using the repository browser.