Changes - j0ke.net Open Build Service

@@ -1,3 +1,7 @@ +2011-11-09 Matteo Corti <matteo.corti@id.ethz.ch> + + * check_diskio: support for 3.x kernels + 2010-10-22 Matteo Corti <matteo.corti@id.ethz.ch> * check_diskio: fixed a problem in the parsing of the diskstat file @@ -114,7 +118,7 @@ * Initial release -# $Id: Changes 1196 2010-10-22 13:57:51Z corti $ -# $Revision: 1196 $ +# $Id: Changes 1275 2011-11-09 15:24:34Z corti $ +# $Revision: 1275 $ # $HeadURL: https://svn.id.ethz.ch/nagios_plugins/check_diskio/Changes $ -# $Date: 2010-10-22 15:57:51 +0200 (Fri, 22 Oct 2010) $ +# $Date: 2011-11-09 16:24:34 +0100 (Wed, 09 Nov 2011) $

@@ -4,10 +4,12 @@ - 'Matteo Corti <matteo.corti@id.ethz.ch>' build_requires: ExtUtils::MakeMaker: 6.42 + File::Spec: 0 + Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module -generated_by: 'Module::Install version 0.91' +generated_by: 'Module::Install version 1.01' license: gpl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -16,6 +18,7 @@ no_index: directory: - inc + - t requires: Array::Unique: 0 English: 0 @@ -27,6 +30,7 @@ Number::Format: 0 POSIX: 0 Readonly: 0 + perl: 5.8.0 resources: license: http://opensource.org/licenses/gpl-license.php -version: 3.2.3 +version: 3.2.4

@@ -4,9 +4,10 @@ ############################################################################## # Define metadata (we read it from the binary) -name 'check_diskio'; -all_from 'check_diskio.pod'; -version_from 'check_diskio'; +name 'check_diskio'; +version_from 'check_diskio'; +perl_version_from 'check_diskio'; +all_from 'check_diskio.pod'; ############################################################################## # Specific dependencies @@ -26,6 +27,10 @@ install_script 'check_diskio'; +tests 't/*.t'; +test_requires 'Test::More' => 0; +test_requires 'File::Spec' => 0; + WriteMakefile( INSTALLSCRIPT => '/usr/lib/nagios/plugins/contrib', INSTALLSITESCRIPT => '/usr/lib/nagios/plugins/contrib',

@@ -1,3 +1,4 @@ +2011-11-09 3.2.4: supports 3.X kernels 2010-10-20 3.2.3: fixes a bug in the parsing of the statistics file 2010-07-06 3.2.2: fixes a bug which ignored devices specified with -d /dev 2010-06-30 3.2.1: exits with UNKNOWN if not able to read LVM stats @@ -26,7 +27,7 @@ 2007-02-23 1.1: removed the max interval check 2007-02-19 1.0: initial release -# $Id: NEWS 1196 2010-10-22 13:57:51Z corti $ -# $Revision: 1196 $ +# $Id: NEWS 1275 2011-11-09 15:24:34Z corti $ +# $Revision: 1275 $ # $HeadURL: https://svn.id.ethz.ch/nagios_plugins/check_diskio/NEWS $ -# $Date: 2010-10-22 15:57:51 +0200 (Fri, 22 Oct 2010) $ +# $Date: 2011-11-09 16:24:34 +0100 (Wed, 09 Nov 2011) $

