2 # Copyright (c) 2009-2012 Zmanda, Inc. All Rights Reserved.
4 # This program is free software; you can redistribute it and/or
5 # modify it under the terms of the GNU General Public License
6 # as published by the Free Software Foundation; either version 2
7 # of the License, or (at your option) any later version.
9 # This program is distributed in the hope that it will be useful, but
10 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
11 # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
14 # You should have received a copy of the GNU General Public License along
15 # with this program; if not, write to the Free Software Foundation, Inc.,
16 # 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18 # Contact information: Zmanda Inc, 465 S. Mathilda Ave., Suite 300
19 # Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
27 Installcheck - utilities for installchecks (not installed)
33 my $testdir = "$Installcheck::TMP/mystuff/";
36 Amanda::Debug::dbopen("installcheck");
37 Installcheck::log_test_output();
41 Miscellaneous utilities for installchecks. No symbols are exported by default.
47 The temporary directory for installcheck data. This directory is created for you.
49 =item C<log_test_output()>
51 Calling this function causes status meesages from tests (e.g. "ok 1 - some test")
52 to be recorded in the debug logs. It should be called exactly once.
54 =item C<get_unused_port()>
56 Find a local TCP port that is currently unused and not listed in
57 C</etc/services>. This can still fail, if the port in question is bound by
58 another process between the call to C<get_unused_port()> and the port's
70 our @ISA = qw(Exporter);
71 our @EXPORT = qw( $srcdir );
75 our $TMP = "$AMANDA_TMPDIR/installchecks";
77 # the Makefile provides srcdir to us in most cases; if not, assume it's "."
78 our $srcdir = $ENV{'srcdir'} || '.';
80 # run this just before the script actually executes
81 # (not during syntax checks)
83 Amanda::Util::set_pname("$0");
89 my ($base, $count) = (10000, 10000);
91 my $tcp = getprotobyname('tcp');
93 # select ports randomly until we find one that is usable or have tried 1000
95 for ($i = 0; $i < 1000; $i++) {
96 my $port = int(rand($count)) + $base;
98 # have we already used it?
99 next if (grep { $_ == $port } @used_ports);
101 # is it listed in /etc/services?
102 next if (getservbyport($port, $tcp));
104 # can we bind() to it? (using REUSADDR so that the kernel doesn't reserve
105 # the port after we close it)
106 next unless socket(SOCK, PF_INET, SOCK_STREAM, $tcp);
107 next unless setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1));
108 next unless bind(SOCK, sockaddr_in($port, INADDR_ANY));
111 # it passed the gauntlet of tests, so the port is good
112 push @used_ports, $port;
116 die("could not find unused port");
119 sub log_test_output {
120 my $builder = Test::More->builder();
122 # not supported on perl-5.6
123 return if !$^V or $^V lt v5.8.0;
125 # wrap each filehandle used for output
126 foreach my $out (qw(output failure_output todo_output)) {
127 $builder->$out(Installcheck::TestFD->new($builder->$out));
131 package Installcheck::TestFD;
133 use base qw(Tie::Handle IO::Handle);
136 use Amanda::Debug qw(debug);
142 my ($class, $fh) = @_;
143 # save the underlying filehandle
144 my $o = {'fh' => $fh};
145 # must bless before tie()
147 # note that gensym is needed so we have something to tie()
149 tie(*$new_fh, $class, $o);
150 # note that the anonymous glob reference must be returned, so
151 # when 'print $fh "some string"' is used it works
156 my ($class, $o) = @_;
160 # other methods of IO::Handle or Tie::Handle may be called in theory,
161 # but in practice this seems to be all we need
165 reutrn $self->PRINT(@args);
169 my ($self, @msgs) = @_;
170 # log each line separately
171 foreach my $m (split("\n", join($, , @msgs))) {
174 # now call print on the wrapped filehandle
175 return $self->{'fh'}->print(@msgs);