git.gag.com Git - debian/amanda/blob - installcheck/Installcheck.pm

   1 # vim:ft=perl
   2 # Copyright (c) 2009-2012 Zmanda, Inc.  All Rights Reserved.
   3 #
   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.
   8 #
   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
  12 # for more details.
  13 #
  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
  17 #
  18 # Contact information: Zmanda Inc, 465 S. Mathilda Ave., Suite 300
  19 # Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
  20
  21 package Installcheck;
  22 use File::Path;
  23 use Amanda::Paths;
  24
  25 =head1 NAME
  26
  27 Installcheck - utilities for installchecks (not installed)
  28
  29 =head1 SYNOPSIS
  30
  31   use Installcheck;
  32
  33   my $testdir = "$Installcheck::TMP/mystuff/";
  34
  35   use Amanda::Debug;
  36   Amanda::Debug::dbopen("installcheck");
  37   Installcheck::log_test_output();
  38
  39 =head1 DESCRIPTION
  40
  41 Miscellaneous utilities for installchecks. No symbols are exported by default.
  42
  43 =over
  44
  45 =item C<$TMP>
  46
  47 The temporary directory for installcheck data. This directory is created for you.
  48
  49 =item C<log_test_output()>
  50
  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.
  53
  54 =item C<get_unused_port()>
  55
  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
  59 eventual use.
  60
  61 =back
  62
  63 =cut
  64
  65 use strict;
  66 use warnings;
  67 use Socket;
  68 require Exporter;
  69
  70 our @ISA = qw(Exporter);
  71 our @EXPORT = qw( $srcdir );
  72
  73 use Amanda::Util;
  74
  75 our $TMP = "$AMANDA_TMPDIR/installchecks";
  76
  77 # the Makefile provides srcdir to us in most cases; if not, assume it's "."
  78 our $srcdir = $ENV{'srcdir'} || '.';
  79
  80 # run this just before the script actually executes
  81 # (not during syntax checks)
  82 INIT {
  83     Amanda::Util::set_pname("$0");
  84     mkpath($TMP);
  85 }
  86
  87 my @used_ports;
  88 sub get_unused_port {
  89      my ($base, $count) = (10000, 10000);
  90      my $i;
  91      my $tcp = getprotobyname('tcp');
  92
  93      # select ports randomly until we find one that is usable or have tried 1000
  94      # ports
  95      for ($i = 0; $i < 1000; $i++) {
  96         my $port = int(rand($count)) + $base;
  97
  98         # have we already used it?
  99         next if (grep { $_ == $port } @used_ports);
 100
 101         # is it listed in /etc/services?
 102         next if (getservbyport($port, $tcp));
 103
 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));
 109         close(SOCK);
 110
 111         # it passed the gauntlet of tests, so the port is good
 112         push @used_ports, $port;
 113         return $port;
 114     }
 115
 116     die("could not find unused port");
 117 }
 118
 119 sub log_test_output {
 120     my $builder = Test::More->builder();
 121
 122     # not supported on perl-5.6
 123     return if !$^V or $^V lt v5.8.0;
 124
 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));
 128     }
 129 }
 130
 131 package Installcheck::TestFD;
 132
 133 use base qw(Tie::Handle IO::Handle);
 134
 135 use Symbol;
 136 use Amanda::Debug qw(debug);
 137
 138 use strict;
 139 use warnings;
 140
 141 sub new {
 142     my ($class, $fh) = @_;
 143     # save the underlying filehandle
 144     my $o = {'fh' => $fh};
 145     # must bless before tie()
 146     bless($o, $class);
 147     # note that gensym is needed so we have something to tie()
 148     my $new_fh = gensym;
 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
 152     return $new_fh;
 153 }
 154
 155 sub TIEHANDLE {
 156     my ($class, $o) = @_;
 157     return $o;
 158 }
 159
 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
 162
 163 sub print {
 164     my ($self, @args);
 165     reutrn $self->PRINT(@args);
 166 }
 167
 168 sub PRINT {
 169     my ($self, @msgs) = @_;
 170     # log each line separately
 171     foreach my $m (split("\n", join($, , @msgs))) {
 172         debug($m);
 173     }
 174     # now call print on the wrapped filehandle
 175     return $self->{'fh'}->print(@msgs);
 176 }
 177
 178 1;