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
  68 use Amanda::Util;
  69
  70 our $TMP = "$AMANDA_TMPDIR/installchecks";
  71
  72 # run this just before the script actually executes
  73 # (not during syntax checks)
  74 INIT {
  75     Amanda::Util::set_pname("$0");
  76     mkpath($TMP);
  77 }
  78
  79 my @used_ports;
  80 sub get_unused_port {
  81      my ($base, $count) = (10000, 10000);
  82      my $i;
  83      my $tcp = getprotobyname('tcp');
  84
  85      # select ports randomly until we find one that is usable or have tried 1000
  86      # ports
  87      for ($i = 0; $i < 1000; $i++) {
  88         my $port = int(rand($count)) + $base;
  89
  90         # have we already used it?
  91         next if (grep { $_ == $port } @used_ports);
  92
  93         # is it listed in /etc/services?
  94         next if (getservbyport($port, $tcp));
  95
  96         # can we bind() to it? (using REUSADDR so that the kernel doesn't reserve
  97         # the port after we close it)
  98         next unless socket(SOCK, PF_INET, SOCK_STREAM, $tcp);
  99         next unless setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1));
 100         next unless bind(SOCK, sockaddr_in($port, INADDR_ANY));
 101         close(SOCK);
 102
 103         # it passed the gauntlet of tests, so the port is good
 104         push @used_ports, $port;
 105         return $port;
 106     }
 107
 108     die("could not find unused port");
 109 }
 110
 111 sub log_test_output {
 112     my $builder = Test::More->builder();
 113
 114     # not supported on perl-5.6
 115     return if !$^V or $^V lt v5.8.0;
 116
 117     # wrap each filehandle used for output
 118     foreach my $out (qw(output failure_output todo_output)) {
 119         $builder->$out(Installcheck::TestFD->new($builder->$out));
 120     }
 121 }
 122
 123 package Installcheck::TestFD;
 124
 125 use base qw(Tie::Handle IO::Handle);
 126
 127 use Symbol;
 128 use Amanda::Debug qw(debug);
 129
 130 use strict;
 131 use warnings;
 132
 133 sub new {
 134     my ($class, $fh) = @_;
 135     # save the underlying filehandle
 136     my $o = {'fh' => $fh};
 137     # must bless before tie()
 138     bless($o, $class);
 139     # note that gensym is needed so we have something to tie()
 140     my $new_fh = gensym;
 141     tie(*$new_fh, $class, $o);
 142     # note that the anonymous glob reference must be returned, so
 143     # when 'print $fh "some string"' is used it works
 144     return $new_fh;
 145 }
 146
 147 sub TIEHANDLE {
 148     my ($class, $o) = @_;
 149     return $o;
 150 }
 151
 152 # other methods of IO::Handle or Tie::Handle may be called in theory,
 153 # but in practice this seems to be all we need
 154
 155 sub print {
 156     my ($self, @args);
 157     reutrn $self->PRINT(@args);
 158 }
 159
 160 sub PRINT {
 161     my ($self, @msgs) = @_;
 162     # log each line separately
 163     foreach my $m (split("\n", join($, , @msgs))) {
 164         debug($m);
 165     }
 166     # now call print on the wrapped filehandle
 167     return $self->{'fh'}->print(@msgs);
 168 }
 169
 170 1;