@@ -1,5 +1,7 @@ #!perl +package main; + # check_diskio is a Nagios plugin to monitor the amount of disk # I/O in sectors on Linux 2.6 and 2.4 systems # @@ -15,15 +17,17 @@ # enable substitution with: # $ svn propset svn:keywords "Id Revision HeadURL Source Date" # -# $Id: check_diskio 1196 2010-10-22 13:57:51Z corti $ -# $Revision: 1196 $ +# $Id: check_diskio 1277 2011-11-09 17:25:43Z corti $ +# $Revision: 1277 $ # $HeadURL: https://svn.id.ethz.ch/nagios_plugins/check_diskio/check_diskio $ -# $Date: 2010-10-22 15:57:51 +0200 (Fri, 22 Oct 2010) $ +# $Date: 2011-11-09 18:25:43 +0100 (Wed, 09 Nov 2011) $ + +use 5.00800; use strict; use warnings; -our $VERSION = '3.2.3'; +our $VERSION = '3.2.4'; use Array::Unique; use English qw(-no_match_vars); @@ -41,6 +45,9 @@ Readonly my $BITS_PER_BYTE => 8; Readonly my $BYTES_PER_SECTOR => 512; +Readonly my $KILO => 1_000; +Readonly my $KIBI => 1_024; + # IMPORTANT: Nagios plugins could be executed using embedded perl in this case # the main routine would be executed as a subroutine and all the # declared subroutines would therefore be inner subroutines @@ -49,6 +56,7 @@ # # All variables are therefore declared as package variables... # +## no critic (ProhibitPackageVars) use vars qw( $factor $format @@ -61,6 +69,15 @@ %diskio_r @stat_file ); +## use critic (ProhibitPackageVars) + +# the script is declared as a package so that it can be unit tested +# but it should not be used as a module +if ( !caller ) { + run(); +} + +## no critic (InputOutput::RequireCheckedSyscalls) ############################################################################## # subroutines @@ -168,6 +185,7 @@ . $time . "\n", 1; + ## no critic (InputOutput::RequireBriefOpen) open $TMP_FH, q{>}, $tmp or $plugin->nagios_exit( UNKNOWN, "Cannot initialize timer ($tmp): $OS_ERROR" ); @@ -182,6 +200,7 @@ close $TMP_FH or $plugin->nagios_exit( UNKNOWN, "Cannot close timer: $OS_ERROR" ); + ## use critic (InputOutput::RequireBriefOpen) return; @@ -205,6 +224,7 @@ my $out; my $diff; + ## no critic (InputOutput::RequireBriefOpen) open $TMP_FH, q{<}, $tmp or $plugin->nagios_exit( UNKNOWN, "Cannot open timer ($tmp): $OS_ERROR" ); @@ -223,6 +243,7 @@ close $TMP_FH or $plugin->nagios_exit( UNKNOWN, "Cannot close timer: $OS_ERROR" ); + ## use critic (InputOutput::RequireBriefOpen) verbose 'reading data: read=' . format_number( $in, 0, 0, ) @@ -239,30 +260,23 @@ } ############################################################################## -# Usage : $version = kernel_version(); -# Purpose : detects the Linux kernel version -# Returns : kernel version (w/o minor number) +# Usage : $boolean = use_diskstats(); +# Purpose : detects the Linux kernel version and determines if we should +# use diskstats +# Returns : true if we should use diskstats # Arguments : n/a # Throws : n/a # Comments : n/a # See also : n/a -sub kernel_version { +sub use_diskstats { my ( $sysname, $nodename, $release, $version, $machine ) = uname; if ( $options->debug() ) { print "[DEBUG] kernel $release\n"; } - if ( $release =~ /^2.4/mxs ) { - return '2.4'; - } - if ( $release =~ /^2.6/mxs ) { - return '2.6'; - } - $plugin->nagios_exit( UNKNOWN, - "Error: unsupported kernel version ($release)" ); - return; + return ( $release =~ /^2.6/mxs ) || ( $release =~ /^3/mxs ); } @@ -350,7 +364,7 @@ # In theory with 2.6 kernels we should get only 4 fields but # on some distributions we get 11 of them - if ( defined $f05 && $f05 =~ m/[0-9]/mxs ) { + if ( defined $f05 && $f05 =~ m/\d/mxs ) { # 11 fields if ( $options->debug() ) { @@ -429,7 +443,7 @@ verbose "Information found for '$name'\n", 1; } - if ( $name =~ /^ide.*bus([0-9]).*target([0-9]).*lun([0-9])/mxs ) { + if ( $name =~ /^ide.*bus(\d).*target(\d).*lun(\d)/mxs ) { # we try to get the corresponding device @@ -522,26 +536,33 @@ } ############################################################################## -# main -# +# Usage : run(); +# Purpose : main method +# Returns : n/a +# Arguments : n/a +# Throws : n/a +# Comments : n/a +# See also : n/a +## no critic (Subroutines::ProhibitExcessComplexity) +sub run { -################ -# initialization -$factor = 1; -$format = q{s}; -$plugin = Nagios::Plugin->new( shortname => 'CHECK_DISKIO' ); + ################ + # initialization + $factor = 1; + $format = q{s}; + $plugin = Nagios::Plugin->new( shortname => 'CHECK_DISKIO' ); -######################## -# Command line arguments + ######################## + # Command line arguments -my $usage = <<'EOT'; + my $usage = <<'EOT'; check_diskio --device=devicename --critical=critical --warning=warning [--help] [--reset] [--silent] [--ssize=size] [--verbose] [--version] [--uom=unit] [--factor=unit] [--strip-partition-number] EOT -my $extra = <<'EOT'; + my $extra = <<'EOT'; Units of measurement: @@ -566,256 +587,260 @@ EOT -$options = Nagios::Plugin::Getopt->new( - usage => $usage, - extra => $extra, - version => $VERSION, - url => 'https://trac.id.ethz.ch/projects/nagios_plugins', - blurb => 'Monitor disk I/O', -); - -$options->arg( - spec => 'device|d=s@', - help => 'device name(s) (or mount point(s))', - required => 1, -); - -$options->arg( - spec => 'critical|c=i', - help => 'critical number of sectors/s', - required => 1, -); - -$options->arg( - spec => 'warning|w=i', - help => 'number of sectors/s which generates a warning', - required => 1, -); + $options = Nagios::Plugin::Getopt->new( + usage => $usage, + extra => $extra, + version => $VERSION, + url => 'https://trac.id.ethz.ch/projects/nagios_plugins', + blurb => 'Monitor disk I/O', + ); -$options->arg( - spec => 'reset|r', - help => 'reset the counter(s)', - required => 0, -); + $options->arg( + spec => 'device|d=s@', + help => 'device name(s) (or mount point(s))', + required => 1, + ); -$options->arg( - spec => 'silent|s', - help => 'no warnings or critials are issued', - required => 0, -); + $options->arg( + spec => 'critical|c=i', + help => 'critical number of sectors/s', + required => 1, + ); -$options->arg( - spec => 'ssize=i', - help => 'specify the sector size in bytes (default 512)', - required => 0, - default => $BYTES_PER_SECTOR, -); + $options->arg( + spec => 'warning|w=i', + help => 'number of sectors/s which generates a warning', + required => 1, + ); -$options->arg( - spec => 'uom=s', - help => 'unit of measurement', - required => 0, -); + $options->arg( + spec => 'reset|r', + help => 'reset the counter(s)', + required => 0, + ); -$options->arg( - spec => 'factor=s', - help => 'unit of threshold', - required => 0, -); + $options->arg( + spec => 'silent|s', + help => 'no warnings or critials are issued', + required => 0, + ); -$options->arg( - spec => 'debug', - help => 'debugging output', - required => 0, -); + $options->arg( + spec => 'ssize=i', + help => 'specify the sector size in bytes (default 512)', + required => 0, + default => $BYTES_PER_SECTOR, + ); -$options->arg( - spec => 'testfile=s', - help => 'tests the plugin with the given disk statistics file (debugging)', - required => 0, -); - + $options->arg( + spec => 'uom=s', + help => 'unit of measurement', + required => 0, + ); -$options->arg( - spec => 'strip-partition-number', - help => - 'strips p[0-9]+ from the device number (needed for HP Smart Array cards)', - required => 0, -); + $options->arg( + spec => 'factor=s', + help => 'unit of threshold', + required => 0, + ); -$options->getopts(); + $options->arg( + spec => 'debug', + help => 'debugging output', + required => 0, + ); -################################################################################ -# Sanity checks + $options->arg( + spec => 'testfile=s', + help => + 'tests the plugin with the given disk statistics file (debugging)', + required => 0, + ); -################ -# kernel version + $options->arg( + spec => 'strip-partition-number', + help => +'strips p[0-9]+ from the device number (needed for HP Smart Array cards)', + required => 0, + ); -my $kversion = kernel_version(); + $options->getopts(); -my $proc_diskstats_available = ( -r '/proc/diskstats' ); + ################################################################################ + # Sanity checks -######################### -# Disk stats (read files) + ################ + # kernel version -if ( $kversion eq '2.6' ) { - if ( !-r '/proc/diskstats' && !-r '/proc/partitions' ) { - $plugin->nagios_exit( UNKNOWN, - '/proc/diskstats or /proc/partitions not readable' ); - } -} -else { - if ( !-r '/proc/partitions' ) { - $plugin->nagios_exit( UNKNOWN, '/proc/partitions not readable' ); - } -} + my $proc_diskstats_available = ( -r '/proc/diskstats' ); -if (! $options->testfile() ) { + ######################### + # Disk stats (read files) - if ( -r '/proc/diskstats' ) { - @stat_file = File::Slurp::read_file('/proc/diskstats'); + if ( use_diskstats() ) { + if ( !-r '/proc/diskstats' && !-r '/proc/partitions' ) { + $plugin->nagios_exit( UNKNOWN, + '/proc/diskstats or /proc/partitions not readable' ); + } } else { - @stat_file = File::Slurp::read_file('/proc/partitions'); - } - -} else { - - if ( ! -r $options->testfile() ) { - $plugin->nagios_exit( - UNKNOWN, - $options->testfile() . ' not readable' - ); + if ( !-r '/proc/partitions' ) { + $plugin->nagios_exit( UNKNOWN, '/proc/partitions not readable' ); + } } - - verbose 'Reading ' . $options->testfile() . "\n"; - - @stat_file = File::Slurp::read_file($options->testfile()); -} - + if ( !$options->testfile() ) { -if ( $options->debug() ) { - for my $line (@stat_file) { - chomp $line; - my $filename; if ( -r '/proc/diskstats' ) { - $filename = '/proc/diskstats'; + @stat_file = File::Slurp::read_file('/proc/diskstats'); } else { - $filename = '/proc/partitions'; + @stat_file = File::Slurp::read_file('/proc/partitions'); } - print "[DEBUG] $filename |$line|\n"; + } -} + else { -######### -# Devices + if ( !-r $options->testfile() ) { + $plugin->nagios_exit( UNKNOWN, + $options->testfile() . ' not readable' ); + } -my @devices; -tie @devices, 'Array::Unique'; + verbose 'Reading ' . $options->testfile() . "\n"; -for my $device ( @{ $options->device() } ) { + @stat_file = File::Slurp::read_file( $options->testfile() ); - # Detect device from mount point - if ( !( $device =~ /^\/dev\//mxs ) ) { + } - if ( $options->debug() ) { - print "[DEBUG] $device is a mount point\n"; + if ( $options->debug() ) { + for my $line (@stat_file) { + chomp $line; + my $filename; + if ( -r '/proc/diskstats' ) { + $filename = '/proc/diskstats'; + } + else { + $filename = '/proc/partitions'; + } + print "[DEBUG] $filename |$line|\n"; } + } - if ( $device ne q{/} && $device =~ /\/$/mxs ) { + ######### + # Devices - # remove trailing / - $device =~ s/\/$//mxs; - } + my @unique_devices; + ## no critic (Miscellanea::ProhibitTies) + tie @unique_devices, 'Array::Unique'; + ## use critic (Miscellanea::ProhibitTies) - my $MTAB_FH; - my $mount_point = $device; + for my $device ( @{ $options->device() } ) { - undef $device; + # Detect device from mount point + if ( !( $device =~ /^\/dev\//mxs ) ) { - open $MTAB_FH, q{<}, '/etc/mtab' - or - $plugin->nagios_exit( UNKNOWN, "Cannot open /etc/mtab: $OS_ERROR" ); - while (<$MTAB_FH>) { - my $line = $_; - chomp $line; if ( $options->debug() ) { - print "[DEBUG] /etc/mtab |$line|\n"; + print "[DEBUG] $device is a mount point\n"; } - if ( $line =~ /(\/dev.*)\ +$mount_point\ +.*/mxs ) { - $device = $1; - if ( $options->debug() ) { - print "[DEBUG] device found: $device\n"; - } - last; + + if ( $device ne q{/} && $device =~ /\/$/mxs ) { + + # remove trailing / + $device =~ s/\/$//mxs; } - } - close $MTAB_FH - or $plugin->nagios_exit( UNKNOWN, - "Error while closing /etc/mtab: $OS_ERROR" ); - if ( !$device ) { - $plugin->nagios_exit( UNKNOWN, - "Could not find a device for $mount_point" ); - } + my $MTAB_FH; + my $mount_point = $device; - # device found: strip the partition number - if ( $options->get('strip-partition-number') ) { - $device =~ s/p?[0-9]+$//mxs; - } + undef $device; - verbose "Mount point $mount_point corresponds to device $device\n"; + ## no critic (InputOutput::RequireBriefOpen) + open $MTAB_FH, q{<}, '/etc/mtab' + or $plugin->nagios_exit( UNKNOWN, + "Cannot open /etc/mtab: $OS_ERROR" ); + while (<$MTAB_FH>) { + my $line = $_; + chomp $line; + if ( $options->debug() ) { + print "[DEBUG] /etc/mtab |$line|\n"; + } + if ( $line =~ /(\/dev.*)[ ]+$mount_point[ ]+.*/mxs ) { + $device = $1; + if ( $options->debug() ) { + print "[DEBUG] device found: $device\n"; + } + last; + } + } + close $MTAB_FH + or $plugin->nagios_exit( UNKNOWN, + "Error while closing /etc/mtab: $OS_ERROR" ); + ## use critic (InputOutput::RequireBriefOpen) - my $dev_name = $device; - $dev_name =~ s/^\/dev\///mxs; + if ( !$device ) { + $plugin->nagios_exit( UNKNOWN, + "Could not find a device for $mount_point" ); + } - if ( $options->debug ) { - print "[DEBUG] device name: $dev_name\n"; - } + # device found: strip the partition number + if ( $options->get('strip-partition-number') ) { + $device =~ s/p?\d+$//mxs; + } - if ( !any { /\s$dev_name\s/msx } @stat_file ) { + verbose "Mount point $mount_point corresponds to device $device\n"; - # LVM? - if ( whoami() eq 'root' ) { + my $dev_name = $device; + $dev_name =~ s/^\/dev\///mxs; - my @output; + if ( $options->debug ) { + print "[DEBUG] device name: $dev_name\n"; + } - @output = exec_command("lvdisplay $device 2>&1 "); + ## no critic (ControlStructures::ProhibitDeepNests) + if ( !any { /\s$dev_name\s/msx } @stat_file ) { - if ( any { /not\ found/mxs } @output ) { - verbose "LVM volume not found\n"; - } - else { + # LVM? + if ( whoami() eq 'root' ) { - my @volume_groups = grep { /VG\ Name/mxs } @output; - if ( @volume_groups == 1 ) { + my @output; - $volume_groups[0] =~ s{.*\ }{}mxs; + @output = exec_command("lvdisplay $device 2>&1 "); - @output = - exec_command("vgdisplay -v $volume_groups[0] 2>&1 "); + if ( any { /not[ ]found/mxs } @output ) { + verbose "LVM volume not found\n"; + } + else { - if ( any { /not\ found/mxs } @output ) { - verbose "Cannot get info on $volume_groups[0]\n"; - } - else { + my @volume_groups = grep { /VG[ ]Name/mxs } @output; + if ( @volume_groups == 1 ) { - my @pvs = grep { /PV\ Name/mxs } @output; + $volume_groups[0] =~ s{.*[ ]}{}mxs; - if ( @pvs < 1 ) { - verbose "No physical volumes found\n"; + @output = exec_command( + "vgdisplay -v $volume_groups[0] 2>&1 "); + + if ( any { /not[ ]found/mxs } @output ) { + verbose + "Cannot get info on $volume_groups[0]\n"; } else { - # strip everything but the device name fro - # the output - for (@pvs) { - s{.*\s+/dev/([a-z]+).*}{/dev/$1}mxs; + my @pvs = grep { /PV[ ]Name/mxs } @output; + + if ( @pvs < 1 ) { + verbose "No physical volumes found\n"; } + else { + + # strip everything but the device name fro + # the output + for (@pvs) { +s{.*\s+/dev/([[:lower:]]+).*}{/dev/$1}mxs; + } - push @devices, @pvs; + push @unique_devices, @pvs; + + } } @@ -824,275 +849,285 @@ } } + else { - } - else { + $plugin->nagios_exit( UNKNOWN, + "Cannot check LVM volume $device if not root" ); - $plugin->nagios_exit( UNKNOWN, - "Cannot check LVM volume $device if not root" ); + } } + ## use critic (ControlStructures::ProhibitDeepNests) } + else { - } - else { + push @unique_devices, $device; - push @devices, $device; + } } -} - -if ( $options->debug() ) { - print "[DEBUG] devices: @devices\n"; -} + if ( $options->debug() ) { + #<<< + print "[DEBUG] devices: @unique_devices\n"; ## no critic (RequireCheckedSyscalls) + #>>> + } -# check if the devices exist + # check if the devices exist -for my $device (@devices) { - if ( !-e $device && ! $options->testfile() ) { - $plugin->nagios_exit( UNKNOWN, "Device $device not found" ); + for my $device (@unique_devices) { + if ( !-e $device && !$options->testfile() ) { + $plugin->nagios_exit( UNKNOWN, "Device $device not found" ); + } } -} -verbose "Checking: @devices\n"; + verbose "Checking: @unique_devices\n"; ##### -# UOM + # UOM -my $multiplier; -my $UOM; + my $multiplier; + my $UOM; -if ( $options->uom() ) { - $format = $options->uom(); -} + if ( $options->uom() ) { + $format = $options->uom(); + } -# according to the guidelines only [TGMK]B (Bytes) are valid UOM -# http://nagiosplug.sourceforge.net/developer-guidelines.html#AEN201 -my $perfdata_UOM = 'B'; -if ( $format eq 's' || $format =~ /^sector[s]$/mxs ) { - - #sectors - $multiplier = 1; - $UOM = 'sectors'; - $perfdata_UOM = q{}; + # according to the guidelines only [TGMK]B (Bytes) are valid UOM + # http://nagiosplug.sourceforge.net/developer-guidelines.html#AEN201 + my $perfdata_uom = 'B'; + if ( $format eq 's' || $format =~ /^sector[s]$/mxs ) { -} -elsif ( $format eq 'b' || $format =~ /^bit[s]$/mxs ) { + #sectors + $multiplier = 1; + $UOM = 'sectors'; + $perfdata_uom = q{}; - # bits - $multiplier = $options->ssize() * $BITS_PER_BYTE; - $UOM = 'b'; - $perfdata_UOM = q{}; + } + elsif ( $format eq 'b' || $format =~ /^bit[s]$/mxs ) { -} -elsif ( $format eq 'B' || $format =~ /^byte[s]$/mxs ) { + # bits + $multiplier = $options->ssize() * $BITS_PER_BYTE; + $UOM = 'b'; + $perfdata_uom = q{}; - # bytes - $multiplier = $options->ssize(); - $UOM = 'B'; + } + elsif ( $format eq 'B' || $format =~ /^byte[s]$/mxs ) { -} -else { - $plugin->nagios_exit( UNKNOWN, "Uknown unit of measurement: $format" ); -} + # bytes + $multiplier = $options->ssize(); + $UOM = 'B'; -my $unit = 1024; -if ( $options->factor() ) { - $format = $options->factor(); - - if ( $format =~ m/^ki$/imxs || $format =~ m/^Kibi$/imxs ) { - $factor = 1024; - } - elsif ( $format =~ m/^mi$/imxs || $format =~ m/^mebi$/imxs ) { - $factor = 1024 * 1024; - } - elsif ( $format =~ m/^gi$/imxs || $format =~ m/^gibi$/imxs ) { - $factor = 1024 * 1024 * 1024; - } - elsif ( $format =~ m/^k$/imxs || $format =~ m/^Kilo$/imxs ) { - $factor = 1000; - $unit = 1000; - } - elsif ( $format =~ m/^m$/imxs || $format =~ m/^mega$/imxs ) { - $factor = 1000 * 1000; - $unit = 1000; - } - elsif ( $format =~ m/^g$/imxs || $format =~ m/^giga$/imxs ) { - $factor = 1000 * 1000 * 1000; - $unit = 1000; } else { - $plugin->nagios_exit( UNKNOWN, "Uknown unit of threshold: $format" ); + $plugin->nagios_exit( UNKNOWN, "Uknown unit of measurement: $format" ); } -} -################ -# Initialization + my $unit = $KIBI; + ## no critic (ControlStructures::ProhibitCascadingIfElse) + if ( $options->factor() ) { + $format = $options->factor(); -$threshold = Nagios::Plugin::Threshold->set_thresholds( - warning => $options->warning() * $factor, - critical => $options->critical() * $factor, -); + if ( $format =~ m/^ki$/imxs || $format =~ m/^Kibi$/imxs ) { + $factor = $KIBI; + } + elsif ( $format =~ m/^mi$/imxs || $format =~ m/^mebi$/imxs ) { + $factor = $KIBI * $KIBI; + } + elsif ( $format =~ m/^gi$/imxs || $format =~ m/^gibi$/imxs ) { + $factor = $KIBI * $KIBI * $KIBI; + } + elsif ( $format =~ m/^k$/imxs || $format =~ m/^Kilo$/imxs ) { + $factor = $KILO; + $unit = $KILO; + } + elsif ( $format =~ m/^m$/imxs || $format =~ m/^mega$/imxs ) { + $factor = $KILO * $KILO; + $unit = $KILO; + } + elsif ( $format =~ m/^g$/imxs || $format =~ m/^giga$/imxs ) { + $factor = $KILO * $KILO * $KILO; + $unit = $KILO; + } + else { + $plugin->nagios_exit( UNKNOWN, + "Uknown unit of threshold: $format" ); + } + } + ## use critic (ControlStructures::ProhibitCascadingIfElse) -my $tmp_file_prefix = '/tmp/check_diskio_status-' . whoami(); + ################ + # Initialization -# strip /dev/ -for (@devices) { - s/^\/dev\///mxs; -} + $threshold = Nagios::Plugin::Threshold->set_thresholds( + warning => $options->warning() * $factor, + critical => $options->critical() * $factor, + ); -for my $device (@devices) { + my $tmp_file_prefix = '/tmp/check_diskio_status-' . whoami(); - # we need one temporary file per device - my ( $controller, $disk ) = split /\//mxs, $device; - if ( !$disk ) { - $tmp_files{$device} = "$tmp_file_prefix-$controller"; - } - else { - $tmp_files{$device} = "$tmp_file_prefix--$disk"; + # strip /dev/ + for (@unique_devices) { + s/^\/dev\///mxs; } -} + for my $device (@unique_devices) { -######################## -# Check the proc entry + # we need one temporary file per device + my ( $controller, $disk ) = split /\//mxs, $device; + if ( !$disk ) { + $tmp_files{$device} = "$tmp_file_prefix-$controller"; + } + else { + $tmp_files{$device} = "$tmp_file_prefix--$disk"; + } -my $diff; -my $found = 0; -my $in; -my $out; -my $time; + } -my $s_read; -my $s_write; +######################## + # Check the proc entry -my $TMP_FH; -my $status = OK; -my @status_lines; + my $diff; + my $found = 0; + my $in; + my $out; + my $time; -for my $device (@devices) { + my $s_read; + my $s_write; - if ( $kversion eq '2.6' && $proc_diskstats_available ) { - ( $s_read, $s_write ) = read_26($device); - } - else { - ( $s_read, $s_write ) = read_24($device); - } + my $TMP_FH; + my $status = OK; + my @status_lines; - verbose 'current data: read=' - . format_number( $s_read, 0, 0 ) - . ' write=' - . format_number( $s_write, 0, 0 ) - . "\n", 1; + for my $device (@unique_devices) { - if ( !-f $tmp_files{$device} ) { - verbose "temporary file not available resetting and waiting\n"; - write_timer( $tmp_files{$device}, $s_write, $s_read ); - sleep 1; - if ( $kversion eq '2.6' && $proc_diskstats_available ) { + if ( use_diskstats() && $proc_diskstats_available ) { ( $s_read, $s_write ) = read_26($device); } else { ( $s_read, $s_write ) = read_24($device); } - } - ( $diff, $in, $out ) = read_timer( $tmp_files{$device} ); + verbose 'current data: read=' + . format_number( $s_read, 0, 0 ) + . ' write=' + . format_number( $s_write, 0, 0 ) + . "\n", 1; + + if ( !-f $tmp_files{$device} ) { + verbose "temporary file not available resetting and waiting\n"; + write_timer( $tmp_files{$device}, $s_write, $s_read ); + sleep 1; + if ( use_diskstats() && $proc_diskstats_available ) { + ( $s_read, $s_write ) = read_26($device); + } + else { + ( $s_read, $s_write ) = read_24($device); + } + } + + ( $diff, $in, $out ) = read_timer( $tmp_files{$device} ); - if ( $diff < 1 ) { + if ( $diff < 1 ) { - # wait a little bit - sleep 1; - ( $diff, $in, $out ) = read_timer(); + # wait a little bit + sleep 1; + ( $diff, $in, $out ) = read_timer(); - } + } - write_timer( $tmp_files{$device}, $s_write, $s_read ); + write_timer( $tmp_files{$device}, $s_write, $s_read ); - verbose 'time difference: ' . $diff . "s\n", 1; + verbose 'time difference: ' . $diff . "s\n", 1; - if ( $diff == 0 ) { + if ( $diff == 0 ) { - # round up - $diff = 1; + # round up + $diff = 1; - } + } - # check for overflows (2^32 sectors) - if ( $s_write < $in ) { + # check for overflows (2^32 sectors) + if ( $s_write < $in ) { - # overflow - $diskio_w{$device} = $OVERFLOW - $in + $s_write; + # overflow + $diskio_w{$device} = $OVERFLOW - $in + $s_write; - } - else { - $diskio_w{$device} = $s_write - $in; - } + } + else { + $diskio_w{$device} = $s_write - $in; + } - if ( $s_read < $out ) { + if ( $s_read < $out ) { - # overflow - $diskio_r{$device} = $OVERFLOW - $out + $s_read; - } - else { - $diskio_r{$device} = $s_read - $out; - } + # overflow + $diskio_r{$device} = $OVERFLOW - $out + $s_read; + } + else { + $diskio_r{$device} = $s_read - $out; + } - $diskio_w{$device} = int( $diskio_w{$device} * $multiplier / $diff ); - $diskio_r{$device} = int( $diskio_r{$device} * $multiplier / $diff ); - $diskio{$device} = $diskio_w{$device} + $diskio_r{$device}; + $diskio_w{$device} = int( $diskio_w{$device} * $multiplier / $diff ); + $diskio_r{$device} = int( $diskio_r{$device} * $multiplier / $diff ); + $diskio{$device} = $diskio_w{$device} + $diskio_r{$device}; + + my $suffix = q{}; + + # we append the device name to the labels only if there is more + # than one device to maintain backwards compatibility + if ( @unique_devices > 1 ) { + $suffix = "_\U$device"; + } - my $suffix = q{}; + # use unscaled values for performance data - will be scaled by rrdtool - # we append the device name to the labels only if there is more - # than one device to maintain backwards compatibility - if ( @devices > 1 ) { - $suffix = "_\U$device"; - } + $plugin->add_perfdata( + label => "WRITE$suffix", + value => sprintf( '%.0f', $diskio_w{$device} ), + uom => $perfdata_uom, + threshold => $threshold, + ); - # use unscaled values for performance data - will be scaled by rrdtool + $plugin->add_perfdata( + label => "READ$suffix", + value => sprintf( '%.0f', $diskio_r{$device} ), + uom => $perfdata_uom, + threshold => $threshold, + ); - $plugin->add_perfdata( - label => "WRITE$suffix", - value => sprintf( '%.0f', $diskio_w{$device} ), - uom => $perfdata_UOM, - threshold => $threshold, - ); + $plugin->add_perfdata( + label => "TOTAL$suffix", + value => sprintf( '%.0f', $diskio{$device} ), + uom => $perfdata_uom, + threshold => $threshold, + ); - $plugin->add_perfdata( - label => "READ$suffix", - value => sprintf( '%.0f', $diskio_r{$device} ), - uom => $perfdata_UOM, - threshold => $threshold, - ); + my $device_status = $threshold->get_status( $diskio{$device} ); + if ( $device_status == CRITICAL ) { + $status = CRITICAL; + } + elsif ( $device_status == WARNING && $status != CRITICAL ) { + $status = WARNING; + } - $plugin->add_perfdata( - label => "TOTAL$suffix", - value => sprintf( '%.0f', $diskio{$device} ), - uom => $perfdata_UOM, - threshold => $threshold, - ); + my ( $val, $prefix ) = shortenrate( $diskio{$device}, $unit ); + push @status_lines, + "$device " . sprintf( '%.2f', $val ) . " $prefix$UOM/s"; - my $device_status = $threshold->get_status( $diskio{$device} ); - if ( $device_status == CRITICAL ) { - $status = CRITICAL; - } - elsif ( $device_status == WARNING && $status != CRITICAL ) { - $status = WARNING; } - my ( $val, $prefix ) = shortenrate( $diskio{$device}, $unit ); - push @status_lines, "$device " . sprintf( '%.2f', $val ) . " $prefix$UOM/s"; + if ( $options->silent() ) { + $plugin->nagios_exit( OK, ( join ', ', @unique_devices ) . 'OK' ); + } + else { + $plugin->nagios_exit( $status, join ', ', @status_lines, ); + } -} + return; -if ( $options->silent() ) { - $plugin->nagios_exit( OK, ( join ', ', @devices ) . 'OK' ); -} -else { - $plugin->nagios_exit( $status, join ', ', @status_lines, ); } +## use critic (Subroutines::ProhibitExcessComplexity) 1;

