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

   1 # vim:ft=perl
   2 # Copyright (c) 2009, 2010 Zmanda, Inc.  All Rights Reserved.
   3 #
   4 # This program is free software; you can redistribute it and/or modify it
   5 # under the terms of the GNU General Public License version 2 as published
   6 # by the Free Software Foundation.
   7 #
   8 # This program is distributed in the hope that it will be useful, but
   9 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  10 # or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  11 # for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License along
  14 # with this program; if not, write to the Free Software Foundation, Inc.,
  15 # 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
  16 #
  17 # Contact information: Zmanda Inc, 465 S. Mathilda Ave., Suite 300
  18 # Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
  19
  20 package Installcheck;
  21 use File::Path;
  22 use Amanda::Paths;
  23
  24 =head1 NAME
  25
  26 Installcheck - utilities for installchecks (not installed)
  27
  28 =head1 SYNOPSIS
  29
  30   use Installcheck;
  31
  32   my $testdir = "$Installcheck::TMP/mystuff/";
  33
  34   use Amanda::Debug;
  35   Amanda::Debug::dbopen("installcheck");
  36   Installcheck::log_test_output();
  37
  38 =head1 DESCRIPTION
  39
  40 Miscellaneous utilities for installchecks. No symbols are exported by default.
  41
  42 =over
  43
  44 =item C<$TMP>
  45
  46 The temporary directory for installcheck data. This directory is created for you.
  47
  48 =item C<log_test_output()>
  49
  50 Calling this function causes status meesages from tests (e.g. "ok 1 - some test")
  51 to be recorded in the debug logs. It should be called exactly once.
  52
  53 =item C<get_unused_port()>
  54
  55 Find a local TCP port that is currently unused and not listed in
  56 C</etc/services>.  This can still fail, if the port in question is bound by
  57 another process between the call to C<get_unused_port()> and the port's
  58 eventual use.
  59
  60 =back
  61
  62 =cut
  63
  64 use strict;
  65 use warnings;
  66 use Socket;
  67 require Exporter;
  68
  69 our @ISA = qw(Exporter);
  70 our @EXPORT = qw( $srcdir );
  71
  72 use Amanda::Util;
  73
  74 our $TMP = "$AMANDA_TMPDIR/installchecks";
  75
  76 # the Makefile provides srcdir to us in most cases; if not, assume it's "."
  77 our $srcdir = $ENV{'srcdir'} || '.';
  78
  79 # run this just before the script actually executes
  80 # (not during syntax checks)
  81 INIT {
  82     Amanda::Util::set_pname("$0");
  83     mkpath($TMP);
  84 }
  85
  86 my @used_ports;
  87 sub get_unused_port {
  88      my ($base, $count) = (10000, 10000);
  89      my $i;
  90      my $tcp = getprotobyname('tcp');
  91
  92      # select ports randomly until we find one that is usable or have tried 1000
  93      # ports
  94      for ($i = 0; $i < 1000; $i++) {
  95         my $port = int(rand($count)) + $base;
  96
  97         # have we already used it?
  98         next if (grep { $_ == $port } @used_ports);
  99
 100         # is it listed in /etc/services?
 101         next if (getservbyport($port, $tcp));
 102
 103         # can we bind() to it? (using REUSADDR so that the kernel doesn't reserve
 104         # the port after we close it)
 105         next unless socket(SOCK, PF_INET, SOCK_STREAM, $tcp);
 106         next unless setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1));
 107         next unless bind(SOCK, sockaddr_in($port, INADDR_ANY));
 108         close(SOCK);
 109
 110         # it passed the gauntlet of tests, so the port is good
 111         push @used_ports, $port;
 112         return $port;
 113     }
 114
 115     die("could not find unused port");
 116 }
 117
 118 sub log_test_output {
 119     my $builder = Test::More->builder();
 120
 121     # not supported on perl-5.6
 122     return if !$^V or $^V lt v5.8.0;
 123
 124     # wrap each filehandle used for output
 125     foreach my $out (qw(output failure_output todo_output)) {
 126         $builder->$out(Installcheck::TestFD->new($builder->$out));
 127     }
 128 }
 129
 130 package Installcheck::TestFD;
 131
 132 use base qw(Tie::Handle IO::Handle);
 133
 134 use Symbol;
 135 use Amanda::Debug qw(debug);
 136
 137 use strict;
 138 use warnings;
 139
 140 sub new {
 141     my ($class, $fh) = @_;
 142     # save the underlying filehandle
 143     my $o = {'fh' => $fh};
 144     # must bless before tie()
 145     bless($o, $class);
 146     # note that gensym is needed so we have something to tie()
 147     my $new_fh = gensym;
 148     tie(*$new_fh, $class, $o);
 149     # note that the anonymous glob reference must be returned, so
 150     # when 'print $fh "some string"' is used it works
 151     return $new_fh;
 152 }
 153
 154 sub TIEHANDLE {
 155     my ($class, $o) = @_;
 156     return $o;
 157 }
 158
 159 # other methods of IO::Handle or Tie::Handle may be called in theory,
 160 # but in practice this seems to be all we need
 161
 162 sub print {
 163     my ($self, @args);
 164     reutrn $self->PRINT(@args);
 165 }
 166
 167 sub PRINT {
 168     my ($self, @msgs) = @_;
 169     # log each line separately
 170     foreach my $m (split("\n", join($, , @msgs))) {
 171         debug($m);
 172     }
 173     # now call print on the wrapped filehandle
 174     return $self->{'fh'}->print(@msgs);
 175 }
 176
 177 1;