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

   1 # vim:ft=perl
   2 # Copyright (c) 2009 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::Changer;
  21
  22 =head1 NAME
  23
  24 Installcheck::Changer - utilities for testing changers
  25
  26 =head1 SYNOPSIS
  27
  28   use Installcheck::Changer;
  29
  30   my $res_cb = sub {
  31     my ($err, $res) = @_;
  32     chg_err_like($err,
  33         { message => "expected msg", type => 'failure' },
  34         "operation produces the expected error");
  35     # or, just looking at the message
  36     chg_err_like($err,
  37         qr/expected .*/,
  38         "operation produces the expected error");
  39   };
  40
  41 =head1 USAGE
  42
  43 The function C<chg_err_like> takes an C<Amanda::Changer::Error> object and a
  44 hashref of expected values for that error object, and compares the two.  The
  45 values of this hashref can be regular expressions or strings.  Alternately, the
  46 function can take a regexp which is compared to the error's message.  This
  47 function is exported by default.
  48
  49 =cut
  50
  51 use Test::More;
  52 use Data::Dumper;
  53 use strict;
  54 use warnings;
  55 use vars qw( @ISA @EXPORT );
  56
  57 require Exporter;
  58 @ISA = qw(Exporter);
  59 @EXPORT = qw(chg_err_like);
  60
  61 sub chg_err_like {
  62     my ($err, $expected, $msg) = @_;
  63
  64     if (!defined($err) or !$err->isa("Amanda::Changer::Error")) {
  65         fail($msg);
  66         diag("Expected an Amanda::Changer::Error object; got\n" . Dumper($err));
  67         return;
  68     }
  69
  70     if (ref($expected) eq 'Regexp') {
  71         like($err->{'message'}, $expected, $msg);
  72     } else {
  73         my $ok = 1;
  74         for my $key (qw( type reason message )) {
  75             if (exists $expected->{$key}) {
  76                 if (!exists $err->{$key}) {
  77                     fail($msg) if ($ok);
  78                     $ok = 0;
  79                     diag("expected a '$key' hash elt, but saw none");
  80                     next;
  81                 }
  82
  83                 my ($got, $exp) = ($err->{$key}, $expected->{$key});
  84                 if (ref($exp) eq "Regexp") {
  85                     if ($got !~ $exp) {
  86                         fail($msg) if $ok;
  87                         $ok = 0;
  88                         diag("$key '$got' does not match '$exp'");
  89                     }
  90                 } elsif ($got ne $exp) {
  91                     fail($msg) if ($ok);
  92                     $ok = 0;
  93                     diag("expected $key '$exp'; got $key '$got'");
  94                 }
  95             }
  96         }
  97         pass($msg) if ($ok);
  98     }
  99 }