Perl：在使用“严格引用”时不能使用字符串（“XXX”）作为 HASH 引用

Question

我一直在处理一个旧的 Perl 脚本，它在更新我的 Perl 环境后停止工作。

这是有问题的脚本（我已按照 cmets 中的建议添加了 use Data::Dumper; print Dumper \@checks;）：

#!/usr/bin/perl -w
use warnings;
use strict;
use sort 'stable';
use File::Spec;
use File::Temp qw(tempdir);
use Getopt::Long;
use Nagios::Plugin;
use Nagios::Plugin::Threshold;

my $PROGRAM = 'check_tsm';
my $VERSION = '0.2';

my $default_tsm_dir = '/opt/tivoli/tsm/client/ba/bin';
my $plugin = Nagios::Plugin->new(shortname => $PROGRAM);
my %opt = ('tsm-directory' => $default_tsm_dir);
my @checks;
Getopt::Long::config('bundling');
Getopt::Long::GetOptions(\%opt, 'host|H=s', 'username|U=s', 'password|P=s',
  'port|p=i',
  'tsm-directory=s', 'warning|w=s', 'critical|c=s', 'bytes', 'help', 'version',
  '<>' => sub {
    push @checks, {
      'type' => $_[0]->{'name'},
      'warning' => $opt{'warning'}, #$opt{'warning'} eq '-' ? undef : $opt{'warning'},
      'critical' => $opt{'critical'}, #$opt{'critical'} eq '-' ? undef : $opt{'critical'},
    };
  }) || exit UNKNOWN;
if ($opt{'help'}) {
  print "Usage: $0 [OPTION]... CHECK...\n";
}

$plugin->nagios_exit(UNKNOWN, "host not set\n") if !defined $opt{'host'};
$plugin->nagios_exit(UNKNOWN, "username not set\n") if !defined $opt{'username'};
$plugin->nagios_exit(UNKNOWN, "password not set\n") if !defined $opt{'password'};
$plugin->nagios_exit(UNKNOWN, "no check specified\n") if !@checks;

use Data::Dumper; print Dumper \@checks;
foreach my $check (@checks) {
  if ($check->{'type'} eq 'drives') {
    $check->{'text'} = 'Online drives';
    $check->{'query'} = "select count(*) from drives where online='YES'";
    $check->{'warning'} //= '2:';
    $check->{'critical'} //= '1:';
    $check->{'order'} = 0;
  } elsif ($check->{'type'} eq 'paths') {
    $check->{'text'} = 'Online paths';
    $check->{'query'} = "select count(*) from paths where online='YES' and destination_type='DRIVE'";
    $check->{'warning'} //= '2:';
    $check->{'critical'} //= '1:';
    $check->{'order'} = 0;
  } elsif ($check->{'type'} eq 'dbspace') {
    $check->{'text'} = 'Database space utilization';
    $check->{'query'} = "select used_db_space_mb, tot_file_system_mb from db";
    $check->{'warning'} //= 90;
    $check->{'critical'} //= 95;
    $check->{'order'} = 0;
  } elsif ($check->{'type'} eq 'logspace') {
    $check->{'text'} = 'Log space utilization';
    $check->{'query'} = "select used_space_mb, total_space_mb from log";
    $check->{'warning'} //= 90;
    $check->{'critical'} //= 95;
    $check->{'order'} = 0;
  } elsif ($check->{'type'} eq 'badvols') {
    $check->{'text'} = 'Error or read-only volumes';
    #$check->{'query'} = "select count(*) from volumes where error_state='YES' or access='READONLY'";
    $check->{'query'} = "select count(*) from volumes where (error_state='YES' and access='READONLY') or access='UNAVAILABLE'";
    $check->{'warning'} //= 0;
    $check->{'critical'} //= 0;
    $check->{'order'} = 0;
  } elsif ($check->{'type'} eq 'reclaimvols') {
    $check->{'text'} = 'Volumes needing reclamation';
    $check->{'query'} = "select count(*) from volumes join stgpools on volumes.stgpool_name=stgpools.stgpool_name where volumes.pct_reclaim>stgpools.reclaim and volumes.status='FULL' and volumes.access='READWRITE'";
    $check->{'warning'} //= 50;
    $check->{'critical'} //= 100;
    $check->{'order'} = 0;
  } elsif ($check->{'type'} eq 'freelibvols') {
    $check->{'text'} = 'Scratch library volumes';
    $check->{'query'} = "select count(*) from libvolumes where status='Scratch'";
    $check->{'warning'} //= '5:';
    $check->{'critical'} //= '1:';
    $check->{'order'} = 0;
  } elsif ($check->{'type'} eq 'reqs') {
    $check->{'text'} = 'Outstanding requests';
    $check->{'query'} = 'query request';
    $check->{'warning'} //= 0;
    $check->{'critical'} //= 1; # Critical not used since we only return 0 or 1
    $check->{'order'} = 1;
  } else {
    $plugin->nagios_exit(UNKNOWN, "unknown check ".$check->{'type'}."\n");
  }
}

# This needs stable sort in order so that reqs checks are always last
@checks = sort { $a->{'order'} <=> $b->{'order'} } @checks;

当我尝试运行脚本时，无论我使用哪个参数（驱动器、路径、dbspace ...），我都会不断收到此错误：

/usr/local/nagios/libexec/check_tsm --host=<IP ADDRESS> --port=<TCP PORT> --username=<USER> --password=<PASSWORD> --critical=85 --warning=80 dbspace
Can't use string ("dbspace") as a HASH ref while "strict refs" in use at /usr/local/nagios/libexec/check_tsm.tst line 23.

第 23 行是push @checks, {。

我目前不明白问题出在哪里，因为在升级我的 Perl 版本之前它工作正常。

Answer 1

问题出在一行

'type' => $_[0]->{'name'},

$_[0] 引用封闭子例程的第一个参数（从'<>' => sub { 开始）。根据Getopt::Long's <> option 的文档，每个命令行的非选项参数都会调用此子例程一次，并将此“非选项参数”作为其单个参数。如果你在这个子程序的开头添加use Data::Dumper; print Dumper \@_;，你会得到如下输出：

$VAR1 = [
          'dbspace'
        ];

因此，$_[0] 是字符串 "dbspace"，而不是哈希引用。做$_[0]->{'name'} 毫无意义。相反，您可能只想使用$_[0]：

push @checks, {
  'type' => $_[0],
  ...

请参阅 @shawn's answer 以了解更新 Perl 会破坏您的脚本的原因。

Answer 2

@Dada 描述了这个问题，但是您看到相同的代码在旧版本上工作并且在新版本上失败，这是不寻常的 - 为什么它在旧设置上也没有失败？原因如下：

在Getopt::Long 2.37 版中，传递给参数处理程序中的回调函数的参数已从纯字符串更改为对象（在本例中为祝福的hashref），其字段包括name。但是，在 2.39...

将对象作为第一个参数传递给<> 的回调处理程序在将参数传递给其他模块（例如Archive::Tar）的情况下会出现问题。还原更改，因为对象的添加功能与 <> 回调函数并不真正相关。

因此，您的旧安装必须使用 2.37 或 2.38 版本，其中提供的访问名称字段的代码工作正常。 2.39 或更高版本会破坏它（与 2.36 或更早版本一样）。