@@ -4,17 +4,17 @@ =head1 NAME C<check_diskio> - a Nagios plugin to monitor the amount of disk I/O in sectors -on Linux 2.6 and 2.4 systems +on Linux =head1 DESCRIPTION check_diskio is a Nagios plugin to monitor the amount of disk I/O in sectors -on Linux 2.6 and 2.4 systems +on Linux =head1 VERSION -Version 3.2.3 +Version 3.2.4 =head1 SYNOPSIS

@@ -1,32 +1,44 @@ ################################################################################ # File version information: -# $Id: check_diskio.spec 1196 2010-10-22 13:57:51Z corti $ -# $Revision: 1196 $ +# $Id: check_diskio.spec 1278 2011-11-09 18:44:34Z corti $ +# $Revision: 1278 $ # $HeadURL: https://svn.id.ethz.ch/nagios_plugins/check_diskio/check_diskio.spec $ -# $Date: 2010-10-22 15:57:51 +0200 (Fri, 22 Oct 2010) $ +# $Date: 2011-11-09 19:44:34 +0100 (Wed, 09 Nov 2011) $ ################################################################################ -%define version 3.2.3 -%define release 0 -%define name check_diskio +%define version 3.2.4 +%define release 0 +%define sourcename check_diskio +%define packagename nagios-plugins-check-diskio %define nagiospluginsdir %{_libdir}/nagios/plugins # No binaries in this package %define debug_package %{nil} Summary: Nagios plugin to monitor the amount of disk I/O -Name: %{name} +Name: %{packagename} Version: %{version} +Obsoletes: check_diskio Release: %{release}%{?dist} License: GPLv3+ Packager: Matteo Corti <matteo.corti@id.ethz.ch> Group: Applications/System -BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) -URL: https://trac.id.ethz.ch/projects/nagios_plugins/wiki/%{name} -Source: https://trac.id.ethz.ch/projects/nagios_plugins/downloads/%{name}-%{version}.tar.gz +BuildRoot: %{_tmppath}/%{packagename}-%{version}-%{release}-root-%(%{__id_u} -n) +URL: https://trac.id.ethz.ch/projects/nagios_plugins/wiki/check_diskio +Source: https://trac.id.ethz.ch/projects/nagios_plugins/downloads/%{sourcename}-%{version}.tar.gz # Fedora build requirement (not needed for EPEL{4,5}) BuildRequires: perl(ExtUtils::MakeMaker) +BuildRequires: perl(Test::More) +BuildRequires: perl(Number::Format) +BuildRequires: perl(Nagios::Plugin) +BuildRequires: perl(Readonly) +BuildRequires: perl(File::Spec) +BuildRequires: perl(List::MoreUtils) +BuildRequires: perl(File::Slurp) +BuildRequires: perl(English) +BuildRequires: perl(Carp) +BuildRequires: perl(Array::Unique) Requires: nagios-plugins @@ -34,7 +46,7 @@ Nagios plugin to monitor the amount of disk I/O %prep -%setup -q +%setup -q -n %{sourcename}-%{version} %build %{__perl} Makefile.PL INSTALLDIRS=vendor \ @@ -50,16 +62,22 @@ find %{buildroot} -depth -type d -exec rmdir {} 2>/dev/null \; %{_fixperms} %{buildroot}/* +%check +make test + %clean rm -rf %{buildroot} %files %defattr(-, root, root, -) %doc AUTHORS Changes NEWS README INSTALL TODO COPYING COPYRIGHT -%{nagiospluginsdir}/%{name} -%{_mandir}/man1/%{name}.1* +%{nagiospluginsdir}/%{sourcename} +%{_mandir}/man1/%{sourcename}.1* %changelog +* Wed Nov 9 2011 Matteo Corti <matteo.corti@id.ethz.ch> - 3.2.4-0 +- 3.X kernel support + * Fri Oct 22 2010 Matteo Corti <matteo.corti@id.ethz.ch> - 3.2.3-0 - Fixed a bug in the statistics parsing

@@ -19,6 +19,10 @@ use 5.005; use strict 'vars'; +use Cwd (); +use File::Find (); +use File::Path (); +use FindBin; use vars qw{$VERSION $MAIN}; BEGIN { @@ -28,7 +32,7 @@ # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. - $VERSION = '0.91'; + $VERSION = '0.95'; # Storage for the pseudo-singleton $MAIN = undef; @@ -38,18 +42,25 @@ } +sub import { + my $class = shift; + my $self = $class->new(@_); + my $who = $self->_caller; - - - -# Whether or not inc::Module::Install is actually loaded, the -# $INC{inc/Module/Install.pm} is what will still get set as long as -# the caller loaded module this in the documented manner. -# If not set, the caller may NOT have loaded the bundled version, and thus -# they may not have a MI version that works with the Makefile.PL. This would -# result in false errors or unexpected behaviour. And we don't want that. -my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; -unless ( $INC{$file} ) { die <<"END_DIE" } + #------------------------------------------------------------- + # all of the following checks should be included in import(), + # to allow "eval 'require Module::Install; 1' to test + # installation of Module::Install. (RT #51267) + #------------------------------------------------------------- + + # Whether or not inc::Module::Install is actually loaded, the + # $INC{inc/Module/Install.pm} is what will still get set as long as + # the caller loaded module this in the documented manner. + # If not set, the caller may NOT have loaded the bundled version, and thus + # they may not have a MI version that works with the Makefile.PL. This would + # result in false errors or unexpected behaviour. And we don't want that. + my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; + unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: @@ -61,26 +72,28 @@ END_DIE - - - - -# If the script that is loading Module::Install is from the future, -# then make will detect this and cause it to re-run over and over -# again. This is bad. Rather than taking action to touch it (which -# is unreliable on some platforms and requires write permissions) -# for now we should catch this and refuse to run. -if ( -f $0 ) { - my $s = (stat($0))[9]; - - # If the modification time is only slightly in the future, - # sleep briefly to remove the problem. - my $a = $s - time; - if ( $a > 0 and $a < 5 ) { sleep 5 } - - # Too far in the future, throw an error. - my $t = time; - if ( $s > $t ) { die <<"END_DIE" } + # This reportedly fixes a rare Win32 UTC file time issue, but + # as this is a non-cross-platform XS module not in the core, + # we shouldn't really depend on it. See RT #24194 for detail. + # (Also, this module only supports Perl 5.6 and above). + eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; + + # If the script that is loading Module::Install is from the future, + # then make will detect this and cause it to re-run over and over + # again. This is bad. Rather than taking action to touch it (which + # is unreliable on some platforms and requires write permissions) + # for now we should catch this and refuse to run. + if ( -f $0 ) { + my $s = (stat($0))[9]; + + # If the modification time is only slightly in the future, + # sleep briefly to remove the problem. + my $a = $s - time; + if ( $a > 0 and $a < 5 ) { sleep 5 } + + # Too far in the future, throw an error. + my $t = time; + if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). @@ -89,15 +102,12 @@ Please correct this, then run $0 again. END_DIE -} - - - + } -# Build.PL was formerly supported, but no longer is due to excessive -# difficulty in implementing every single feature twice. -if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } + # Build.PL was formerly supported, but no longer is due to excessive + # difficulty in implementing every single feature twice. + if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. @@ -107,23 +117,36 @@ END_DIE + #------------------------------------------------------------- + # To save some more typing in Module::Install installers, every... + # use inc::Module::Install + # ...also acts as an implicit use strict. + $^H |= strict::bits(qw(refs subs vars)); + #------------------------------------------------------------- + unless ( -f $self->{file} ) { + require "$self->{path}/$self->{dispatch}.pm"; + File::Path::mkpath("$self->{prefix}/$self->{author}"); + $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); + $self->{admin}->init; + @_ = ($class, _self => $self); + goto &{"$self->{name}::import"}; + } -# To save some more typing in Module::Install installers, every... -# use inc::Module::Install -# ...also acts as an implicit use strict. -$^H |= strict::bits(qw(refs subs vars)); - - + *{"${who}::AUTOLOAD"} = $self->autoload; + $self->preload; + # Unregister loader and worker packages so subdirs can use them again + delete $INC{"$self->{file}"}; + delete $INC{"$self->{path}.pm"}; + # Save to the singleton + $MAIN = $self; -use Cwd (); -use File::Find (); -use File::Path (); -use FindBin; + return 1; +} sub autoload { my $self = shift; @@ -152,33 +175,6 @@ }; } -sub import { - my $class = shift; - my $self = $class->new(@_); - my $who = $self->_caller; - - unless ( -f $self->{file} ) { - require "$self->{path}/$self->{dispatch}.pm"; - File::Path::mkpath("$self->{prefix}/$self->{author}"); - $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); - $self->{admin}->init; - @_ = ($class, _self => $self); - goto &{"$self->{name}::import"}; - } - - *{"${who}::AUTOLOAD"} = $self->autoload; - $self->preload; - - # Unregister loader and worker packages so subdirs can use them again - delete $INC{"$self->{file}"}; - delete $INC{"$self->{path}.pm"}; - - # Save to the singleton - $MAIN = $self; - - return 1; -} - sub preload { my $self = shift; unless ( $self->{extensions} ) { @@ -348,17 +344,24 @@ return $call; } +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; - if ( $] >= 5.006 ) { - open( FH, '<', $_[0] ) or die "open($_[0]): $!"; - } else { - open( FH, "< $_[0]" ) or die "open($_[0]): $!"; - } + open( FH, '<', $_[0] ) or die "open($_[0]): $!"; + my $string = do { local $/; <FH> }; + close FH or die "close($_[0]): $!"; + return $string; +} +END_NEW +sub _read { + local *FH; + open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; <FH> }; close FH or die "close($_[0]): $!"; return $string; } +END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); @@ -379,18 +382,26 @@ return $string; } +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; - if ( $] >= 5.006 ) { - open( FH, '>', $_[0] ) or die "open($_[0]): $!"; - } else { - open( FH, "> $_[0]" ) or die "open($_[0]): $!"; + open( FH, '>', $_[0] ) or die "open($_[0]): $!"; + foreach ( 1 .. $#_ ) { + print FH $_[$_] or die "print($_[0]): $!"; } + close FH or die "close($_[0]): $!"; +} +END_NEW +sub _write { + local *FH; + open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } +END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). @@ -427,4 +438,4 @@ 1; -# Copyright 2008 - 2009 Adam Kennedy. +# Copyright 2008 - 2010 Adam Kennedy.

@@ -4,7 +4,7 @@ use strict 'vars'; use vars qw{$VERSION}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; } # Suspend handler for "redefined" warnings

@@ -6,7 +6,7 @@ use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; }

@@ -7,12 +7,12 @@ use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } -my $makefile; +my $makefile = undef; sub WriteMakefile { my ($self, %args) = @_; @@ -36,6 +36,12 @@ } } + if (my $prereq = delete($args{BUILD_REQUIRES})) { + while (my($k,$v) = each %$prereq) { + $self->build_requires($k,$v); + } + } + # put the remaining args to makemaker_args $self->makemaker_args(%args); }

@@ -7,7 +7,7 @@ use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -25,8 +25,8 @@ die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } - # In automated testing, always use defaults - if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { + # In automated testing or non-interactive session, always use defaults + if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { @@ -34,21 +34,110 @@ } } +# Store a cleaned up version of the MakeMaker version, +# since we need to behave differently in a variety of +# ways based on the MM version. +my $makemaker = eval $ExtUtils::MakeMaker::VERSION; + +# If we are passed a param, do a "newer than" comparison. +# Otherwise, just return the MakeMaker version. +sub makemaker { + ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 +} + +# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified +# as we only need to know here whether the attribute is an array +# or a hash or something else (which may or may not be appendable). +my %makemaker_argtype = ( + C => 'ARRAY', + CONFIG => 'ARRAY', +# CONFIGURE => 'CODE', # ignore + DIR => 'ARRAY', + DL_FUNCS => 'HASH', + DL_VARS => 'ARRAY', + EXCLUDE_EXT => 'ARRAY', + EXE_FILES => 'ARRAY', + FUNCLIST => 'ARRAY', + H => 'ARRAY', + IMPORTS => 'HASH', + INCLUDE_EXT => 'ARRAY', + LIBS => 'ARRAY', # ignore '' + MAN1PODS => 'HASH', + MAN3PODS => 'HASH', + META_ADD => 'HASH', + META_MERGE => 'HASH', + PL_FILES => 'HASH', + PM => 'HASH', + PMLIBDIRS => 'ARRAY', + PMLIBPARENTDIRS => 'ARRAY', + PREREQ_PM => 'HASH', + CONFIGURE_REQUIRES => 'HASH', + SKIP => 'ARRAY', + TYPEMAPS => 'ARRAY', + XS => 'HASH', +# VERSION => ['version',''], # ignore +# _KEEP_AFTER_FLUSH => '', + + clean => 'HASH', + depend => 'HASH', + dist => 'HASH', + dynamic_lib=> 'HASH', + linkext => 'HASH', + macro => 'HASH', + postamble => 'HASH', + realclean => 'HASH', + test => 'HASH', + tool_autosplit => 'HASH', + + # special cases where you can use makemaker_append + CCFLAGS => 'APPENDABLE', + DEFINE => 'APPENDABLE', + INC => 'APPENDABLE', + LDDLFLAGS => 'APPENDABLE', + LDFROM => 'APPENDABLE', +); + sub makemaker_args { - my $self = shift; + my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); - %$args = ( %$args, @_ ); + foreach my $key (keys %new_args) { + if ($makemaker_argtype{$key} eq 'ARRAY') { + $args->{$key} = [] unless defined $args->{$key}; + unless (ref $args->{$key} eq 'ARRAY') { + $args->{$key} = [$args->{$key}] + } + push @{$args->{$key}}, + ref $new_args{$key} eq 'ARRAY' + ? @{$new_args{$key}} + : $new_args{$key}; + } + elsif ($makemaker_argtype{$key} eq 'HASH') { + $args->{$key} = {} unless defined $args->{$key}; + foreach my $skey (keys %{ $new_args{$key} }) { + $args->{$key}{$skey} = $new_args{$key}{$skey}; + } + } + elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { + $self->makemaker_append($key => $new_args{$key}); + } + else { + if (defined $args->{$key}) { + warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; + } + $args->{$key} = $new_args{$key}; + } + } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { - my $self = sShift; + my $self = shift; my $name = shift; my $args = $self->makemaker_args; - $args->{name} = defined $args->{$name} - ? join( ' ', $args->{name}, @_ ) + $args->{$name} = defined $args->{$name} + ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } @@ -107,6 +196,9 @@ %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); + if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { + File::Find::find( \&_wanted_t, 'xt' ); + } $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } @@ -130,12 +222,13 @@ # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. - $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); - $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); + my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; + $self->build_requires( 'ExtUtils::MakeMaker' => $v ); + $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. - $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); + $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } @@ -143,59 +236,103 @@ my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; - $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; + $args->{VERSION} = $self->version or die <<'EOT'; +ERROR: Can't determine distribution version. Please specify it +explicitly via 'version' in Makefile.PL, or set a valid $VERSION +in a module, and provide its file path via 'version_from' (or +'all_from' if you prefer) in Makefile.PL. +EOT + + $DB::single = 1; if ( $self->tests ) { - $args->{test} = { TESTS => $self->tests }; + my @tests = split ' ', $self->tests; + my %seen; + $args->{test} = { + TESTS => (join ' ', grep {!$seen{$_}++} @tests), + }; + } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { + $args->{test} = { + TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), + }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; - $args->{AUTHOR} = $self->author; + $args->{AUTHOR} = join ', ', @{$self->author || []}; } - if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { - $args->{NO_META} = 1; + if ( $self->makemaker(6.10) ) { + $args->{NO_META} = 1; + #$args->{NO_MYMETA} = 1; } - if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { + if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } + if ( $self->makemaker(6.31) and $self->license ) { + $args->{LICENSE} = $self->license; + } - # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, - map { @$_ } + map { @$_ } # flatten [module => version] map { @$_ } grep $_, - ($self->configure_requires, $self->build_requires, $self->requires) + ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; - # merge both kinds of requires into prereq_pm + # Merge both kinds of requires into BUILD_REQUIRES + my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); + %$build_prereq = ( %$build_prereq, + map { @$_ } # flatten [module => version] + map { @$_ } + grep $_, + ($self->configure_requires, $self->build_requires) + ); + + # Remove any reference to perl, BUILD_REQUIRES doesn't support it + delete $args->{BUILD_REQUIRES}->{perl}; + + # Delete bundled dists from prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; - delete $prereq->{$file}; + delete $build_prereq->{$file}; #Delete from build prereqs only } } + unless ( $self->makemaker('6.55_03') ) { + %$prereq = (%$prereq,%$build_prereq); + delete $args->{BUILD_REQUIRES}; + } + if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; + + if ( $self->makemaker(6.48) ) { + $args->{MIN_PERL_VERSION} = $perl_version; + } } - $args->{INSTALLDIRS} = $self->installdirs; + if ($self->installdirs) { + warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; + $args->{INSTALLDIRS} = $self->installdirs; + } - my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; + my %args = map { + ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) + } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; - if (my $preop = $self->admin->preop($user_preop)) { + if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } @@ -265,4 +402,4 @@ __END__ -#line 394 +#line 531

@@ -6,7 +6,7 @@ use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -19,7 +19,6 @@ name module_name abstract - author version distribution_type tests @@ -43,8 +42,11 @@ my @array_keys = qw{ keywords + author }; +*authors = \&author; + sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } @@ -230,6 +232,8 @@ die("The path '$file' does not exist, or is not a file"); } + $self->{values}{all_from} = $file; + # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; @@ -240,7 +244,7 @@ $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; - $self->author_from($pod) unless $self->author; + $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; @@ -385,11 +389,10 @@ } } -sub perl_version_from { - my $self = shift; +sub _extract_perl_version { if ( - Module::Install::_read($_[0]) =~ m/ - ^ + $_[0] =~ m/ + ^\s* (?:use|require) \s* v? ([\d_\.]+) @@ -398,6 +401,16 @@ ) { my $perl_version = $1; $perl_version =~ s{_}{}g; + return $perl_version; + } else { + return; + } +} + +sub perl_version_from { + my $self = shift; + my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); + if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; @@ -417,59 +430,116 @@ ([^\n]*) /ixms) { my $author = $1 || $2; - $author =~ s{E<lt>}{<}g; - $author =~ s{E<gt>}{>}g; + + # XXX: ugly but should work anyway... + if (eval "require Pod::Escapes; 1") { + # Pod::Escapes has a mapping table. + # It's in core of perl >= 5.9.3, and should be installed + # as one of the Pod::Simple's prereqs, which is a prereq + # of Pod::Text 3.x (see also below). + $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } + { + defined $2 + ? chr($2) + : defined $Pod::Escapes::Name2character_number{$1} + ? chr($Pod::Escapes::Name2character_number{$1}) + : do { + warn "Unknown escape: E<$1>"; + "E<$1>"; + }; + }gex; + } + elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { + # Pod::Text < 3.0 has yet another mapping table, + # though the table name of 2.x and 1.x are different. + # (1.x is in core of Perl < 5.6, 2.x is in core of + # Perl < 5.9.3) + my $mapping = ($Pod::Text::VERSION < 2) + ? \%Pod::Text::HTML_Escapes + : \%Pod::Text::ESCAPES; + $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } + { + defined $2 + ? chr($2) + : defined $mapping->{$1} + ? $mapping->{$1} + : do { + warn "Unknown escape: E<$1>"; + "E<$1>"; + }; + }gex; + } + else { + $author =~ s{E<lt>}{<}g; + $author =~ s{E<gt>}{>}g; + } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } -sub license_from { - my $self = shift; - if ( - Module::Install::_read($_[0]) =~ m/ - ( - =head \d \s+ - (?:licen[cs]e|licensing|copyright|legal)\b - .*? - ) - (=head\\d.*|=cut.*|) - \z - /ixms ) { - my $license_text = $1; - my @phrases = ( - 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1, - 'GNU general public license' => 'gpl', 1, - 'GNU public license' => 'gpl', 1, - 'GNU lesser general public license' => 'lgpl', 1, - 'GNU lesser public license' => 'lgpl', 1, - 'GNU library general public license' => 'lgpl', 1, - 'GNU library public license' => 'lgpl', 1, - 'BSD license' => 'bsd', 1, - 'Artistic license' => 'artistic', 1, - 'GPL' => 'gpl', 1, - 'LGPL' => 'lgpl', 1, - 'BSD' => 'bsd', 1, - 'Artistic' => 'artistic', 1, - 'MIT' => 'mit', 1, - 'proprietary' => 'proprietary', 0, - ); - while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { - $pattern =~ s{\s+}{\\s+}g; - if ( $license_text =~ /\b$pattern\b/i ) { - $self->license($license); - return 1; - } +sub _extract_license { + my $pod = shift; + my $matched; + return __extract_license( + ($matched) = $pod =~ m/ + (=head \d \s+ (?:licen[cs]e|licensing)\b.*?) + (=head \d.*|=cut.*|)\z + /ixms + ) || __extract_license( + ($matched) = $pod =~ m/ + (=head \d \s+ (?:copyrights?|legal)\b.*?) + (=head \d.*|=cut.*|)\z + /ixms + ); +} + +sub __extract_license { + my $license_text = shift or return; + my @phrases = ( + 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1, + 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1, + 'Artistic and GPL' => 'perl', 1, + 'GNU general public license' => 'gpl', 1, + 'GNU public license' => 'gpl', 1, + 'GNU lesser general public license' => 'lgpl', 1, + 'GNU lesser public license' => 'lgpl', 1, + 'GNU library general public license' => 'lgpl', 1, + 'GNU library public license' => 'lgpl', 1, + 'BSD license' => 'bsd', 1, + 'Artistic license' => 'artistic', 1, + 'GPL' => 'gpl', 1, + 'LGPL' => 'lgpl', 1, + 'BSD' => 'bsd', 1, + 'Artistic' => 'artistic', 1, + 'MIT' => 'mit', 1, + 'proprietary' => 'proprietary', 0, + ); + while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { + $pattern =~ s#\s+#\\s+#gs; + if ( $license_text =~ /\b$pattern\b/i ) { + return $license; } } +} - warn "Cannot determine license info from $_[0]\n"; - return 'unknown'; +sub license_from { + my $self = shift; + if (my $license=_extract_license(Module::Install::_read($_[0]))) { + $self->license($license); + } else { + warn "Cannot determine license info from $_[0]\n"; + return 'unknown'; + } } sub _extract_bugtracker { - my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; + my @links = $_[0] =~ m#L<( + \Qhttp://rt.cpan.org/\E[^>]+| + \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| + \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list + )>#gx; my %links; @links{@links}=(); @links=keys %links; @@ -485,7 +555,7 @@ return 0; } if ( @links > 1 ) { - warn "Found more than on rt.cpan.org link in $_[0]\n"; + warn "Found more than one bugtracker link in $_[0]\n"; return 0; }

@@ -6,7 +6,7 @@ use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; }

[-] [+]	Added	check_diskio.changes
@@ -0,0 +1,5 @@ +------------------------------------------------------------------- +Fri Nov 11 13:07:53 UTC 2011 - cs@linux-administrator.com + +- Update to release 3.2.4 +
[-] [+]	Changed	check_diskio.spec ^
@@ -1,4 +1,4 @@ -%define version 3.2.3 +%define version 3.2.4 %define release 1 %define pkgname check_diskio %define _plugindir /usr/lib/nagios/plugins @@ -12,7 +12,7 @@ Packager: Matteo Corti <matteo.corti@id.ethz.ch> Group: Applications/System BuildRoot: %{_tmppath}/%{pkgname}-%{version}-root -Source: http://www.id.ethz.ch/people/allid_list/corti/%{pkgname}-%{version}.tar.gz +Source: http://www.id.ethz.ch/people/allid_list/corti/%{pkgname}-%{version}.tar.bz2 BuildArch: noarch BuildRequires: perl-Nagios-Plugin
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/Changes ^
@@ -1,3 +1,7 @@ +2011-11-09 Matteo Corti <matteo.corti@id.ethz.ch> + + * check_diskio: support for 3.x kernels + 2010-10-22 Matteo Corti <matteo.corti@id.ethz.ch> * check_diskio: fixed a problem in the parsing of the diskstat file @@ -114,7 +118,7 @@ * Initial release -# $Id: Changes 1196 2010-10-22 13:57:51Z corti $ -# $Revision: 1196 $ +# $Id: Changes 1275 2011-11-09 15:24:34Z corti $ +# $Revision: 1275 $ # $HeadURL: https://svn.id.ethz.ch/nagios_plugins/check_diskio/Changes $ -# $Date: 2010-10-22 15:57:51 +0200 (Fri, 22 Oct 2010) $ +# $Date: 2011-11-09 16:24:34 +0100 (Wed, 09 Nov 2011) $
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/META.yml ^
@@ -4,10 +4,12 @@ - 'Matteo Corti <matteo.corti@id.ethz.ch>' build_requires: ExtUtils::MakeMaker: 6.42 + File::Spec: 0 + Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module -generated_by: 'Module::Install version 0.91' +generated_by: 'Module::Install version 1.01' license: gpl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -16,6 +18,7 @@ no_index: directory: - inc + - t requires: Array::Unique: 0 English: 0 @@ -27,6 +30,7 @@ Number::Format: 0 POSIX: 0 Readonly: 0 + perl: 5.8.0 resources: license: http://opensource.org/licenses/gpl-license.php -version: 3.2.3 +version: 3.2.4
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/Makefile.PL ^
@@ -4,9 +4,10 @@ ############################################################################## # Define metadata (we read it from the binary) -name 'check_diskio'; -all_from 'check_diskio.pod'; -version_from 'check_diskio'; +name 'check_diskio'; +version_from 'check_diskio'; +perl_version_from 'check_diskio'; +all_from 'check_diskio.pod'; ############################################################################## # Specific dependencies @@ -26,6 +27,10 @@ install_script 'check_diskio'; +tests 't/*.t'; +test_requires 'Test::More' => 0; +test_requires 'File::Spec' => 0; + WriteMakefile( INSTALLSCRIPT => '/usr/lib/nagios/plugins/contrib', INSTALLSITESCRIPT => '/usr/lib/nagios/plugins/contrib',
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/NEWS ^
@@ -1,3 +1,4 @@ +2011-11-09 3.2.4: supports 3.X kernels 2010-10-20 3.2.3: fixes a bug in the parsing of the statistics file 2010-07-06 3.2.2: fixes a bug which ignored devices specified with -d /dev 2010-06-30 3.2.1: exits with UNKNOWN if not able to read LVM stats @@ -26,7 +27,7 @@ 2007-02-23 1.1: removed the max interval check 2007-02-19 1.0: initial release -# $Id: NEWS 1196 2010-10-22 13:57:51Z corti $ -# $Revision: 1196 $ +# $Id: NEWS 1275 2011-11-09 15:24:34Z corti $ +# $Revision: 1275 $ # $HeadURL: https://svn.id.ethz.ch/nagios_plugins/check_diskio/NEWS $ -# $Date: 2010-10-22 15:57:51 +0200 (Fri, 22 Oct 2010) $ +# $Date: 2011-11-09 16:24:34 +0100 (Wed, 09 Nov 2011) $
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/check_diskio ^
@@ -1,5 +1,7 @@ #!perl +package main; + # check_diskio is a Nagios plugin to monitor the amount of disk # I/O in sectors on Linux 2.6 and 2.4 systems # @@ -15,15 +17,17 @@ # enable substitution with: # $ svn propset svn:keywords "Id Revision HeadURL Source Date" # -# $Id: check_diskio 1196 2010-10-22 13:57:51Z corti $ -# $Revision: 1196 $ +# $Id: check_diskio 1277 2011-11-09 17:25:43Z corti $ +# $Revision: 1277 $ # $HeadURL: https://svn.id.ethz.ch/nagios_plugins/check_diskio/check_diskio $ -# $Date: 2010-10-22 15:57:51 +0200 (Fri, 22 Oct 2010) $ +# $Date: 2011-11-09 18:25:43 +0100 (Wed, 09 Nov 2011) $ + +use 5.00800; use strict; use warnings; -our $VERSION = '3.2.3'; +our $VERSION = '3.2.4'; use Array::Unique; use English qw(-no_match_vars); @@ -41,6 +45,9 @@ Readonly my $BITS_PER_BYTE => 8; Readonly my $BYTES_PER_SECTOR => 512; +Readonly my $KILO => 1_000; +Readonly my $KIBI => 1_024; + # IMPORTANT: Nagios plugins could be executed using embedded perl in this case # the main routine would be executed as a subroutine and all the # declared subroutines would therefore be inner subroutines @@ -49,6 +56,7 @@ # # All variables are therefore declared as package variables... # +## no critic (ProhibitPackageVars) use vars qw( $factor $format @@ -61,6 +69,15 @@ %diskio_r @stat_file ); +## use critic (ProhibitPackageVars) + +# the script is declared as a package so that it can be unit tested +# but it should not be used as a module +if ( !caller ) { + run(); +} + +## no critic (InputOutput::RequireCheckedSyscalls) ############################################################################## # subroutines @@ -168,6 +185,7 @@ . $time . "\n", 1; + ## no critic (InputOutput::RequireBriefOpen) open $TMP_FH, q{>}, $tmp or $plugin->nagios_exit( UNKNOWN, "Cannot initialize timer ($tmp): $OS_ERROR" ); @@ -182,6 +200,7 @@ close $TMP_FH or $plugin->nagios_exit( UNKNOWN, "Cannot close timer: $OS_ERROR" ); + ## use critic (InputOutput::RequireBriefOpen) return; @@ -205,6 +224,7 @@ my $out; my $diff; + ## no critic (InputOutput::RequireBriefOpen) open $TMP_FH, q{<}, $tmp or $plugin->nagios_exit( UNKNOWN, "Cannot open timer ($tmp): $OS_ERROR" ); @@ -223,6 +243,7 @@ close $TMP_FH or $plugin->nagios_exit( UNKNOWN, "Cannot close timer: $OS_ERROR" ); + ## use critic (InputOutput::RequireBriefOpen) verbose 'reading data: read=' . format_number( $in, 0, 0, ) @@ -239,30 +260,23 @@ } ############################################################################## -# Usage : $version = kernel_version(); -# Purpose : detects the Linux kernel version -# Returns : kernel version (w/o minor number) +# Usage : $boolean = use_diskstats(); +# Purpose : detects the Linux kernel version and determines if we should +# use diskstats +# Returns : true if we should use diskstats # Arguments : n/a # Throws : n/a # Comments : n/a # See also : n/a -sub kernel_version { +sub use_diskstats { my ( $sysname, $nodename, $release, $version, $machine ) = uname; if ( $options->debug() ) { print "[DEBUG] kernel $release\n"; } - if ( $release =~ /^2.4/mxs ) { - return '2.4'; - } - if ( $release =~ /^2.6/mxs ) { - return '2.6'; - } - $plugin->nagios_exit( UNKNOWN, - "Error: unsupported kernel version ($release)" ); - return; + return ( $release =~ /^2.6/mxs ) \|\| ( $release =~ /^3/mxs ); } @@ -350,7 +364,7 @@ # In theory with 2.6 kernels we should get only 4 fields but # on some distributions we get 11 of them - if ( defined $f05 && $f05 =~ m/[0-9]/mxs ) { + if ( defined $f05 && $f05 =~ m/\d/mxs ) { # 11 fields if ( $options->debug() ) { @@ -429,7 +443,7 @@ verbose "Information found for '$name'\n", 1; } - if ( $name =~ /^ide.bus([0-9]).target([0-9]).lun([0-9])/mxs ) { + if ( $name =~ /^ide.bus(\d).target(\d).lun(\d)/mxs ) { # we try to get the corresponding device @@ -522,26 +536,33 @@ } ############################################################################## -# main -# +# Usage : run(); +# Purpose : main method +# Returns : n/a +# Arguments : n/a +# Throws : n/a +# Comments : n/a +# See also : n/a +## no critic (Subroutines::ProhibitExcessComplexity) +sub run { -################ -# initialization -$factor = 1; -$format = q{s}; -$plugin = Nagios::Plugin->new( shortname => 'CHECK_DISKIO' ); + ################ + # initialization + $factor = 1; + $format = q{s}; + $plugin = Nagios::Plugin->new( shortname => 'CHECK_DISKIO' ); -######################## -# Command line arguments + ######################## + # Command line arguments -my $usage = <<'EOT'; + my $usage = <<'EOT'; check_diskio --device=devicename --critical=critical --warning=warning [--help] [--reset] [--silent] [--ssize=size] [--verbose] [--version] [--uom=unit] [--factor=unit] [--strip-partition-number] EOT -my $extra = <<'EOT'; + my $extra = <<'EOT'; Units of measurement: @@ -566,256 +587,260 @@ EOT -$options = Nagios::Plugin::Getopt->new( - usage => $usage, - extra => $extra, - version => $VERSION, - url => 'https://trac.id.ethz.ch/projects/nagios_plugins', - blurb => 'Monitor disk I/O', -); - -$options->arg( - spec => 'device\|d=s@', - help => 'device name(s) (or mount point(s))', - required => 1, -); - -$options->arg( - spec => 'critical\|c=i', - help => 'critical number of sectors/s', - required => 1, -); - -$options->arg( - spec => 'warning\|w=i', - help => 'number of sectors/s which generates a warning', - required => 1, -); + $options = Nagios::Plugin::Getopt->new( + usage => $usage, + extra => $extra, + version => $VERSION, + url => 'https://trac.id.ethz.ch/projects/nagios_plugins', + blurb => 'Monitor disk I/O', + ); -$options->arg( - spec => 'reset\|r', - help => 'reset the counter(s)', - required => 0, -); + $options->arg( + spec => 'device\|d=s@', + help => 'device name(s) (or mount point(s))', + required => 1, + ); -$options->arg( - spec => 'silent\|s', - help => 'no warnings or critials are issued', - required => 0, -); + $options->arg( + spec => 'critical\|c=i', + help => 'critical number of sectors/s', + required => 1, + ); -$options->arg( - spec => 'ssize=i', - help => 'specify the sector size in bytes (default 512)', - required => 0, - default => $BYTES_PER_SECTOR, -); + $options->arg( + spec => 'warning\|w=i', + help => 'number of sectors/s which generates a warning', + required => 1, + ); -$options->arg( - spec => 'uom=s', - help => 'unit of measurement', - required => 0, -); + $options->arg( + spec => 'reset\|r', + help => 'reset the counter(s)', + required => 0, + ); -$options->arg( - spec => 'factor=s', - help => 'unit of threshold', - required => 0, -); + $options->arg( + spec => 'silent\|s', + help => 'no warnings or critials are issued', + required => 0, + ); -$options->arg( - spec => 'debug', - help => 'debugging output', - required => 0, -); + $options->arg( + spec => 'ssize=i', + help => 'specify the sector size in bytes (default 512)', + required => 0, + default => $BYTES_PER_SECTOR, + ); -$options->arg( - spec => 'testfile=s', - help => 'tests the plugin with the given disk statistics file (debugging)', - required => 0, -); - + $options->arg( + spec => 'uom=s', + help => 'unit of measurement', + required => 0, + ); -$options->arg( - spec => 'strip-partition-number', - help => - 'strips p[0-9]+ from the device number (needed for HP Smart Array cards)', - required => 0, -); + $options->arg( + spec => 'factor=s', + help => 'unit of threshold', + required => 0, + ); -$options->getopts(); + $options->arg( + spec => 'debug', + help => 'debugging output', + required => 0, + ); -################################################################################ -# Sanity checks + $options->arg( + spec => 'testfile=s', + help => + 'tests the plugin with the given disk statistics file (debugging)', + required => 0, + ); -################ -# kernel version + $options->arg( + spec => 'strip-partition-number', + help => +'strips p[0-9]+ from the device number (needed for HP Smart Array cards)', + required => 0, + ); -my $kversion = kernel_version(); + $options->getopts(); -my $proc_diskstats_available = ( -r '/proc/diskstats' ); + ################################################################################ + # Sanity checks -######################### -# Disk stats (read files) + ################ + # kernel version -if ( $kversion eq '2.6' ) { - if ( !-r '/proc/diskstats' && !-r '/proc/partitions' ) { - $plugin->nagios_exit( UNKNOWN, - '/proc/diskstats or /proc/partitions not readable' ); - } -} -else { - if ( !-r '/proc/partitions' ) { - $plugin->nagios_exit( UNKNOWN, '/proc/partitions not readable' ); - } -} + my $proc_diskstats_available = ( -r '/proc/diskstats' ); -if (! $options->testfile() ) { + ######################### + # Disk stats (read files) - if ( -r '/proc/diskstats' ) { - @stat_file = File::Slurp::read_file('/proc/diskstats'); + if ( use_diskstats() ) { + if ( !-r '/proc/diskstats' && !-r '/proc/partitions' ) { + $plugin->nagios_exit( UNKNOWN, + '/proc/diskstats or /proc/partitions not readable' ); + } } else { - @stat_file = File::Slurp::read_file('/proc/partitions'); - } - -} else { - - if ( ! -r $options->testfile() ) { - $plugin->nagios_exit( - UNKNOWN, - $options->testfile() . ' not readable' - ); + if ( !-r '/proc/partitions' ) { + $plugin->nagios_exit( UNKNOWN, '/proc/partitions not readable' ); + } } - - verbose 'Reading ' . $options->testfile() . "\n"; - - @stat_file = File::Slurp::read_file($options->testfile()); -} - + if ( !$options->testfile() ) { -if ( $options->debug() ) { - for my $line (@stat_file) { - chomp $line; - my $filename; if ( -r '/proc/diskstats' ) { - $filename = '/proc/diskstats'; + @stat_file = File::Slurp::read_file('/proc/diskstats'); } else { - $filename = '/proc/partitions'; + @stat_file = File::Slurp::read_file('/proc/partitions'); } - print "[DEBUG] $filename \|$line\|\n"; + } -} + else { -######### -# Devices + if ( !-r $options->testfile() ) { + $plugin->nagios_exit( UNKNOWN, + $options->testfile() . ' not readable' ); + } -my @devices; -tie @devices, 'Array::Unique'; + verbose 'Reading ' . $options->testfile() . "\n"; -for my $device ( @{ $options->device() } ) { + @stat_file = File::Slurp::read_file( $options->testfile() ); - # Detect device from mount point - if ( !( $device =~ /^\/dev\//mxs ) ) { + } - if ( $options->debug() ) { - print "[DEBUG] $device is a mount point\n"; + if ( $options->debug() ) { + for my $line (@stat_file) { + chomp $line; + my $filename; + if ( -r '/proc/diskstats' ) { + $filename = '/proc/diskstats'; + } + else { + $filename = '/proc/partitions'; + } + print "[DEBUG] $filename \|$line\|\n"; } + } - if ( $device ne q{/} && $device =~ /\/$/mxs ) { + ######### + # Devices - # remove trailing / - $device =~ s/\/$//mxs; - } + my @unique_devices; + ## no critic (Miscellanea::ProhibitTies) + tie @unique_devices, 'Array::Unique'; + ## use critic (Miscellanea::ProhibitTies) - my $MTAB_FH; - my $mount_point = $device; + for my $device ( @{ $options->device() } ) { - undef $device; + # Detect device from mount point + if ( !( $device =~ /^\/dev\//mxs ) ) { - open $MTAB_FH, q{<}, '/etc/mtab' - or - $plugin->nagios_exit( UNKNOWN, "Cannot open /etc/mtab: $OS_ERROR" ); - while (<$MTAB_FH>) { - my $line = $_; - chomp $line; if ( $options->debug() ) { - print "[DEBUG] /etc/mtab \|$line\|\n"; + print "[DEBUG] $device is a mount point\n"; } - if ( $line =~ /(\/dev.)\ +$mount_point\ +./mxs ) { - $device = $1; - if ( $options->debug() ) { - print "[DEBUG] device found: $device\n"; - } - last; + + if ( $device ne q{/} && $device =~ /\/$/mxs ) { + + # remove trailing / + $device =~ s/\/$//mxs; } - } - close $MTAB_FH - or $plugin->nagios_exit( UNKNOWN, - "Error while closing /etc/mtab: $OS_ERROR" ); - if ( !$device ) { - $plugin->nagios_exit( UNKNOWN, - "Could not find a device for $mount_point" ); - } + my $MTAB_FH; + my $mount_point = $device; - # device found: strip the partition number - if ( $options->get('strip-partition-number') ) { - $device =~ s/p?[0-9]+$//mxs; - } + undef $device; - verbose "Mount point $mount_point corresponds to device $device\n"; + ## no critic (InputOutput::RequireBriefOpen) + open $MTAB_FH, q{<}, '/etc/mtab' + or $plugin->nagios_exit( UNKNOWN, + "Cannot open /etc/mtab: $OS_ERROR" ); + while (<$MTAB_FH>) { + my $line = $_; + chomp $line; + if ( $options->debug() ) { + print "[DEBUG] /etc/mtab \|$line\|\n"; + } + if ( $line =~ /(\/dev.)[ ]+$mount_point[ ]+./mxs ) { + $device = $1; + if ( $options->debug() ) { + print "[DEBUG] device found: $device\n"; + } + last; + } + } + close $MTAB_FH + or $plugin->nagios_exit( UNKNOWN, + "Error while closing /etc/mtab: $OS_ERROR" ); + ## use critic (InputOutput::RequireBriefOpen) - my $dev_name = $device; - $dev_name =~ s/^\/dev\///mxs; + if ( !$device ) { + $plugin->nagios_exit( UNKNOWN, + "Could not find a device for $mount_point" ); + } - if ( $options->debug ) { - print "[DEBUG] device name: $dev_name\n"; - } + # device found: strip the partition number + if ( $options->get('strip-partition-number') ) { + $device =~ s/p?\d+$//mxs; + } - if ( !any { /\s$dev_name\s/msx } @stat_file ) { + verbose "Mount point $mount_point corresponds to device $device\n"; - # LVM? - if ( whoami() eq 'root' ) { + my $dev_name = $device; + $dev_name =~ s/^\/dev\///mxs; - my @output; + if ( $options->debug ) { + print "[DEBUG] device name: $dev_name\n"; + } - @output = exec_command("lvdisplay $device 2>&1 "); + ## no critic (ControlStructures::ProhibitDeepNests) + if ( !any { /\s$dev_name\s/msx } @stat_file ) { - if ( any { /not\ found/mxs } @output ) { - verbose "LVM volume not found\n"; - } - else { + # LVM? + if ( whoami() eq 'root' ) { - my @volume_groups = grep { /VG\ Name/mxs } @output; - if ( @volume_groups == 1 ) { + my @output; - $volume_groups[0] =~ s{.\ }{}mxs; + @output = exec_command("lvdisplay $device 2>&1 "); - @output = - exec_command("vgdisplay -v $volume_groups[0] 2>&1 "); + if ( any { /not[ ]found/mxs } @output ) { + verbose "LVM volume not found\n"; + } + else { - if ( any { /not\ found/mxs } @output ) { - verbose "Cannot get info on $volume_groups[0]\n"; - } - else { + my @volume_groups = grep { /VG[ ]Name/mxs } @output; + if ( @volume_groups == 1 ) { - my @pvs = grep { /PV\ Name/mxs } @output; + $volume_groups[0] =~ s{.[ ]}{}mxs; - if ( @pvs < 1 ) { - verbose "No physical volumes found\n"; + @output = exec_command( + "vgdisplay -v $volume_groups[0] 2>&1 "); + + if ( any { /not[ ]found/mxs } @output ) { + verbose + "Cannot get info on $volume_groups[0]\n"; } else { - # strip everything but the device name fro - # the output - for (@pvs) { - s{.\s+/dev/([a-z]+).}{/dev/$1}mxs; + my @pvs = grep { /PV[ ]Name/mxs } @output; + + if ( @pvs < 1 ) { + verbose "No physical volumes found\n"; } + else { + + # strip everything but the device name fro + # the output + for (@pvs) { +s{.\s+/dev/([[:lower:]]+).}{/dev/$1}mxs; + } - push @devices, @pvs; + push @unique_devices, @pvs; + + } } @@ -824,275 +849,285 @@ } } + else { - } - else { + $plugin->nagios_exit( UNKNOWN, + "Cannot check LVM volume $device if not root" ); - $plugin->nagios_exit( UNKNOWN, - "Cannot check LVM volume $device if not root" ); + } } + ## use critic (ControlStructures::ProhibitDeepNests) } + else { - } - else { + push @unique_devices, $device; - push @devices, $device; + } } -} - -if ( $options->debug() ) { - print "[DEBUG] devices: @devices\n"; -} + if ( $options->debug() ) { + #<<< + print "[DEBUG] devices: @unique_devices\n"; ## no critic (RequireCheckedSyscalls) + #>>> + } -# check if the devices exist + # check if the devices exist -for my $device (@devices) { - if ( !-e $device && ! $options->testfile() ) { - $plugin->nagios_exit( UNKNOWN, "Device $device not found" ); + for my $device (@unique_devices) { + if ( !-e $device && !$options->testfile() ) { + $plugin->nagios_exit( UNKNOWN, "Device $device not found" ); + } } -} -verbose "Checking: @devices\n"; + verbose "Checking: @unique_devices\n"; ##### -# UOM + # UOM -my $multiplier; -my $UOM; + my $multiplier; + my $UOM; -if ( $options->uom() ) { - $format = $options->uom(); -} + if ( $options->uom() ) { + $format = $options->uom(); + } -# according to the guidelines only [TGMK]B (Bytes) are valid UOM -# http://nagiosplug.sourceforge.net/developer-guidelines.html#AEN201 -my $perfdata_UOM = 'B'; -if ( $format eq 's' \|\| $format =~ /^sector[s]$/mxs ) { - - #sectors - $multiplier = 1; - $UOM = 'sectors'; - $perfdata_UOM = q{}; + # according to the guidelines only [TGMK]B (Bytes) are valid UOM + # http://nagiosplug.sourceforge.net/developer-guidelines.html#AEN201 + my $perfdata_uom = 'B'; + if ( $format eq 's' \|\| $format =~ /^sector[s]$/mxs ) { -} -elsif ( $format eq 'b' \|\| $format =~ /^bit[s]$/mxs ) { + #sectors + $multiplier = 1; + $UOM = 'sectors'; + $perfdata_uom = q{}; - # bits - $multiplier = $options->ssize() * $BITS_PER_BYTE; - $UOM = 'b'; - $perfdata_UOM = q{}; + } + elsif ( $format eq 'b' \|\| $format =~ /^bit[s]$/mxs ) { -} -elsif ( $format eq 'B' \|\| $format =~ /^byte[s]$/mxs ) { + # bits + $multiplier = $options->ssize() * $BITS_PER_BYTE; + $UOM = 'b'; + $perfdata_uom = q{}; - # bytes - $multiplier = $options->ssize(); - $UOM = 'B'; + } + elsif ( $format eq 'B' \|\| $format =~ /^byte[s]$/mxs ) { -} -else { - $plugin->nagios_exit( UNKNOWN, "Uknown unit of measurement: $format" ); -} + # bytes + $multiplier = $options->ssize(); + $UOM = 'B'; -my $unit = 1024; -if ( $options->factor() ) { - $format = $options->factor(); - - if ( $format =~ m/^ki$/imxs \|\| $format =~ m/^Kibi$/imxs ) { - $factor = 1024; - } - elsif ( $format =~ m/^mi$/imxs \|\| $format =~ m/^mebi$/imxs ) { - $factor = 1024 * 1024; - } - elsif ( $format =~ m/^gi$/imxs \|\| $format =~ m/^gibi$/imxs ) { - $factor = 1024 * 1024 * 1024; - } - elsif ( $format =~ m/^k$/imxs \|\| $format =~ m/^Kilo$/imxs ) { - $factor = 1000; - $unit = 1000; - } - elsif ( $format =~ m/^m$/imxs \|\| $format =~ m/^mega$/imxs ) { - $factor = 1000 * 1000; - $unit = 1000; - } - elsif ( $format =~ m/^g$/imxs \|\| $format =~ m/^giga$/imxs ) { - $factor = 1000 * 1000 * 1000; - $unit = 1000; } else { - $plugin->nagios_exit( UNKNOWN, "Uknown unit of threshold: $format" ); + $plugin->nagios_exit( UNKNOWN, "Uknown unit of measurement: $format" ); } -} -################ -# Initialization + my $unit = $KIBI; + ## no critic (ControlStructures::ProhibitCascadingIfElse) + if ( $options->factor() ) { + $format = $options->factor(); -$threshold = Nagios::Plugin::Threshold->set_thresholds( - warning => $options->warning() * $factor, - critical => $options->critical() * $factor, -); + if ( $format =~ m/^ki$/imxs \|\| $format =~ m/^Kibi$/imxs ) { + $factor = $KIBI; + } + elsif ( $format =~ m/^mi$/imxs \|\| $format =~ m/^mebi$/imxs ) { + $factor = $KIBI * $KIBI; + } + elsif ( $format =~ m/^gi$/imxs \|\| $format =~ m/^gibi$/imxs ) { + $factor = $KIBI * $KIBI * $KIBI; + } + elsif ( $format =~ m/^k$/imxs \|\| $format =~ m/^Kilo$/imxs ) { + $factor = $KILO; + $unit = $KILO; + } + elsif ( $format =~ m/^m$/imxs \|\| $format =~ m/^mega$/imxs ) { + $factor = $KILO * $KILO; + $unit = $KILO; + } + elsif ( $format =~ m/^g$/imxs \|\| $format =~ m/^giga$/imxs ) { + $factor = $KILO * $KILO * $KILO; + $unit = $KILO; + } + else { + $plugin->nagios_exit( UNKNOWN, + "Uknown unit of threshold: $format" ); + } + } + ## use critic (ControlStructures::ProhibitCascadingIfElse) -my $tmp_file_prefix = '/tmp/check_diskio_status-' . whoami(); + ################ + # Initialization -# strip /dev/ -for (@devices) { - s/^\/dev\///mxs; -} + $threshold = Nagios::Plugin::Threshold->set_thresholds( + warning => $options->warning() * $factor, + critical => $options->critical() * $factor, + ); -for my $device (@devices) { + my $tmp_file_prefix = '/tmp/check_diskio_status-' . whoami(); - # we need one temporary file per device - my ( $controller, $disk ) = split /\//mxs, $device; - if ( !$disk ) { - $tmp_files{$device} = "$tmp_file_prefix-$controller"; - } - else { - $tmp_files{$device} = "$tmp_file_prefix--$disk"; + # strip /dev/ + for (@unique_devices) { + s/^\/dev\///mxs; } -} + for my $device (@unique_devices) { -######################## -# Check the proc entry + # we need one temporary file per device + my ( $controller, $disk ) = split /\//mxs, $device; + if ( !$disk ) { + $tmp_files{$device} = "$tmp_file_prefix-$controller"; + } + else { + $tmp_files{$device} = "$tmp_file_prefix--$disk"; + } -my $diff; -my $found = 0; -my $in; -my $out; -my $time; + } -my $s_read; -my $s_write; +######################## + # Check the proc entry -my $TMP_FH; -my $status = OK; -my @status_lines; + my $diff; + my $found = 0; + my $in; + my $out; + my $time; -for my $device (@devices) { + my $s_read; + my $s_write; - if ( $kversion eq '2.6' && $proc_diskstats_available ) { - ( $s_read, $s_write ) = read_26($device); - } - else { - ( $s_read, $s_write ) = read_24($device); - } + my $TMP_FH; + my $status = OK; + my @status_lines; - verbose 'current data: read=' - . format_number( $s_read, 0, 0 ) - . ' write=' - . format_number( $s_write, 0, 0 ) - . "\n", 1; + for my $device (@unique_devices) { - if ( !-f $tmp_files{$device} ) { - verbose "temporary file not available resetting and waiting\n"; - write_timer( $tmp_files{$device}, $s_write, $s_read ); - sleep 1; - if ( $kversion eq '2.6' && $proc_diskstats_available ) { + if ( use_diskstats() && $proc_diskstats_available ) { ( $s_read, $s_write ) = read_26($device); } else { ( $s_read, $s_write ) = read_24($device); } - } - ( $diff, $in, $out ) = read_timer( $tmp_files{$device} ); + verbose 'current data: read=' + . format_number( $s_read, 0, 0 ) + . ' write=' + . format_number( $s_write, 0, 0 ) + . "\n", 1; + + if ( !-f $tmp_files{$device} ) { + verbose "temporary file not available resetting and waiting\n"; + write_timer( $tmp_files{$device}, $s_write, $s_read ); + sleep 1; + if ( use_diskstats() && $proc_diskstats_available ) { + ( $s_read, $s_write ) = read_26($device); + } + else { + ( $s_read, $s_write ) = read_24($device); + } + } + + ( $diff, $in, $out ) = read_timer( $tmp_files{$device} ); - if ( $diff < 1 ) { + if ( $diff < 1 ) { - # wait a little bit - sleep 1; - ( $diff, $in, $out ) = read_timer(); + # wait a little bit + sleep 1; + ( $diff, $in, $out ) = read_timer(); - } + } - write_timer( $tmp_files{$device}, $s_write, $s_read ); + write_timer( $tmp_files{$device}, $s_write, $s_read ); - verbose 'time difference: ' . $diff . "s\n", 1; + verbose 'time difference: ' . $diff . "s\n", 1; - if ( $diff == 0 ) { + if ( $diff == 0 ) { - # round up - $diff = 1; + # round up + $diff = 1; - } + } - # check for overflows (2^32 sectors) - if ( $s_write < $in ) { + # check for overflows (2^32 sectors) + if ( $s_write < $in ) { - # overflow - $diskio_w{$device} = $OVERFLOW - $in + $s_write; + # overflow + $diskio_w{$device} = $OVERFLOW - $in + $s_write; - } - else { - $diskio_w{$device} = $s_write - $in; - } + } + else { + $diskio_w{$device} = $s_write - $in; + } - if ( $s_read < $out ) { + if ( $s_read < $out ) { - # overflow - $diskio_r{$device} = $OVERFLOW - $out + $s_read; - } - else { - $diskio_r{$device} = $s_read - $out; - } + # overflow + $diskio_r{$device} = $OVERFLOW - $out + $s_read; + } + else { + $diskio_r{$device} = $s_read - $out; + } - $diskio_w{$device} = int( $diskio_w{$device} * $multiplier / $diff ); - $diskio_r{$device} = int( $diskio_r{$device} * $multiplier / $diff ); - $diskio{$device} = $diskio_w{$device} + $diskio_r{$device}; + $diskio_w{$device} = int( $diskio_w{$device} * $multiplier / $diff ); + $diskio_r{$device} = int( $diskio_r{$device} * $multiplier / $diff ); + $diskio{$device} = $diskio_w{$device} + $diskio_r{$device}; + + my $suffix = q{}; + + # we append the device name to the labels only if there is more + # than one device to maintain backwards compatibility + if ( @unique_devices > 1 ) { + $suffix = "_\U$device"; + } - my $suffix = q{}; + # use unscaled values for performance data - will be scaled by rrdtool - # we append the device name to the labels only if there is more - # than one device to maintain backwards compatibility - if ( @devices > 1 ) { - $suffix = "_\U$device"; - } + $plugin->add_perfdata( + label => "WRITE$suffix", + value => sprintf( '%.0f', $diskio_w{$device} ), + uom => $perfdata_uom, + threshold => $threshold, + ); - # use unscaled values for performance data - will be scaled by rrdtool + $plugin->add_perfdata( + label => "READ$suffix", + value => sprintf( '%.0f', $diskio_r{$device} ), + uom => $perfdata_uom, + threshold => $threshold, + ); - $plugin->add_perfdata( - label => "WRITE$suffix", - value => sprintf( '%.0f', $diskio_w{$device} ), - uom => $perfdata_UOM, - threshold => $threshold, - ); + $plugin->add_perfdata( + label => "TOTAL$suffix", + value => sprintf( '%.0f', $diskio{$device} ), + uom => $perfdata_uom, + threshold => $threshold, + ); - $plugin->add_perfdata( - label => "READ$suffix", - value => sprintf( '%.0f', $diskio_r{$device} ), - uom => $perfdata_UOM, - threshold => $threshold, - ); + my $device_status = $threshold->get_status( $diskio{$device} ); + if ( $device_status == CRITICAL ) { + $status = CRITICAL; + } + elsif ( $device_status == WARNING && $status != CRITICAL ) { + $status = WARNING; + } - $plugin->add_perfdata( - label => "TOTAL$suffix", - value => sprintf( '%.0f', $diskio{$device} ), - uom => $perfdata_UOM, - threshold => $threshold, - ); + my ( $val, $prefix ) = shortenrate( $diskio{$device}, $unit ); + push @status_lines, + "$device " . sprintf( '%.2f', $val ) . " $prefix$UOM/s"; - my $device_status = $threshold->get_status( $diskio{$device} ); - if ( $device_status == CRITICAL ) { - $status = CRITICAL; - } - elsif ( $device_status == WARNING && $status != CRITICAL ) { - $status = WARNING; } - my ( $val, $prefix ) = shortenrate( $diskio{$device}, $unit ); - push @status_lines, "$device " . sprintf( '%.2f', $val ) . " $prefix$UOM/s"; + if ( $options->silent() ) { + $plugin->nagios_exit( OK, ( join ', ', @unique_devices ) . 'OK' ); + } + else { + $plugin->nagios_exit( $status, join ', ', @status_lines, ); + } -} + return; -if ( $options->silent() ) { - $plugin->nagios_exit( OK, ( join ', ', @devices ) . 'OK' ); -} -else { - $plugin->nagios_exit( $status, join ', ', @status_lines, ); } +## use critic (Subroutines::ProhibitExcessComplexity) 1;
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/check_diskio.pod ^
@@ -4,17 +4,17 @@ =head1 NAME C<check_diskio> - a Nagios plugin to monitor the amount of disk I/O in sectors -on Linux 2.6 and 2.4 systems +on Linux =head1 DESCRIPTION check_diskio is a Nagios plugin to monitor the amount of disk I/O in sectors -on Linux 2.6 and 2.4 systems +on Linux =head1 VERSION -Version 3.2.3 +Version 3.2.4 =head1 SYNOPSIS
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/check_diskio.spec ^
@@ -1,32 +1,44 @@ ################################################################################ # File version information: -# $Id: check_diskio.spec 1196 2010-10-22 13:57:51Z corti $ -# $Revision: 1196 $ +# $Id: check_diskio.spec 1278 2011-11-09 18:44:34Z corti $ +# $Revision: 1278 $ # $HeadURL: https://svn.id.ethz.ch/nagios_plugins/check_diskio/check_diskio.spec $ -# $Date: 2010-10-22 15:57:51 +0200 (Fri, 22 Oct 2010) $ +# $Date: 2011-11-09 19:44:34 +0100 (Wed, 09 Nov 2011) $ ################################################################################ -%define version 3.2.3 -%define release 0 -%define name check_diskio +%define version 3.2.4 +%define release 0 +%define sourcename check_diskio +%define packagename nagios-plugins-check-diskio %define nagiospluginsdir %{_libdir}/nagios/plugins # No binaries in this package %define debug_package %{nil} Summary: Nagios plugin to monitor the amount of disk I/O -Name: %{name} +Name: %{packagename} Version: %{version} +Obsoletes: check_diskio Release: %{release}%{?dist} License: GPLv3+ Packager: Matteo Corti <matteo.corti@id.ethz.ch> Group: Applications/System -BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) -URL: https://trac.id.ethz.ch/projects/nagios_plugins/wiki/%{name} -Source: https://trac.id.ethz.ch/projects/nagios_plugins/downloads/%{name}-%{version}.tar.gz +BuildRoot: %{_tmppath}/%{packagename}-%{version}-%{release}-root-%(%{__id_u} -n) +URL: https://trac.id.ethz.ch/projects/nagios_plugins/wiki/check_diskio +Source: https://trac.id.ethz.ch/projects/nagios_plugins/downloads/%{sourcename}-%{version}.tar.gz # Fedora build requirement (not needed for EPEL{4,5}) BuildRequires: perl(ExtUtils::MakeMaker) +BuildRequires: perl(Test::More) +BuildRequires: perl(Number::Format) +BuildRequires: perl(Nagios::Plugin) +BuildRequires: perl(Readonly) +BuildRequires: perl(File::Spec) +BuildRequires: perl(List::MoreUtils) +BuildRequires: perl(File::Slurp) +BuildRequires: perl(English) +BuildRequires: perl(Carp) +BuildRequires: perl(Array::Unique) Requires: nagios-plugins @@ -34,7 +46,7 @@ Nagios plugin to monitor the amount of disk I/O %prep -%setup -q +%setup -q -n %{sourcename}-%{version} %build %{__perl} Makefile.PL INSTALLDIRS=vendor \ @@ -50,16 +62,22 @@ find %{buildroot} -depth -type d -exec rmdir {} 2>/dev/null \; %{_fixperms} %{buildroot}/* +%check +make test + %clean rm -rf %{buildroot} %files %defattr(-, root, root, -) %doc AUTHORS Changes NEWS README INSTALL TODO COPYING COPYRIGHT -%{nagiospluginsdir}/%{name} -%{_mandir}/man1/%{name}.1* +%{nagiospluginsdir}/%{sourcename} +%{_mandir}/man1/%{sourcename}.1* %changelog +* Wed Nov 9 2011 Matteo Corti <matteo.corti@id.ethz.ch> - 3.2.4-0 +- 3.X kernel support + * Fri Oct 22 2010 Matteo Corti <matteo.corti@id.ethz.ch> - 3.2.3-0 - Fixed a bug in the statistics parsing
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/inc/Module/Install.pm ^
@@ -19,6 +19,10 @@ use 5.005; use strict 'vars'; +use Cwd (); +use File::Find (); +use File::Path (); +use FindBin; use vars qw{$VERSION $MAIN}; BEGIN { @@ -28,7 +32,7 @@ # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. - $VERSION = '0.91'; + $VERSION = '0.95'; # Storage for the pseudo-singleton $MAIN = undef; @@ -38,18 +42,25 @@ } +sub import { + my $class = shift; + my $self = $class->new(@_); + my $who = $self->_caller; - - - -# Whether or not inc::Module::Install is actually loaded, the -# $INC{inc/Module/Install.pm} is what will still get set as long as -# the caller loaded module this in the documented manner. -# If not set, the caller may NOT have loaded the bundled version, and thus -# they may not have a MI version that works with the Makefile.PL. This would -# result in false errors or unexpected behaviour. And we don't want that. -my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; -unless ( $INC{$file} ) { die <<"END_DIE" } + #------------------------------------------------------------- + # all of the following checks should be included in import(), + # to allow "eval 'require Module::Install; 1' to test + # installation of Module::Install. (RT #51267) + #------------------------------------------------------------- + + # Whether or not inc::Module::Install is actually loaded, the + # $INC{inc/Module/Install.pm} is what will still get set as long as + # the caller loaded module this in the documented manner. + # If not set, the caller may NOT have loaded the bundled version, and thus + # they may not have a MI version that works with the Makefile.PL. This would + # result in false errors or unexpected behaviour. And we don't want that. + my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; + unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: @@ -61,26 +72,28 @@ END_DIE - - - - -# If the script that is loading Module::Install is from the future, -# then make will detect this and cause it to re-run over and over -# again. This is bad. Rather than taking action to touch it (which -# is unreliable on some platforms and requires write permissions) -# for now we should catch this and refuse to run. -if ( -f $0 ) { - my $s = (stat($0))[9]; - - # If the modification time is only slightly in the future, - # sleep briefly to remove the problem. - my $a = $s - time; - if ( $a > 0 and $a < 5 ) { sleep 5 } - - # Too far in the future, throw an error. - my $t = time; - if ( $s > $t ) { die <<"END_DIE" } + # This reportedly fixes a rare Win32 UTC file time issue, but + # as this is a non-cross-platform XS module not in the core, + # we shouldn't really depend on it. See RT #24194 for detail. + # (Also, this module only supports Perl 5.6 and above). + eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; + + # If the script that is loading Module::Install is from the future, + # then make will detect this and cause it to re-run over and over + # again. This is bad. Rather than taking action to touch it (which + # is unreliable on some platforms and requires write permissions) + # for now we should catch this and refuse to run. + if ( -f $0 ) { + my $s = (stat($0))[9]; + + # If the modification time is only slightly in the future, + # sleep briefly to remove the problem. + my $a = $s - time; + if ( $a > 0 and $a < 5 ) { sleep 5 } + + # Too far in the future, throw an error. + my $t = time; + if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). @@ -89,15 +102,12 @@ Please correct this, then run $0 again. END_DIE -} - - - + } -# Build.PL was formerly supported, but no longer is due to excessive -# difficulty in implementing every single feature twice. -if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } + # Build.PL was formerly supported, but no longer is due to excessive + # difficulty in implementing every single feature twice. + if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. @@ -107,23 +117,36 @@ END_DIE + #------------------------------------------------------------- + # To save some more typing in Module::Install installers, every... + # use inc::Module::Install + # ...also acts as an implicit use strict. + $^H \|= strict::bits(qw(refs subs vars)); + #------------------------------------------------------------- + unless ( -f $self->{file} ) { + require "$self->{path}/$self->{dispatch}.pm"; + File::Path::mkpath("$self->{prefix}/$self->{author}"); + $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); + $self->{admin}->init; + @_ = ($class, _self => $self); + goto &{"$self->{name}::import"}; + } -# To save some more typing in Module::Install installers, every... -# use inc::Module::Install -# ...also acts as an implicit use strict. -$^H \|= strict::bits(qw(refs subs vars)); - - + {"${who}::AUTOLOAD"} = $self->autoload; + $self->preload; + # Unregister loader and worker packages so subdirs can use them again + delete $INC{"$self->{file}"}; + delete $INC{"$self->{path}.pm"}; + # Save to the singleton + $MAIN = $self; -use Cwd (); -use File::Find (); -use File::Path (); -use FindBin; + return 1; +} sub autoload { my $self = shift; @@ -152,33 +175,6 @@ }; } -sub import { - my $class = shift; - my $self = $class->new(@_); - my $who = $self->_caller; - - unless ( -f $self->{file} ) { - require "$self->{path}/$self->{dispatch}.pm"; - File::Path::mkpath("$self->{prefix}/$self->{author}"); - $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); - $self->{admin}->init; - @_ = ($class, _self => $self); - goto &{"$self->{name}::import"}; - } - - {"${who}::AUTOLOAD"} = $self->autoload; - $self->preload; - - # Unregister loader and worker packages so subdirs can use them again - delete $INC{"$self->{file}"}; - delete $INC{"$self->{path}.pm"}; - - # Save to the singleton - $MAIN = $self; - - return 1; -} - sub preload { my $self = shift; unless ( $self->{extensions} ) { @@ -348,17 +344,24 @@ return $call; } +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local FH; - if ( $] >= 5.006 ) { - open( FH, '<', $_[0] ) or die "open($_[0]): $!"; - } else { - open( FH, "< $_[0]" ) or die "open($_[0]): $!"; - } + open( FH, '<', $_[0] ) or die "open($_[0]): $!"; + my $string = do { local $/; <FH> }; + close FH or die "close($_[0]): $!"; + return $string; +} +END_NEW +sub _read { + local FH; + open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; <FH> }; close FH or die "close($_[0]): $!"; return $string; } +END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); @@ -379,18 +382,26 @@ return $string; } +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local FH; - if ( $] >= 5.006 ) { - open( FH, '>', $_[0] ) or die "open($_[0]): $!"; - } else { - open( FH, "> $_[0]" ) or die "open($_[0]): $!"; + open( FH, '>', $_[0] ) or die "open($_[0]): $!"; + foreach ( 1 .. $#_ ) { + print FH $_[$_] or die "print($_[0]): $!"; } + close FH or die "close($_[0]): $!"; +} +END_NEW +sub _write { + local FH; + open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } +END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). @@ -427,4 +438,4 @@ 1; -# Copyright 2008 - 2009 Adam Kennedy. +# Copyright 2008 - 2010 Adam Kennedy.
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/inc/Module/Install/Base.pm ^
@@ -4,7 +4,7 @@ use strict 'vars'; use vars qw{$VERSION}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; } # Suspend handler for "redefined" warnings
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/inc/Module/Install/Include.pm ^
@@ -6,7 +6,7 @@ use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; }
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/inc/Module/Install/MakeMaker.pm ^
@@ -7,12 +7,12 @@ use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } -my $makefile; +my $makefile = undef; sub WriteMakefile { my ($self, %args) = @_; @@ -36,6 +36,12 @@ } } + if (my $prereq = delete($args{BUILD_REQUIRES})) { + while (my($k,$v) = each %$prereq) { + $self->build_requires($k,$v); + } + } + # put the remaining args to makemaker_args $self->makemaker_args(%args); }
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/inc/Module/Install/Makefile.pm ^
@@ -7,7 +7,7 @@ use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -25,8 +25,8 @@ die "Caught an potential prompt infinite loop ($c[1]\|$c[2]\|$_[0])"; } - # In automated testing, always use defaults - if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { + # In automated testing or non-interactive session, always use defaults + if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { @@ -34,21 +34,110 @@ } } +# Store a cleaned up version of the MakeMaker version, +# since we need to behave differently in a variety of +# ways based on the MM version. +my $makemaker = eval $ExtUtils::MakeMaker::VERSION; + +# If we are passed a param, do a "newer than" comparison. +# Otherwise, just return the MakeMaker version. +sub makemaker { + ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 +} + +# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified +# as we only need to know here whether the attribute is an array +# or a hash or something else (which may or may not be appendable). +my %makemaker_argtype = ( + C => 'ARRAY', + CONFIG => 'ARRAY', +# CONFIGURE => 'CODE', # ignore + DIR => 'ARRAY', + DL_FUNCS => 'HASH', + DL_VARS => 'ARRAY', + EXCLUDE_EXT => 'ARRAY', + EXE_FILES => 'ARRAY', + FUNCLIST => 'ARRAY', + H => 'ARRAY', + IMPORTS => 'HASH', + INCLUDE_EXT => 'ARRAY', + LIBS => 'ARRAY', # ignore '' + MAN1PODS => 'HASH', + MAN3PODS => 'HASH', + META_ADD => 'HASH', + META_MERGE => 'HASH', + PL_FILES => 'HASH', + PM => 'HASH', + PMLIBDIRS => 'ARRAY', + PMLIBPARENTDIRS => 'ARRAY', + PREREQ_PM => 'HASH', + CONFIGURE_REQUIRES => 'HASH', + SKIP => 'ARRAY', + TYPEMAPS => 'ARRAY', + XS => 'HASH', +# VERSION => ['version',''], # ignore +# _KEEP_AFTER_FLUSH => '', + + clean => 'HASH', + depend => 'HASH', + dist => 'HASH', + dynamic_lib=> 'HASH', + linkext => 'HASH', + macro => 'HASH', + postamble => 'HASH', + realclean => 'HASH', + test => 'HASH', + tool_autosplit => 'HASH', + + # special cases where you can use makemaker_append + CCFLAGS => 'APPENDABLE', + DEFINE => 'APPENDABLE', + INC => 'APPENDABLE', + LDDLFLAGS => 'APPENDABLE', + LDFROM => 'APPENDABLE', +); + sub makemaker_args { - my $self = shift; + my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} \|\|= {} ); - %$args = ( %$args, @_ ); + foreach my $key (keys %new_args) { + if ($makemaker_argtype{$key} eq 'ARRAY') { + $args->{$key} = [] unless defined $args->{$key}; + unless (ref $args->{$key} eq 'ARRAY') { + $args->{$key} = [$args->{$key}] + } + push @{$args->{$key}}, + ref $new_args{$key} eq 'ARRAY' + ? @{$new_args{$key}} + : $new_args{$key}; + } + elsif ($makemaker_argtype{$key} eq 'HASH') { + $args->{$key} = {} unless defined $args->{$key}; + foreach my $skey (keys %{ $new_args{$key} }) { + $args->{$key}{$skey} = $new_args{$key}{$skey}; + } + } + elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { + $self->makemaker_append($key => $new_args{$key}); + } + else { + if (defined $args->{$key}) { + warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; + } + $args->{$key} = $new_args{$key}; + } + } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { - my $self = sShift; + my $self = shift; my $name = shift; my $args = $self->makemaker_args; - $args->{name} = defined $args->{$name} - ? join( ' ', $args->{name}, @_ ) + $args->{$name} = defined $args->{$name} + ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } @@ -107,6 +196,9 @@ %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); + if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { + File::Find::find( \&_wanted_t, 'xt' ); + } $self->tests( join ' ', map { "$_/.t" } sort keys %test_dir ); } @@ -130,12 +222,13 @@ # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. - $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); - $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); + my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; + $self->build_requires( 'ExtUtils::MakeMaker' => $v ); + $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. - $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); + $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } @@ -143,59 +236,103 @@ my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name \|\| $self->name; - $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; + $args->{VERSION} = $self->version or die <<'EOT'; +ERROR: Can't determine distribution version. Please specify it +explicitly via 'version' in Makefile.PL, or set a valid $VERSION +in a module, and provide its file path via 'version_from' (or +'all_from' if you prefer) in Makefile.PL. +EOT + + $DB::single = 1; if ( $self->tests ) { - $args->{test} = { TESTS => $self->tests }; + my @tests = split ' ', $self->tests; + my %seen; + $args->{test} = { + TESTS => (join ' ', grep {!$seen{$_}++} @tests), + }; + } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { + $args->{test} = { + TESTS => join( ' ', map { "$_/.t" } grep { -d $_ } qw{ t xt } ), + }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; - $args->{AUTHOR} = $self->author; + $args->{AUTHOR} = join ', ', @{$self->author \|\| []}; } - if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { - $args->{NO_META} = 1; + if ( $self->makemaker(6.10) ) { + $args->{NO_META} = 1; + #$args->{NO_MYMETA} = 1; } - if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { + if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } + if ( $self->makemaker(6.31) and $self->license ) { + $args->{LICENSE} = $self->license; + } - # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} \|\|= {}); %$prereq = ( %$prereq, - map { @$_ } + map { @$_ } # flatten [module => version] map { @$_ } grep $_, - ($self->configure_requires, $self->build_requires, $self->requires) + ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; - # merge both kinds of requires into prereq_pm + # Merge both kinds of requires into BUILD_REQUIRES + my $build_prereq = ($args->{BUILD_REQUIRES} \|\|= {}); + %$build_prereq = ( %$build_prereq, + map { @$_ } # flatten [module => version] + map { @$_ } + grep $_, + ($self->configure_requires, $self->build_requires) + ); + + # Remove any reference to perl, BUILD_REQUIRES doesn't support it + delete $args->{BUILD_REQUIRES}->{perl}; + + # Delete bundled dists from prereq_pm my $subdirs = ($args->{DIR} \|\|= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; - delete $prereq->{$file}; + delete $build_prereq->{$file}; #Delete from build prereqs only } } + unless ( $self->makemaker('6.55_03') ) { + %$prereq = (%$prereq,%$build_prereq); + delete $args->{BUILD_REQUIRES}; + } + if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; + + if ( $self->makemaker(6.48) ) { + $args->{MIN_PERL_VERSION} = $perl_version; + } } - $args->{INSTALLDIRS} = $self->installdirs; + if ($self->installdirs) { + warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; + $args->{INSTALLDIRS} = $self->installdirs; + } - my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; + my %args = map { + ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) + } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; - if (my $preop = $self->admin->preop($user_preop)) { + if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } @@ -265,4 +402,4 @@ __END__ -#line 394 +#line 531
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/inc/Module/Install/Metadata.pm ^
@@ -6,7 +6,7 @@ use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -19,7 +19,6 @@ name module_name abstract - author version distribution_type tests @@ -43,8 +42,11 @@ my @array_keys = qw{ keywords + author }; +authors = \&author; + sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } @@ -230,6 +232,8 @@ die("The path '$file' does not exist, or is not a file"); } + $self->{values}{all_from} = $file; + # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; @@ -240,7 +244,7 @@ $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; - $self->author_from($pod) unless $self->author; + $self->author_from($pod) unless @{$self->author \|\| []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; @@ -385,11 +389,10 @@ } } -sub perl_version_from { - my $self = shift; +sub _extract_perl_version { if ( - Module::Install::_read($_[0]) =~ m/ - ^ + $_[0] =~ m/ + ^\s (?:use\|require) \s* v? ([\d_\.]+) @@ -398,6 +401,16 @@ ) { my $perl_version = $1; $perl_version =~ s{_}{}g; + return $perl_version; + } else { + return; + } +} + +sub perl_version_from { + my $self = shift; + my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); + if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; @@ -417,59 +430,116 @@ ([^\n]) /ixms) { my $author = $1 \|\| $2; - $author =~ s{E<lt>}{<}g; - $author =~ s{E<gt>}{>}g; + + # XXX: ugly but should work anyway... + if (eval "require Pod::Escapes; 1") { + # Pod::Escapes has a mapping table. + # It's in core of perl >= 5.9.3, and should be installed + # as one of the Pod::Simple's prereqs, which is a prereq + # of Pod::Text 3.x (see also below). + $author =~ s{ E<( (\d+) \| ([A-Za-z]+) )> } + { + defined $2 + ? chr($2) + : defined $Pod::Escapes::Name2character_number{$1} + ? chr($Pod::Escapes::Name2character_number{$1}) + : do { + warn "Unknown escape: E<$1>"; + "E<$1>"; + }; + }gex; + } + elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { + # Pod::Text < 3.0 has yet another mapping table, + # though the table name of 2.x and 1.x are different. + # (1.x is in core of Perl < 5.6, 2.x is in core of + # Perl < 5.9.3) + my $mapping = ($Pod::Text::VERSION < 2) + ? \%Pod::Text::HTML_Escapes + : \%Pod::Text::ESCAPES; + $author =~ s{ E<( (\d+) \| ([A-Za-z]+) )> } + { + defined $2 + ? chr($2) + : defined $mapping->{$1} + ? $mapping->{$1} + : do { + warn "Unknown escape: E<$1>"; + "E<$1>"; + }; + }gex; + } + else { + $author =~ s{E<lt>}{<}g; + $author =~ s{E<gt>}{>}g; + } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } -sub license_from { - my $self = shift; - if ( - Module::Install::_read($_[0]) =~ m/ - ( - =head \d \s+ - (?:licen[cs]e\|licensing\|copyright\|legal)\b - .? - ) - (=head\\d.\|=cut.\|) - \z - /ixms ) { - my $license_text = $1; - my @phrases = ( - 'under the same (?:terms\|license) as (?:perl\|the perl programming language) itself' => 'perl', 1, - 'GNU general public license' => 'gpl', 1, - 'GNU public license' => 'gpl', 1, - 'GNU lesser general public license' => 'lgpl', 1, - 'GNU lesser public license' => 'lgpl', 1, - 'GNU library general public license' => 'lgpl', 1, - 'GNU library public license' => 'lgpl', 1, - 'BSD license' => 'bsd', 1, - 'Artistic license' => 'artistic', 1, - 'GPL' => 'gpl', 1, - 'LGPL' => 'lgpl', 1, - 'BSD' => 'bsd', 1, - 'Artistic' => 'artistic', 1, - 'MIT' => 'mit', 1, - 'proprietary' => 'proprietary', 0, - ); - while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { - $pattern =~ s{\s+}{\\s+}g; - if ( $license_text =~ /\b$pattern\b/i ) { - $self->license($license); - return 1; - } +sub _extract_license { + my $pod = shift; + my $matched; + return __extract_license( + ($matched) = $pod =~ m/ + (=head \d \s+ (?:licen[cs]e\|licensing)\b.?) + (=head \d.\|=cut.\|)\z + /ixms + ) \|\| __extract_license( + ($matched) = $pod =~ m/ + (=head \d \s+ (?:copyrights?\|legal)\b.?) + (=head \d.\|=cut.\|)\z + /ixms + ); +} + +sub __extract_license { + my $license_text = shift or return; + my @phrases = ( + 'under the same (?:terms\|license) as (?:perl\|the perl programming language)' => 'perl', 1, + 'under the terms of (?:perl\|the perl programming language) itself' => 'perl', 1, + 'Artistic and GPL' => 'perl', 1, + 'GNU general public license' => 'gpl', 1, + 'GNU public license' => 'gpl', 1, + 'GNU lesser general public license' => 'lgpl', 1, + 'GNU lesser public license' => 'lgpl', 1, + 'GNU library general public license' => 'lgpl', 1, + 'GNU library public license' => 'lgpl', 1, + 'BSD license' => 'bsd', 1, + 'Artistic license' => 'artistic', 1, + 'GPL' => 'gpl', 1, + 'LGPL' => 'lgpl', 1, + 'BSD' => 'bsd', 1, + 'Artistic' => 'artistic', 1, + 'MIT' => 'mit', 1, + 'proprietary' => 'proprietary', 0, + ); + while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { + $pattern =~ s#\s+#\\s+#gs; + if ( $license_text =~ /\b$pattern\b/i ) { + return $license; } } +} - warn "Cannot determine license info from $_[0]\n"; - return 'unknown'; +sub license_from { + my $self = shift; + if (my $license=_extract_license(Module::Install::_read($_[0]))) { + $self->license($license); + } else { + warn "Cannot determine license info from $_[0]\n"; + return 'unknown'; + } } sub _extract_bugtracker { - my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; + my @links = $_[0] =~ m#L<( + \Qhttp://rt.cpan.org/\E[^>]+\| + \Qhttp://github.com/\E[\w_]+/[\w_]+/issues\| + \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list + )>#gx; my %links; @links{@links}=(); @links=keys %links; @@ -485,7 +555,7 @@ return 0; } if ( @links > 1 ) { - warn "Found more than on rt.cpan.org link in $_[0]\n"; + warn "Found more than one bugtracker link in $_[0]\n"; return 0; }
[-] [+]	Changed	check_diskio-3.2.4.tar.bz2/inc/Module/Install/Scripts.pm ^
@@ -6,7 +6,7 @@ use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; }

Changes of Revision 20