NetApp-500.002/000755 067073 067073 00000000000 11763415704 013747 5ustar00pmoorepmoore000000 000000 NetApp-500.002/CHANGES000644 067073 067073 00000001663 11761174400 014741 0ustar00pmoorepmoore000000 000000 Release 2.002 After stagnating for several years, I have once again taken over responsibility for this module, and expect to be enhancing it in the coming months. The version syntax has been changed, to move away from v-strings, and Build.PL converted to Makefile.PL. Otherwise, the code is identical to 1.1.2 Release 1.1.2 CPAN-friendly changes. The test suite will work if you don't configure it, instead of imploding. This will mean we get some minimally useful results from CPAN testers. We will at least get results for the parsing code. Added the dependency on Test::Exception I missed. Added this CHANGES file, and ripped out the .svn directories I mistakenly distributed with 1.1.1. (Oops...) Fixed a parsing typo in NetApp::Volume->get_language Release 1.1.1 This was the first version released to CPAN.NetApp-500.002/inc/000755 067073 067073 00000000000 11763415704 014520 5ustar00pmoorepmoore000000 000000 NetApp-500.002/lib/000755 067073 067073 00000000000 11763415704 014515 5ustar00pmoorepmoore000000 000000 NetApp-500.002/Makefile.PL000644 067073 067073 00000000763 11757741210 015724 0ustar00pmoorepmoore000000 000000 use strict; use warnings; use English; use inc::Module::Install; name q{NetApp}; abstract q{The EFS project, NetApp API}; author q{Phillip Moore }; perl_version q{5.010}; license q{unknown}; all_from q{lib/NetApp.pm}; test_requires q{Test::Exception}; requires q{IPC::Cmd}; requires q{Class::Std}; requires q{Params::Validate}; requires q{Regexp::Common}; requires q{Memoize}; requires q{Net::Telnet}; requires q{Clone}; tests_recursive; WriteAll; NetApp-500.002/MANIFEST000644 067073 067073 00000003261 11763415704 015102 0ustar00pmoorepmoore000000 000000 CHANGES inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/NetApp.pm lib/NetApp/Aggregate.pm lib/NetApp/Aggregate.pod lib/NetApp/Aggregate/Plex.pm lib/NetApp/Aggregate/Plex.pod lib/NetApp/Aggregate/RAIDGroup.pm lib/NetApp/Aggregate/RAIDGroup.pod lib/NetApp/Filer.pm lib/NetApp/Filer.pod lib/NetApp/Filer/Export.pm lib/NetApp/Filer/Export.pod lib/NetApp/Filer/License.pm lib/NetApp/Filer/License.pod lib/NetApp/Filer/Option.pm lib/NetApp/Filer/Option.pod lib/NetApp/Filer/TimeoutCache.pm lib/NetApp/Filer/Version.pm lib/NetApp/Filer/Version.pod lib/NetApp/Qtree.pm lib/NetApp/Qtree.pod lib/NetApp/Snapmirror.pm lib/NetApp/Snapmirror.pod lib/NetApp/Snapmirror/Destination.pm lib/NetApp/Snapmirror/Source.pm lib/NetApp/Snapshot.pm lib/NetApp/Snapshot.pod lib/NetApp/Snapshot/Delta.pm lib/NetApp/Snapshot/Delta.pod lib/NetApp/Snapshot/Schedule.pm lib/NetApp/Snapshot/Schedule.pod lib/NetApp/Volume.pm lib/NetApp/Volume.pod lib/NetApp/Volume/Source.pm Makefile.PL MANIFEST This list of files META.yml README t/10_passive/00_filer_command.t t/10_passive/01_filer_parsing.t t/10_passive/02_filer_objects.t t/10_passive/05_aggregate_parsing.t t/10_passive/06_aggregate_objects.t t/10_passive/10_volume_parsing.t t/10_passive/11_volume_objects.t t/10_passive/15_qtree_parsing.t t/10_passive/16_qtree_objects.t t/10_passive/20_snapmirror_parsing.t t/10_passive/21_snapmirror_objects.t t/10_passive/25_snapshot_parsing.t t/10_passive/26_snapshot_objects.t t/10_passive/30_exports_parsing.t t/10_passive/31_exports_objects.t t/lib/NetApp/Test.pm NetApp-500.002/META.yml000644 067073 067073 00000001115 11763415700 015212 0ustar00pmoorepmoore000000 000000 --- abstract: 'The EFS project, NetApp API' author: - 'Phillip Moore ' build_requires: ExtUtils::MakeMaker: 6.42 Test::Exception: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.93' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: NetApp no_index: directory: - inc - t requires: Class::Std: 0 Clone: 0 IPC::Cmd: 0 Memoize: 0 Net::Telnet: 0 Params::Validate: 0 Regexp::Common: 0 perl: 5.10.0 version: 500.002 NetApp-500.002/README000644 067073 067073 00000007723 11761174211 014631 0ustar00pmoorepmoore000000 000000 INTRODUCTION This package provides a suite of modules for managing NetApp's NAS devices, commonly referred to as "filers". Although I consider the code to be very stable, the API should be considered experimental. The convention I will be following regarding non-compatible API changes is as follows. I'm using a major.minor release naming convention, and I will promise to NOT make non-backwards compatible changes between patches to a given major.minor release. However, in order to allow the API to evolve, it is entirely possible that non-backwards compatible changes will be made between minor releases. There is no guarantee that 2.003 will be 100% backwards compatible with 2.002, although such changes will be made only when justified. The author does not believe in infinite backwards compatibility. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SSH vs TELNET This module is designed to be used with a password-free ssh configuration, which means you must have configured your filers with an ssh key such that you can run remote commands using: ssh [ ssh options ] $hostname $command without entering a password. In order to configure this, you need to install the public half of your ssh key on the filers directly. You can use this module with telnet, but this is less secure, since you have to find a way to access the plain text password from your code, and that usually means either embedding the password in the source code (the worst idea) or embedding it into a file somewhere. In addition, the error checking with telnet is far less robust, and there can only be one concurrent telnet session to a filer, so we recommend against using telnet for anything other than installing the ssh key. In a future release, the author hopes to provide a utility to automate the installation of the ssh key, using the telnet protocol, as both an example of using the API, and a means of helping others wean themselves from the use of telnet. TESTING The test suite is broken down into two separate sections: 10_passive and 20_active. The passive tests will change absolutely nothing on the filers. The goal of the passive tests is to run the query methods and the parsing code through as much input as possible, and these tests will walk through every aggregate, volume and qtree, among other object types, on each filer that has been configured for testing. As a result, they can be somewhat time consuming, depending on the number of filers, and the size of their configuration. The active tests, which are not yet implemented, will be destructive, and will test creating, modifying and destroying objects such as aggregates, volumes, qtrees, etc. The author expects to start adding active tests in one of the upcoming releases of this API. The tests are configured by specifying one or more filers to query in the file: ./t/lib/NetApp/Test.pm Please see that file for examples and documentation on how to customize the configuration. To summarize, you can either hack that file, or you can export a number of environment variables to control the test externally (this is what the author does, for example). DEPENDENCIES A bunch... See Makefile.PL, which will tell you about them anyway when it doesn't find them. Note that if you want to use the caching feature of the NetApp::Filer objects, this requires a patched version of Memoize::Expire. I have tried to get the owner of that code to accept a patch, but have been unable to get a response from him. Email me directly, and I'll be happy to provide the code. COPYRIGHT AND LICENCE Copyright (C) 2008, Phillip Moore All rights reserved. This code is released under the same license as perl itself. CREDITS The following people helped to make this release happen: Baldwin Sung Chibo Qian Ugur Tigli Ed Dabagian-Paul Robert Benoit NetApp-500.002/t/000755 067073 067073 00000000000 11763415704 014212 5ustar00pmoorepmoore000000 000000 NetApp-500.002/t/10_passive/000755 067073 067073 00000000000 11763415704 016164 5ustar00pmoorepmoore000000 000000 NetApp-500.002/t/lib/000755 067073 067073 00000000000 11763415704 014760 5ustar00pmoorepmoore000000 000000 NetApp-500.002/t/lib/NetApp/000755 067073 067073 00000000000 11763415704 016147 5ustar00pmoorepmoore000000 000000 NetApp-500.002/t/lib/NetApp/Test.pm000644 067073 067073 00000003434 11120507202 017406 0ustar00pmoorepmoore000000 000000 # # $Id: $ # package NetApp::Test; use strict; use warnings; use English; select(STDERR); $| = 1; select(STDOUT); $| = 1; # The author has to set these ssh options to workaround the lack of a # centrally managed known_hosts file: # # export NETAPP_SSH_COMMAND = \ # ssh -o StrictHostKeyChecking=no -o LogLevel=ERROR # # If your ssh environment required additional default options, specify # them here. Do NOT specify the identify file in these arguments. my $ssh_command = [ split( /\s+/, $ENV{NETAPP_SSH_COMMAND} || 'ssh' ) ]; # This variable specifies the default ssh identify file to use my $ssh_identity = $ENV{NETAPP_SSH_IDENTITY}; our @filer_args = (); # Specify a list of NAS filers to use for the test suite. This # variable should a whitespace-separated list of colon-separated # entries. Each entry should be of the form: # # $hostname:$protocol:$extra # # where $hostname is the hostname of the filer, $protocol is either # 'ssh' or 'telnet', and $extra is either the ssh identity file # (optional) or the telnet password. If the ssh_identity file is NOT # specified in these entries, then a default must have been specified # above. If the protocol is not given, then it defaults to 'ssh'. if ( $ENV{NETAPP_TEST_FILERS} ) { foreach my $entry ( split /\s+/, $ENV{NETAPP_TEST_FILERS} ) { my ($hostname,$protocol,$extra) = split /:/, $entry, 3; $protocol ||= 'ssh'; my $filer_arg = { hostname => $hostname, protocol => $protocol, }; if ( $protocol eq 'ssh' ) { $filer_arg->{ssh_command} = $ssh_command; $filer_arg->{ssh_identity} = $extra || $ssh_identity; } elsif ( $extra ) { $filer_arg->{telnet_password} = $extra; } push @filer_args, $filer_arg; } } 1; NetApp-500.002/t/10_passive/00_filer_command.t000644 067073 067073 00000007530 11120512076 021437 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; BEGIN { if ( not @NetApp::Test::filer_args ) { print "1..0 # Skip: No test filers defined\n"; exit 0; } } use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; my @filer_args = @NetApp::Test::filer_args; my ($ssh_filer) = grep { $_->{protocol} eq 'ssh' } @filer_args; my $ssh_command = $ssh_filer->{ssh_command}; my $ssh_identity = $ssh_filer->{ssh_identity}; my $hostname = $ssh_filer->{hostname}; my $ssh_string_want = join(' ',@$ssh_command, "-i $ssh_identity -l root $hostname"); my ($telnet_filer) = grep { $_->{protocol} eq 'telnet' } @filer_args; throws_ok { my $filer = NetApp::Filer->new({}); } qr{Mandatory parameter 'hostname' missing in call to NetApp::Filer::BUILD.*}, qq{NetApp::Filer->new requires hostname}; throws_ok { my $filer = NetApp::Filer->new({ hostname => 'some_random_hostname', ssh_identity => '/no/such/file', }); } qr{No such ssh_identity file: /no/such/file}, qq{NetApp::Filer->new requires valid ssh_identity file}; my $filer = NetApp::Filer->new( $ssh_filer ); isa_ok( $filer, 'NetApp::Filer' ); ok( ref $filer->_get_ssh_command eq "ARRAY", 'return type of _get_ssh_command'); my $ssh_string_have = join(' ',@{ $filer->_get_ssh_command }); ok( $ssh_string_have eq $ssh_string_want, "return value of _get_ssh_command: $ssh_string_have" ); ok( $filer->_run_command( command => [qw(version)] ), 'calling _run_command'); ok( $filer->_get_command_status, 'true status'); my @stderr = $filer->_get_command_stderr; my @stdout = $filer->_get_command_stdout; ok( scalar @stderr == 0, 'no stderr'); ok( $filer->_get_command_error == 0, 'no error'); ok( scalar @stdout == 1, 'one line in stdout'); my $status = $filer->_run_command( command => [qw(nosuch command)], nonfatal => 1, ); ok( $status, 'calling run_command again'); # Hmm... The status is still true # ok( $filer->_get_command_status == 0, 'failed status' ); ok( scalar $filer->_get_command_stdout == 0, 'no stdout'); ok( scalar $filer->_get_command_stderr == 1, 'one line in stderr'); ok( ( $filer->_get_command_stderr )[0] eq "nosuch not found. Type '?' for a list of commands", 'nosuch command error message'); # # This is failing with a bizarre error: # Failed test 'Fatal _run_command throws exception by default' # at t/00_filer_command.t line 76. # expecting: Regexp ((?-xism:Error running 'nosuch command' on)) # found: panic: attempt to copy freed scalar a1c7d20 to 9fd7238 at /efs/dist/perl5/core/5.10.0-ml01/.exec/x86-32.linux.2.4/lib/perl5/Carp/Heavy.pm line 104. # # There appear to be major problems with perl5.8 and Test::Exception # on Solaris 8, too. # # throws_ok { # $filer->_run_command( command => [qw(nosuch command)] ); # } qr{Error running 'nosuch command' on}, # qq{Fatal _run_command throws exception by default}; eval { $filer->_run_command( command => [qw(nosuch command)] ); }; ok( $@ =~ qr{Error running 'nosuch command' via ssh on}, qq{Fatal _run_command throws exception by default} ); # Telnet tests if ( not ref $telnet_filer ) { print "# Skipping tests of telnet access. Not configured\n"; exit 0; } $filer = NetApp::Filer->new( $telnet_filer ); isa_ok( $filer, 'NetApp::Filer' ); ok( $filer->_run_command( command => [qw( version )] ), 'calling _run_command' ); ok( $filer->_get_command_status, 'true status' ); @stderr = $filer->_get_command_stderr; @stdout = $filer->_get_command_stdout; ok( scalar @stderr == 0, 'no stderr'); ok( scalar @stdout == 1, 'one line in stdout' ); # NOTE: The error checking tests, based on calling "nosuch command" # can NOT be made to work with Net::Telnet, because there is no # generic error handling available via telnet, only ssh. NetApp-500.002/t/10_passive/01_filer_parsing.t000644 067073 067073 00000006557 11113273352 021500 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; my @lines = split /\n/, <<__lines__; a_sis site ABCDEFG expired (29 May 2008) cifs site HIJKLMN cluster OPQRSTU __lines__ my $license = NetApp::Filer->_parse_license( $lines[0] ); ok( $license->{service} eq 'a_sis', "Parsed 1st service correctly" ); ok( $license->{type} eq 'site', "Parsed 1st type correctly" ); ok( $license->{code} eq 'ABCDEFG', "Parsed 1st code correctly" ); ok( $license->{expired} eq '29 May 2008', "Parsed 1st expiration data correctly" ); $license = NetApp::Filer->_parse_license( $lines[1] ); ok( $license->{service} eq 'cifs', "Parsed 2nd service correctly" ); ok( $license->{type} eq 'site', "Parsed 2nd type correctly" ); ok( $license->{code} eq 'HIJKLMN', "Parsed 2nd code correctly" ); ok( ! $license->{expired}, "Parsed 2nd expiration data correctly" ); $license = NetApp::Filer->_parse_license( $lines[2] ); ok( $license->{service} eq 'cluster', "Parsed 3rd service correctly" ); ok( $license->{type} eq 'node', "Parsed 3rd type correctly" ); ok( $license->{code} eq 'OPQRSTU', "Parsed 3rd code correctly" ); ok( ! $license->{expired}, "Parsed 3rd expiration data correctly" ); @lines = split /\n/, <<__lines__; admin.etc.refresh.rate 0 auditlog.enable on (value might be overwritten in takeover) __lines__ my $option = NetApp::Filer->_parse_option( $lines[0] ); ok( $option->{name} eq 'admin.etc.refresh.rate', "Parsed 1st name correctly" ); ok( $option->{value} eq '0', "Parsed 1st value correctly" ); $option = NetApp::Filer->_parse_option( $lines[1] ); ok( $option->{name} eq 'auditlog.enable', "Parsed 1st name correctly" ); ok( $option->{value} eq 'on', "Parsed 1st value correctly" ); my $version = NetApp::Filer::Version->new({ string => "NetApp Release 7.2.2: Sat Mar 24 20:38:59 PDT 2007", }); isa_ok( $version, 'NetApp::Filer::Version' ); ok( $version->get_major == 7, 'version->get_major' ); ok( $version->get_minor == 2, 'version->get_minor' ); ok( $version->get_subminor == 2, 'version->get_subminor' ); ok( ! $version->get_patchlevel, 'version->get_patchlevel' ); ok( $version->get_date eq 'Sat Mar 24 20:38:59 PDT 2007', 'version->get_date' ); $version = NetApp::Filer::Version->new({ string => "NetApp Release 7.2.4L1: Wed Nov 21 00:49:33 PST 2007", }); isa_ok( $version, 'NetApp::Filer::Version' ); ok( $version->get_major == 7, 'version->get_major' ); ok( $version->get_minor == 2, 'version->get_minor' ); ok( $version->get_subminor == 4, 'version->get_subminor' ); ok( $version->get_patchlevel == 1, 'version->get_patchlevel' ); ok( $version->get_date eq 'Wed Nov 21 00:49:33 PST 2007', 'version->get_date' ); $version = NetApp::Filer::Version->new({ string => "NetApp Release 7.2.5.1: Wed Jun 25 08:55:16 PDT 2008", }); isa_ok( $version, 'NetApp::Filer::Version' ); ok( $version->get_major == 7, 'version->get_major' ); ok( $version->get_minor == 2, 'version->get_minor' ); ok( $version->get_subminor == 5, 'version->get_subminor' ); ok( $version->get_patchlevel == 1, 'version->get_patchlevel' ); ok( $version->get_date eq 'Wed Jun 25 08:55:16 PDT 2008', 'version->get_date' ); NetApp-500.002/t/10_passive/02_filer_objects.t000644 067073 067073 00000002473 11120512070 021447 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; BEGIN { if ( not @NetApp::Test::filer_args ) { print "1..0 # Skip: No test filers defined\n"; exit 0; } } use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; foreach my $filer_args ( @NetApp::Test::filer_args ) { ok( ref $filer_args eq 'HASH', 'filer_args entry is a HASH ref' ); my $filer = NetApp::Filer->new( $filer_args ); isa_ok( $filer, 'NetApp::Filer' ); print "# Running tests on filer " . $filer->get_hostname . "\n"; my $version = $filer->get_version; isa_ok( $version, 'NetApp::Filer::Version' ); my @licenses = $filer->get_licenses; ok( @licenses, 'filer->get_licenses' ); foreach my $license ( @licenses ) { ok( $license->get_service, 'license->get_service' ); ok( $license->get_type, 'license->get_type' ); ok( $license->get_code, 'license->get_code' ); ok( defined $license->get_expired, 'license->get_expired' ); } my @options = $filer->get_options; ok( @options, 'filer->get_options' ); foreach my $option ( @options ) { ok( $option->get_name, 'option->get_name' ); ok( defined $option->get_value, 'option->get_value' ); } } NetApp-500.002/t/10_passive/05_aggregate_parsing.t000644 067073 067073 00000010414 11113273352 022314 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Aggregate; my $header = " Aggr State Status Options"; throws_ok { ( my $bogus = $header ) =~ s/Aggr//; NetApp::Aggregate->_parse_aggr_status_headers( $bogus ); } qr{Unable to match 'Aggr' column header}, qq{Missing Aggr in header}; throws_ok { ( my $bogus = $header ) =~ s/State//; NetApp::Aggregate->_parse_aggr_status_headers( $bogus ); } qr{Unable to match 'State' column header}, qq{Missing State in header}; throws_ok { ( my $bogus = $header ) =~ s/Status//; NetApp::Aggregate->_parse_aggr_status_headers( $bogus ); } qr{Unable to match 'Status' column header}, qq{Missing Status in header}; my $indices = NetApp::Aggregate->_parse_aggr_status_headers( $header ); ok( scalar keys %$indices == 4, "Correct hash key count for indices" ); ok( $indices->{aggr}->[0] == 0 && $indices->{aggr}->[1] == 16, "Indices for aggr correct" ); ok( $indices->{state}->[0] == 16 && $indices->{state}->[1] == 11, "Indices for state correct" ); ok( $indices->{status}->[0] == 27 && $indices->{status}->[1] == 18, "Indices for status correct" ); ok( $indices->{options}->[0] == 45, "Indices for options correct" ); my $line1 = "really_long_aggr01 online raid_dp, aggr root, raidsize=14"; my $line2 = " morestatus moreoptions"; my $aggregate = {}; NetApp::Aggregate->_parse_aggr_status_aggregate( indices => $indices, aggregate => $aggregate, line => $line1, ); ok( $aggregate->{name} eq 'really_long_aggr01', "Parsed name correctly" ); ok( $aggregate->{state}->{online} == 1, "Parsed state correctly" ); foreach my $status ( qw( raid_dp aggr ) ) { ok( $aggregate->{status}->{$status} == 1, "Parsed $status status correctly" ); } ok( $aggregate->{options}->{root} == 1, "Parsed root options correctly" ); ok( $aggregate->{options}->{raidsize} == 14, "Parsed raidsize options correctly" ); NetApp::Aggregate->_parse_aggr_status_aggregate( indices => $indices, aggregate => $aggregate, line => $line2, ); foreach my $status ( qw( raid_dp aggr ) ) { ok( $aggregate->{status}->{$status} == 1, "Previously parsed $status status preserved" ); } ok( $aggregate->{status}->{morestatus} == 1, "Parsed 2nd line status correctly" ); ok( $aggregate->{options}->{moreoptions} == 1, "Parsed 2nd line options correctly" ); my $line3 = " Volumes: vol1, vol2, vol3,"; my $line4 = " vol4, vol5,"; my $line5 = " vol6"; my $volumes = {}; NetApp::Aggregate->_parse_aggr_status_volumes( volumes => $volumes, line => $line3, ); ok( scalar keys %$volumes == 3, "Parsed first volume line correctly" ); NetApp::Aggregate->_parse_aggr_status_volumes( volumes => $volumes, line => $line4, ); ok( scalar keys %$volumes == 5, "Parsed second volume line correctly" ); NetApp::Aggregate->_parse_aggr_status_volumes( volumes => $volumes, line => $line5, ); ok( scalar keys %$volumes == 6, "Parsed third volume line correctly" ); foreach my $index ( 1 .. 6 ) { ok( $volumes->{"vol$index"} == 1, "Volume $index found correctly" ); } my $line6 = " Plex /really_long_aggr01/plex0: online, normal, active"; my $plex = NetApp::Aggregate->_parse_aggr_status_plex( $line6 ); ok( $plex->{name} eq '/really_long_aggr01/plex0', "Parsed plex name correctly" ); ok( ref $plex->{state} eq 'HASH', "Plex state data type correct" ); ok( scalar keys %{ $plex->{state} } == 3, "Correct number of states" ); foreach my $state ( qw( online normal active ) ) { ok( $plex->{state}->{$state}, "State values are correct" ); } my $line7 = " RAID group /really_long_aggr01/plex0/rg0: normal"; my $raidgroup = NetApp::Aggregate->_parse_aggr_status_raidgroup( $line7 ); ok( $raidgroup->{name} eq '/really_long_aggr01/plex0/rg0', "Parsed RAIDGroup name correctly" ); ok( ref $raidgroup->{state} eq 'HASH', "Raidgroup state data type correct" ); ok( scalar keys %{ $raidgroup->{state} } == 1, "Correct number of states" ); ok( $raidgroup->{state}->{normal}, "State value is correct" ); NetApp-500.002/t/10_passive/06_aggregate_objects.t000644 067073 067073 00000004447 11120512047 022307 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; BEGIN { if ( not @NetApp::Test::filer_args ) { print "1..0 # Skip: No test filers defined\n"; exit 0; } } use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Aggregate; foreach my $filer_args ( @NetApp::Test::filer_args ) { ok( ref $filer_args eq 'HASH', 'filer_args entry is a HASH ref' ); my $filer = NetApp::Filer->new( $filer_args ); isa_ok( $filer, 'NetApp::Filer' ); print "# Running tests on filer " . $filer->get_hostname . "\n"; my @aggregate_names = $filer->get_aggregate_names; ok( @aggregate_names, "get_aggregate_names" ); my @aggregates = $filer->get_aggregates; ok( @aggregates, "get_aggregates" ); foreach my $aggregate ( @aggregates ) { isa_ok( $aggregate, 'NetApp::Aggregate' ); isa_ok( $aggregate->get_filer, 'NetApp::Filer' ); my $plex = $aggregate->get_plex; isa_ok( $plex, 'NetApp::Aggregate::Plex' ); foreach my $raidgroup ( $plex->get_raidgroups ) { isa_ok( $raidgroup, 'NetApp::Aggregate::RAIDGroup' ); } my @states = $aggregate->get_states; ok( @states, 'aggregate->get_states' ); foreach my $state ( @states ) { ok( $aggregate->get_state( $state ), "aggregate->get_state($state)" ); } ok( ! $aggregate->get_state( 'bogus' ), 'aggregate->get_state(bogus) returns false' ); my @statuses = $aggregate->get_statuses; ok( @statuses, 'aggregate->get_statuses' ); foreach my $status ( @statuses ) { ok( $aggregate->get_status( $status ), "aggregate->get_status($status)" ); } ok( ! $aggregate->get_status( 'bogus' ), 'aggregate->get_status(bogus) returns false' ); my @options = $aggregate->get_options; ok( @options, 'aggregate->get_options' ); foreach my $option ( @options ) { ok( defined $aggregate->get_option( $option ), "aggregate->get_option($option)" ); } ok( ! defined $aggregate->get_option( 'bogus' ), 'aggregate->get_option(bogus) returns undef' ); } } NetApp-500.002/t/10_passive/10_volume_parsing.t000644 067073 067073 00000011535 11113273352 021676 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Volume; my $header = <<"__header__"; Volume State Status Options __header__ throws_ok { ( my $bogus = $header ) =~ s/Volume//; NetApp::Volume->_parse_vol_status_headers( $bogus ); } qr{Unable to match 'Volume' column header}, qq{Missing Volume in header}; throws_ok { ( my $bogus = $header ) =~ s/State//; NetApp::Volume->_parse_vol_status_headers( $bogus ); } qr{Unable to match 'State' column header}, qq{Missing State in header}; throws_ok { ( my $bogus = $header ) =~ s/Status//; NetApp::Volume->_parse_vol_status_headers( $bogus ); } qr{Unable to match 'Status' column header}, qq{Missing Status in header}; throws_ok { ( my $bogus = $header ) =~ s/Options//; NetApp::Volume->_parse_vol_status_headers( $bogus ); } qr{Unable to match 'Options' column header}, qq{Missing Options in header}; my $indices = NetApp::Volume->_parse_vol_status_headers( $header ); ok( scalar keys %$indices == 5, "Correct hash key count for indices" ); ok( $indices->{volume}->[0] == 0 && $indices->{volume}->[1] == 16, "Indices for volume correct" ); ok( $indices->{state}->[0] == 16 && $indices->{state}->[1] == 11, "Indices for state correct" ); ok( $indices->{status}->[0] == 27 && $indices->{status}->[1] == 18, "Indices for status correct" ); ok( $indices->{options}->[0] == 45, "Indices for options correct" ); my @lines = split /\n/, <<__lines__; really_long_volume01 online raid_dp, flex nosnap=off, nosnapdir=off, minra=off, no_atime_update=off, __lines__ my $volume = {}; NetApp::Volume->_parse_vol_status_volume( indices => $indices, volume => $volume, line => $lines[0], ); ok( $volume->{name} eq 'really_long_volume01', "Parsed name correctly" ); ok( $volume->{state}->{online} == 1, "Parsed state correctly" ); foreach my $status ( qw( raid_dp flex ) ) { ok( $volume->{status}->{$status} == 1, "Parsed $status status correctly" ); } ok( $volume->{options}->{nosnap} eq 'off', "Parsed nosnap options correctly" ); ok( $volume->{options}->{nosnapdir} eq 'off', "Parsed nosnapdir options correctly" ); NetApp::Volume->_parse_vol_status_volume( indices => $indices, volume => $volume, line => $lines[1], ); foreach my $status ( qw( raid_dp flex ) ) { ok( $volume->{status}->{$status} == 1, "Previously parsed $status status preserved" ); } ok( $volume->{options}->{minra} eq 'off' && $volume->{options}->{no_atime_update} eq 'off', "Parsed 2nd line options correctly" ); my $header_source = <<"__header_source__"; Volume State Status Options Source __header_source__ $indices = NetApp::Volume->_parse_vol_status_headers( $header_source ); ok( scalar keys %$indices == 6, "Correct hash key count for indices" ); ok( $indices->{volume}->[0] == 0 && $indices->{volume}->[1] == 16, "Indices for volume correct" ); ok( $indices->{state}->[0] == 16 && $indices->{state}->[1] == 11, "Indices for state correct" ); ok( $indices->{status}->[0] == 27 && $indices->{status}->[1] == 18, "Indices for status correct" ); ok( $indices->{options}->[0] == 45 && $indices->{options}->[1] == 29, "Indices for options correct" ); ok( $indices->{source}->[0] == 74, "Indices for source correct" ); @lines = split /\n/, <<__lines__; cache_volume online raid_dp, flex nosnap=off, nosnapdir=off, localhost:cache_source flexcache minra=off, no_atime_update=off, __lines__ $volume = {}; NetApp::Volume->_parse_vol_status_volume( indices => $indices, volume => $volume, line => $lines[0], ); ok( $volume->{name} eq 'cache_volume', "Parsed name correctly" ); ok( $volume->{state}->{online} == 1, "Parsed state correctly" ); foreach my $status ( qw( raid_dp flex ) ) { ok( $volume->{status}->{$status} == 1, "Parsed $status status correctly" ); } ok( $volume->{options}->{nosnap} eq 'off', "Parsed nosnap options correctly" ); ok( $volume->{options}->{nosnapdir} eq 'off', "Parsed nosnapdir options correctly" ); ok( $volume->{source}->{hostname} eq 'localhost', "Parsed source hostname correctly" ); ok( $volume->{source}->{volume} eq 'cache_source', "Parsed source volume correctly" ); NetApp::Volume->_parse_vol_status_volume( indices => $indices, volume => $volume, line => $lines[1], ); ok( $volume->{status}->{flexcache} == 1, "Parsed flexcache status correctly" ); ok( $volume->{options}->{minra} eq 'off', "Parsed nosnap options correctly" ); ok( $volume->{options}->{no_atime_update} eq 'off', "Parsed nosnapdir options correctly" ); NetApp-500.002/t/10_passive/11_volume_objects.t000644 067073 067073 00000006705 11120512056 021663 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; BEGIN { if ( not @NetApp::Test::filer_args ) { print "1..0 # Skip: No test filers defined\n"; exit 0; } } use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Aggregate; use NetApp::Volume; foreach my $filer_args ( @NetApp::Test::filer_args ) { ok( ref $filer_args eq 'HASH', 'filer_args entry is a HASH ref' ); my $filer = NetApp::Filer->new( $filer_args ); isa_ok( $filer, 'NetApp::Filer' ); print "# Running tests on filer " . $filer->get_hostname . "\n"; my @volume_names = $filer->get_volume_names; ok( @volume_names, "filer->get_volume_names" ); my @volumes = $filer->get_volumes; ok( @volumes, "filer->get_volumes" ); foreach my $volume ( @volumes ) { isa_ok( $volume, 'NetApp::Volume' ); isa_ok( $volume->get_filer, 'NetApp::Filer' ); isa_ok( $volume->get_plex, 'NetApp::Aggregate::Plex' ); foreach my $raidgroup ( $volume->get_plex->get_raidgroups ) { isa_ok( $raidgroup, 'NetApp::Aggregate::RAIDGroup' ); } if ( $volume->get_status( 'flex' ) ) { ok( $volume->get_size, 'volume->get_size' ); my $aggregate = $volume->get_aggregate; isa_ok( $aggregate, 'NetApp::Aggregate' ); my @aggr_volumes = $aggregate->get_volumes; ok( @aggr_volumes, "aggregate->get_volumes" ); foreach my $aggr_volume ( @aggr_volumes ) { isa_ok( $aggr_volume, 'NetApp::Volume' ); } my @volume_names = $aggregate->get_volume_names; ok( @volume_names, "aggregate->volume_names" ); foreach my $volume_name ( @volume_names ) { isa_ok( $aggregate->get_volume( $volume_name ), "NetApp::Volume" ); } } if ( $volume->get_clone_names ) { foreach my $clone ( $volume->get_clones ) { isa_ok( $clone, 'NetApp::Volume' ); } } if ( $volume->is_clone ) { ok( $volume->get_parent_name, 'volume->get_parent_name' ); isa_ok( $volume->get_parent, 'NetApp::Volume' ); } if ( $volume->get_status( 'flexcache' ) ) { isa_ok( $volume->get_source, 'NetApp::Volume::Source' ); } my @states = $volume->get_states; ok( @states, "volume->get_states" ); foreach my $state ( @states ) { ok( $volume->get_state( $state ), "volume->get_state($state)" ); } ok( ! $volume->get_state( 'bogus' ), 'volume->get_state(bogus) returns false' ); my @statuses = $volume->get_statuses; ok( @statuses, "volume->get_statuses" ); foreach my $status ( @statuses ) { ok( $volume->get_status( $status ), "volume->get_status($status)" ); } ok( ! $volume->get_status( 'bogus' ), 'volume->get_status(bogus) returns false' ); my @options = $volume->get_options; ok( @options, "volume->get_options" ); foreach my $option ( @options ) { ok( defined $volume->get_option( $option ), "volume->get_option($option)" ); } ok( ! defined $volume->get_option( 'bogus' ), 'volume->get_option(bogus) returns undef' ); } } NetApp-500.002/t/10_passive/15_qtree_parsing.t000644 067073 067073 00000002002 11113273352 021501 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Qtree; my @lines = split /\n/, <<__lines__; volume_name unix enabled normal 0 vfiler0 volume_name qtree_name unix enabled normal 1 vfiler0 __lines__ foreach my $index ( 0 .. 1 ) { my $qtree = NetApp::Qtree->_parse_qtree_status_qtree( $lines[$index] ); my $name = $index == 0 ? '/vol/volume_name' : '/vol/volume_name/qtree_name'; ok( $qtree->{name} eq $name, "Parsed name correctly" ); ok( $qtree->{security} eq 'unix', "Parsed security correctly" ); ok( $qtree->{oplocks} == 1, "Parsed oplocks correctly" ); ok( $qtree->{status} eq 'normal', "Parsed status correctly" ); ok( $qtree->{id} =~ /^\d$/, "Parsed id correctly" ); ok( $qtree->{vfiler} eq 'vfiler0', "Parsed vfiler correctly" ); } NetApp-500.002/t/10_passive/16_qtree_objects.t000644 067073 067073 00000011176 11120507636 021507 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; BEGIN { if ( not @NetApp::Test::filer_args ) { print "1..0 # Skipped: No test filers defined\n"; exit 0; } } use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Aggregate; use NetApp::Volume; use NetApp::Qtree; foreach my $filer_args ( @NetApp::Test::filer_args ) { ok( ref $filer_args eq 'HASH', 'filer_args entry is a HASH ref' ); my $filer = NetApp::Filer->new( $filer_args ); isa_ok( $filer, 'NetApp::Filer' ); print "# Running tests on filer " . $filer->get_hostname . "\n"; my @qtrees = $filer->get_qtrees; ok( @qtrees, 'filer->get_qtrees' ); foreach my $qtree ( @qtrees ) { isa_ok( $qtree, 'NetApp::Qtree' ); isa_ok( $qtree->get_filer, 'NetApp::Filer' ); my $volume_name = $qtree->get_volume_name; ok( $volume_name, 'qtree->get_volume_name' ); # $filer->_dump_volume_cache; my $volume0 = $qtree->get_volume; isa_ok( $volume0, 'NetApp::Volume' ); my $volume_name0 = $volume0->get_name; # $filer->_dump_volume_cache; my $volume = $qtree->get_volume; isa_ok( $volume, 'NetApp::Volume' ); my $volume_name1 = $volume->get_name; ok( $volume_name0 eq $volume_name1, 'cache returns the same object both times' ); # $filer->_dump_volume_cache; if ( $volume->get_status( 'flex' ) ) { isa_ok( $qtree->get_aggregate, 'NetApp::Aggregate' ); } my $name = $qtree->get_name; my $security = $qtree->get_security; my $oplocks = $qtree->get_oplocks; my $status = $qtree->get_status; my $id = $qtree->get_id; my $vfiler = $qtree->get_vfiler; ok( $name =~ m:^/vol/:, "qtree->get_name: $name" ); ok( $security =~ /^(unix|ntfs|mixed)$/, "qtree->get_security: $security" ); ok( $oplocks == 0 || $oplocks == 1, "qtree->get_oplocks: $oplocks" ); ok( $status =~ /^(normal|snap.*)$/, "qtree->get_status: $status" ); ok( $id =~ /^\d+$/, "qtree->get_id: $id" ); ok( $vfiler, "qtree->get_vfiler: $vfiler" ); } foreach my $aggregate ( $filer->get_aggregates ) { my $aggregate_name = $aggregate->get_name; # XXX: These are not supported correctly if ( $aggregate->get_status( 'trad' ) ) { print "# Skipping traditional aggregate $aggregate_name\n"; next; } my @volumes = $aggregate->get_volumes; if ( not @volumes ) { print "# Skipping aggregate $aggregate_name, it has no volumes\n"; next; } print "# Checking qtrees on $aggregate_name\n"; my @aggr_qtree_names = $aggregate->get_qtree_names; ok( @aggr_qtree_names, 'aggregate->get_qtree_names' ); my @aggr_qtrees = $aggregate->get_qtrees; ok ( @aggr_qtrees, 'aggregate->get_qtrees' ); ok( $#aggr_qtrees == $#aggr_qtree_names, 'same number of qtree objects and names in aggregate' ); foreach my $qtree_name ( @aggr_qtree_names ) { my $qtree = $aggregate->get_qtree( $qtree_name ); ok( ref $qtree && $qtree->isa('NetApp::Qtree'), "aggregate->get_qtree( $qtree_name )" ); } foreach my $volume ( @volumes ) { my $volume_name = $volume->get_name; if ( $volume->get_state('restricted') ) { print "# Skipping restricted volume $volume_name\n"; next; } print "# Checking qtrees on volume $volume_name\n"; my @vol_qtree_names = $volume->get_qtree_names; ok( @vol_qtree_names, 'volume->get_qtree_names' ); my @vol_qtrees = $volume->get_qtrees; ok( @vol_qtrees, 'volume->get_qtrees' ); ok( $#vol_qtrees == $#vol_qtree_names, 'same number of qtree objects and names in volume' ); foreach my $qtree_name ( @vol_qtree_names ) { my $qtree = $volume->get_qtree( $qtree_name ); ok( ref $qtree && $qtree->isa('NetApp::Qtree'), "volume->get_qtree( $qtree_name )" ); } my $vol_qtree = $volume->get_qtree; isa_ok( $vol_qtree, 'NetApp::Qtree' ); ok( ref $vol_qtree && $vol_qtree->get_name eq "/vol/" . $volume->get_name, 'volume->get_qtree returns the volume qtree' ); } } } NetApp-500.002/t/10_passive/20_snapmirror_parsing.t000644 067073 067073 00000004570 11113273352 022565 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Snapmirror; my @lines = split /\n/, <<__lines__; Source: source_hostname:source_volume Destination: destination_hostname:destination_volume Status: Transferring Progress: 0 KB State: Source Lag: 00:01:37 Mirror Timestamp: Wed Aug 13 12:58:01 EDT 2008 Base Snapshot: base_snapshot_name Current Transfer Type: - Current Transfer Error: - Contents: - Last Transfer Type: - Last Transfer Size: 1248 KB Last Transfer Duration: 00:00:44 Last Transfer From: - __lines__ my $snapmirror = {}; foreach my $index ( 0 .. $#lines ) { $snapmirror = NetApp::Snapmirror->_parse_snapmirror_status( snapmirror => $snapmirror, line => $lines[$index], ); } ok( ref $snapmirror->{source} eq 'HASH', 'source is a HASH ref' ); ok( $snapmirror->{source}->{hostname} eq 'source_hostname', 'source hostname is correct' ); ok( $snapmirror->{source}->{volume} eq 'source_volume', 'source volume is correct' ); ok( ref $snapmirror->{destination} eq 'HASH', 'destination is a HASH ref' ); ok( $snapmirror->{destination}->{hostname} eq 'destination_hostname', 'destination hostname is correct' ); ok( $snapmirror->{destination}->{volume} eq 'destination_volume', 'destination volume is correct' ); ok( $snapmirror->{status} eq 'Transferring', 'status is correct' ); ok( $snapmirror->{progress} eq '0 KB', 'progress is correct' ); ok( $snapmirror->{state} eq 'Source', 'state is correct' ); ok( $snapmirror->{lag} eq '00:01:37', 'lag is correct' ); ok( $snapmirror->{mirror_timestamp} eq 'Wed Aug 13 12:58:01 EDT 2008', 'mirror_timestamp is correct' ); ok( $snapmirror->{base_snapshot} eq 'base_snapshot_name', 'base_snapshot is correct' ); ok( $snapmirror->{last_transfer_size} eq '1248 KB', 'last_transfer_size is correct' ); ok( $snapmirror->{last_transfer_duration} eq '00:00:44', 'last_transfer_duration is correct' ); foreach my $key ( qw( current_transfer_type current_transfer_error contents last_transfer_type last_transfer_from ) ) { ok( $snapmirror->{$key} eq '', "$key is correct" ); } NetApp-500.002/t/10_passive/21_snapmirror_objects.t000644 067073 067073 00000006757 11120510007 022552 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; BEGIN { if ( not @NetApp::Test::filer_args ) { print "1..0 # Skipped: No test filers defined\n"; exit 0; } } use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Aggregate; use NetApp::Volume; use NetApp::Snapmirror; my @volume_names = (); foreach my $filer_args ( @NetApp::Test::filer_args ) { ok( ref $filer_args eq 'HASH', 'filer_args entry is a HASH ref' ); my $filer = NetApp::Filer->new( $filer_args ); isa_ok( $filer, 'NetApp::Filer' ); print "# Running tests on filer " . $filer->get_hostname . "\n"; my @snapmirrors = $filer->get_snapmirrors; @volume_names = (); foreach my $snapmirror ( @snapmirrors ) { test_snapmirror( snapmirror => $snapmirror, volume_names => 1, ); } foreach my $volume_name ( @volume_names ) { my $volume = $filer->get_volume( $volume_name ); isa_ok( $volume, 'NetApp::Volume' ); my @volume_snapmirrors = $volume->get_snapmirrors; ok( @volume_snapmirrors,'volume->get_snapmirrors returns list' ); foreach my $volume_snapmirror ( @volume_snapmirrors ) { test_snapmirror( snapmirror => $volume_snapmirror, ); } } } sub test_snapmirror { my (%args) = @_; my $snapmirror = $args{snapmirror}; isa_ok( $snapmirror, 'NetApp::Snapmirror' ); my $hostname = $snapmirror->get_filer->get_hostname; if ( my $source = $snapmirror->get_source ) { isa_ok( $source, 'NetApp::Snapmirror::Source' ); my $source_hostname = $source->get_hostname; ok( $source_hostname, "source->get_hostname: $source_hostname" ); my $source_volume = $source->get_volume; ok( $source_volume, "source->get_volume: $source_volume" ); if ( $args{volume_names} && same_hostname( $hostname, $source_hostname ) ) { push @volume_names, $source_volume; } } my $destination = $snapmirror->get_destination; isa_ok( $destination, 'NetApp::Snapmirror::Destination' ); my $dest_hostname = $destination->get_hostname; ok( $dest_hostname, "destination->get_hostname: $dest_hostname" ); my $dest_volume = $destination->get_volume; ok( $dest_volume, "destination->get_volume: $dest_volume" ); if ( $args{volume_names} && same_hostname( $hostname, $dest_hostname ) ) { push @volume_names, $dest_volume; } my @keys = qw( status progress state lag mirror_timestamp base_snapshot current_transfer_type current_transfer_error contents last_transfer_type last_transfer_size last_transfer_duration last_transfer_from ); foreach my $key ( @keys ) { my $method = "get_$key"; my $value = $snapmirror->$method; ok( defined $value, "snapmirror->$method: '$value'" ); } } # # Crude comparison of hostnames. If both are FQDNs, they must be an # exact match, otherwise, just compare the base hostnames. # sub same_hostname { my ($first,$second) = @_; if ( $first =~ /\./ && $second =~ /\./ ) { return $first eq $second; } else { ($first) = split( /\./, $first ); ($second) = split( /\./, $second ); return $first eq $second; } } NetApp-500.002/t/10_passive/25_snapshot_parsing.t000644 067073 067073 00000007441 11113273352 022235 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Snapshot; my $line = <<'__line__'; 28% (27%) 0% ( 0%) May 07 15:06 sv_hourly.0 __line__ my $snapshot = NetApp::Snapshot->_parse_snap_list( $line ); ok( $snapshot->{used} == 27, 'used value is correct: ' . $snapshot->{used} ); ok( $snapshot->{total} == 0, 'total value is correct: ' . $snapshot->{total} ); ok( $snapshot->{date} eq 'May 07 15:06', 'date value is correct: ' . $snapshot->{date} ); ok( $snapshot->{name} eq 'sv_hourly.0', 'name value is correct: ' . $snapshot->{name} ); my @lines = split /\n+/, <<'__lines__'; nightly.1 Active File System 596 1d 12:39 16.255 hourly.1 hourly.0 3672 0d 07:59 459.223 tempname hourly.0 72 2s 129600.000 __lines__ my $delta = NetApp::Snapshot::Delta->_parse_snap_delta( $lines[0] ); ok( $delta->{from} eq 'nightly.1', '1st from value is correct: ' . $delta->{from} ); ok( $delta->{to} eq 'active', '1st to value is correct: ' . $delta->{to} ); ok( $delta->{changed} == 596, '1st changed value is correct: ' . $delta->{changed} ); ok( $delta->{time} eq '1d 12:39', '1st time value is correct: ' . $delta->{time} ); ok( $delta->{rate} eq '16.255', '1st rate value is correct: ' . $delta->{rate} ); $delta = NetApp::Snapshot::Delta->_parse_snap_delta( $lines[1] ); ok( $delta->{from} eq 'hourly.1', '2nd from value is correct: ' . $delta->{from} ); ok( $delta->{to} eq 'hourly.0', '2nd to value is correct: ' . $delta->{to} ); ok( $delta->{changed} == 3672, '2nd changed value is correct: ' . $delta->{changed} ); ok( $delta->{time} eq '0d 07:59', '2nd time value is correct: ' . $delta->{time} ); ok( $delta->{rate} eq '459.223', '2nd rate value is correct: ' . $delta->{rate} ); $delta = NetApp::Snapshot::Delta->_parse_snap_delta( $lines[2] ); ok( $delta->{from} eq 'tempname', '2nd from value is correct: ' . $delta->{from} ); ok( $delta->{to} eq 'hourly.0', '2nd to value is correct: ' . $delta->{to} ); ok( $delta->{changed} == 72, '2nd changed value is correct: ' . $delta->{changed} ); ok( $delta->{time} eq '2s', '2nd time value is correct: ' . $delta->{time} ); ok( $delta->{rate} eq '129600.000', '2nd rate value is correct: ' . $delta->{rate} ); @lines = split /\n+/, <<'__lines__'; Volume one: 0 0 0 Volume two: 0 2 6@8,12,16,20 __lines__ my $schedule = NetApp::Snapshot::Schedule->_parse_snap_sched( $lines[0] ); ok( $schedule->{weekly} == 0, '1st weekly value is correct: ' . $schedule->{weekly} ); ok( $schedule->{daily} == 0, '1st daily value is correct: ' . $schedule->{daily} ); ok( $schedule->{hourly} == 0, '1st hourly value is correct: ' . $schedule->{hourly} ); ok( ref $schedule->{hourlist} eq 'ARRAY', '1st hourlist is an array ref' ); ok( scalar @{ $schedule->{hourlist} } == 0, '1st hourlist is empty' ); $schedule = NetApp::Snapshot::Schedule->_parse_snap_sched( $lines[1] ); ok( $schedule->{weekly} == 0, '2nd weekly value is correct: ' . $schedule->{weekly} ); ok( $schedule->{daily} == 2, '2nd daily value is correct: ' . $schedule->{daily} ); ok( $schedule->{hourly} == 6, '2nd hourly value is correct: ' . $schedule->{hourly} ); ok( ref $schedule->{hourlist} eq 'ARRAY', '2nd hourlist is an array ref' ); ok( scalar @{ $schedule->{hourlist} } == 4, '2nd hourlist has 4 elements' ); ok( $schedule->{hourlist}->[0] == 8 && $schedule->{hourlist}->[1] == 12 && $schedule->{hourlist}->[2] == 16 && $schedule->{hourlist}->[3] == 20, '2nd hourlist has the correct values: ' . join( ',', @{ $schedule->{hourlist} } ) ); NetApp-500.002/t/10_passive/26_snapshot_objects.t000644 067073 067073 00000012530 11120510041 022202 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; BEGIN { if ( not @NetApp::Test::filer_args ) { print "1..0 # Skipped: No test filers defined\n"; exit 0; } } use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Aggregate; use NetApp::Volume; use NetApp::Snapshot; my %tested = (); foreach my $filer_args ( @NetApp::Test::filer_args ) { ok( ref $filer_args eq 'HASH', 'filer_args entry is a HASH ref' ); %tested = (); my $filer = NetApp::Filer->new( $filer_args ); isa_ok( $filer, 'NetApp::Filer' ); print "# Running tests on filer " . $filer->get_hostname . "\n"; my @aggregates = $filer->get_aggregates; foreach my $aggregate ( @aggregates ) { test_parent( $aggregate ); my $aggregate_name = $aggregate->get_name; if ( $aggregate->get_status( 'trad' ) ) { print "# Skipping traditional aggregate $aggregate_name\n"; next; } my @volumes = $aggregate->get_volumes; foreach my $volume ( @volumes ) { my $volume_name = $volume->get_name; if ( $volume->get_status( 'offline' ) ) { print "# Skipping tests for offline volume $volume_name\n"; next; } if ( $volume->get_state('restricted') ) { print "# Skipping tests for restricted volume $volume_name\n"; next; } test_parent( $volume ); } } } sub test_parent { my $object = shift; my $object_class = ref $object; my $object_name = $object->get_name; my $filer_name = $object->get_filer->get_hostname; if ( exists $tested{$object_class} && $tested{$object_class} >= 3 ) { print "# Skipping further tests for $object_class on $filer_name\n"; return 1; } print "# Testing snapshot API for $object_class $object_name\n"; my $reserved = $object->get_snapshot_reserved; ok( defined $reserved, 'object->get_snapshot_reserved' ); my $schedule = $object->get_snapshot_schedule; isa_ok( $schedule, 'NetApp::Snapshot::Schedule' ); my $schedule_parent = $schedule->get_parent; ok( $schedule_parent->get_name eq $object->get_name, 'schedule parent name is correct' ); ok( $schedule->get_weekly =~ /^\d+$/, 'schedule->get_weekly correct: ' . $schedule->get_weekly ); ok( $schedule->get_daily =~ /^\d+$/, 'schedule->get_daily correct: ' . $schedule->get_daily ); ok( $schedule->get_hourly =~ /^\d+$/, 'schedule->get_hourly correct: ' . $schedule->get_hourly ); foreach my $hour ( $schedule->get_hourlist ) { ok( $hour =~ /^\d+$/, "hourlist value correct: $hour" ); } my @snapshots = $object->get_snapshots; foreach my $snapshot ( @snapshots ) { my $parent = $snapshot->get_parent; my $snapshot_name = $snapshot->get_name; if ( $snapshot_name =~ /\(\d+\)/ ) { print "# Skipping transient snapshot $snapshot_name\n"; next; } else { print "# Testing snapshot $object_name:$snapshot_name\n"; } ok( $parent->get_name eq $object->get_name, 'snapshot parent name is correct' ); ok( $snapshot->get_name, 'snapshot->get_name: ' . $snapshot->get_name ); ok( $snapshot->get_date =~ /^\S+\s+\d+\s+\d+:\d+$/, 'snapshot->get_date: ' . $snapshot->get_date ); ok( $snapshot->get_used =~ /^\d+$/, 'snapshot->get_used: ' . $snapshot->get_used ); ok( $snapshot->get_total =~ /^\d+$/, 'snapshot->get_total: ' . $snapshot->get_total ); # XXX: We're getting burned by transient snapshots... if ( $parent->isa("NetApp::Volume") ) { my $reclaimable = $snapshot->get_reclaimable; if ( defined $reclaimable ) { ok( $reclaimable =~ /^\d+$/, 'snapshot->get_reclaimable: ' . $reclaimable ); } } $tested{$object_class}++; my @deltas = $snapshot->get_snapshot_deltas; foreach my $delta ( @deltas ) { isa_ok( $delta, 'NetApp::Snapshot::Delta' ); if ( $delta->is_summary ) { ok( $delta->get_from eq $snapshot->get_name, 'summary delta from name matches snapshot name' ); } $tested{$object_class}++; } } my @deltas = $object->get_snapshot_deltas; my $found_summary = 0; foreach my $delta ( @deltas ) { my $from = $delta->get_from; my $to = $delta->get_to; my $changed = $delta->get_changed; my $time = $delta->get_time; my $rate = $delta->get_rate; ok( $from, "delta->get_from: $from" ); ok( $to, "delta->get_to: $to" ); ok( $changed =~ /^\d+$/, "delta->get_changed: $changed" ); ok( $time =~ /^\d+d\s+\d+:\d+$/ || $time =~ /^\d+s$/, "delta->get_time: $time" ); ok( $rate =~ /^[\d.]+$/, "delta->get_rate: $rate" ); if ( $delta->is_summary ) { $found_summary = 1; } } if ( @deltas ) { ok( $found_summary, 'found a summary delta in the list' ); $tested{$object_class}++; } } NetApp-500.002/t/10_passive/30_exports_parsing.t000644 067073 067073 00000006060 11113273352 022072 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; my @lines = split /\n+/, <<'__lines__'; /vol/volume1 -sec=sys,rw /vol/otherpath -actual=/vol/volume2,rw=a:b:c:d,root=e:f:g:h /vol/volume3 -sec=sec:krb5,ro,nosuid /vol/volume4 -sec=sys,ro=a:b:c:d __lines__ my $export = NetApp::Filer::Export->_parse_export( $lines[0] ); ok( $export->{path} eq '/vol/volume1', "1st entry has correct path: '$export->{path}'" ); ok( ref $export->{sec} eq 'ARRAY' && scalar @{ $export->{sec} } == 1 && $export->{sec}->[0] eq 'sys', "1st entry has correct sec value: '$export->{sec}'" ); ok( $export->{rw_all} == 1, "1st entry has correct rw_all value: '$export->{rw_all}'" ); if ( exists $export->{rw} ) { ok( 0, "1st entry has bogus rw value: '$export->{rw}'" ); } else { ok( 1, "1st entry does NOT have rw value at all" ); } $export = NetApp::Filer::Export->_parse_export( $lines[1] ); ok( $export->{path} eq '/vol/otherpath', "2nd entry has correct path: '$export->{path}'" ); ok( $export->{actual} eq '/vol/volume2', "2nd entry has correcy actual: '$export->{actual}'" ); ok( ref $export->{rw} eq 'ARRAY' && scalar @{ $export->{rw} } == 4 && $export->{rw}->[0] eq 'a' && $export->{rw}->[1] eq 'b' && $export->{rw}->[2] eq 'c' && $export->{rw}->[3] eq 'd', "2nd entry has correct rw value: '$export->{rw}'" ); ok( ref $export->{root} eq 'ARRAY' && scalar @{ $export->{root} } == 4 && $export->{root}->[0] eq 'e' && $export->{root}->[1] eq 'f' && $export->{root}->[2] eq 'g' && $export->{root}->[3] eq 'h', "2nd entry has correct rw value: '$export->{root}'" ); $export = NetApp::Filer::Export->_parse_export( $lines[2] ); ok( $export->{path} eq '/vol/volume3', "3rd entry has correct path: '$export->{path}'" ); ok( ref $export->{sec} eq 'ARRAY' && scalar @{ $export->{sec} } == 2 && $export->{sec}->[0] eq 'sec' && $export->{sec}->[1] eq 'krb5', "3rd entry has correct sec value: '$export->{sec}'" ); ok( $export->{ro_all} == 1, "3rd entry has correct ro_all value: '$export->{ro_all}'" ); if ( exists $export->{ro} ) { ok( 0, "3rd entry has bogus ro value: '$export->{ro}'" ); } else { ok( 1, "3rd entry does NOT have ro value at all" ); } ok( $export->{nosuid} == 1, "3rd entry has correct nosuid value: '$export->{nosuid}'" ); $export = NetApp::Filer::Export->_parse_export( $lines[3] ); ok( $export->{path} eq '/vol/volume4', "4th entry has correct path: '$export->{path}'" ); ok( ref $export->{ro} eq 'ARRAY' && scalar @{ $export->{ro} } == 4 && $export->{ro}->[0] eq 'a' && $export->{ro}->[1] eq 'b' && $export->{ro}->[2] eq 'c' && $export->{ro}->[3] eq 'd', "2nd entry has correct ro value: '$export->{ro}'" ); NetApp-500.002/t/10_passive/31_exports_objects.t000644 067073 067073 00000006447 11120512122 022057 0ustar00pmoorepmoore000000 000000 #!/usr/bin/env perl -w use strict; use warnings; use lib 'blib/lib'; use lib 't/lib'; use NetApp::Test; BEGIN { if ( not @NetApp::Test::filer_args ) { print "1..0 # Skip: No test filers defined\n"; exit 0; } } use Test::More qw( no_plan ); use Test::Exception; use Data::Dumper; use NetApp::Filer; use NetApp::Aggregate; use NetApp::Volume; foreach my $filer_args ( @NetApp::Test::filer_args ) { ok( ref $filer_args eq 'HASH', 'filer_args entry is a HASH ref' ); my $filer = NetApp::Filer->new( $filer_args ); isa_ok( $filer, 'NetApp::Filer' ); print "# Running tests on filer " . $filer->get_hostname . "\n"; my @exports = $filer->get_exports; ok( @exports, 'filer->get_exports' ); my %exports = map { $_ => 0 } qw( permanent temporary active inactive ); foreach my $export ( @exports ) { isa_ok( $export, 'NetApp::Filer::Export' ); isa_ok( $export->get_filer, 'NetApp::Filer' ); my $type = $export->get_type; ok( ( grep { $type eq $_ } qw( permanent temporary ) ), "export->get_type: '$type'" ); $exports{ $type }++; my $active = $export->get_active; ok( defined $active, "export->get_active: '$active'" ); $exports{ $active ? 'active' : 'inactive' }++; my $path = $export->get_path; ok( $path =~ qr{^/vol/}, "export->get_path: '$path'" ); my $actual = $export->get_actual; if ( $actual ) { ok( $actual =~ qr{^/vol/}, "export->get_actual: '$actual'" ); } my $nosuid = $export->get_nosuid; ok( defined $nosuid, "export->get_nosuid: '$nosuid'" ); foreach my $sec ( $export->get_sec ) { ok( ( grep { $sec eq $_ } qw( none sys krb5 krb5i krb5p ) ), "export->get_sec value: '$sec'" ); } foreach my $root ( $export->get_root ) { ok( defined $root, "export->get_root value: '$root'" ); } if ( $export->get_rw_all ) { if ( my $rw = join ':', $export->get_rw ) { ok( 0, "export->get_rw returns bogus value: '$rw'" ); } else { ok( 1, "export->get_rw returns nothing" ); } } if ( $export->get_ro_all ) { if ( my $ro = join ':', $export->get_ro ) { ok( 0, "export->get_ro returns bogus value: '$ro'" ); } else { ok( 1, "export->get_ro returns nothing" ); } } } my @permanent = $filer->get_permanent_exports; my @temporary = $filer->get_temporary_exports; my @active = $filer->get_active_exports; my @inactive = $filer->get_inactive_exports; ok( $exports{permanent} == scalar @permanent, "filer->get_permanent_exports scalar value: " . ($#permanent+1) ); ok( $exports{temporary} == scalar @temporary, "filer->get_temporary_exports scalar value: " . ($#temporary+1) ); ok( $exports{active} == scalar @active, "filer->get_active_exports scalar value: " . ($#active+1) ); ok( $exports{inactive} == scalar @inactive, "filer->get_inactive_exports scalar value: " . ($#inactive+1) ); } NetApp-500.002/lib/NetApp/000755 067073 067073 00000000000 11763415704 015704 5ustar00pmoorepmoore000000 000000 NetApp-500.002/lib/NetApp.pm000644 067073 067073 00000000431 11763415445 016242 0ustar00pmoorepmoore000000 000000 package NetApp; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use English; use Carp; use NetApp::Filer; use NetApp::Aggregate; use NetApp::Volume; use NetApp::Qtree; use NetApp::Snapmirror; use NetApp::Snapshot; 1; NetApp-500.002/lib/NetApp/Aggregate/000755 067073 067073 00000000000 11763415704 017572 5ustar00pmoorepmoore000000 000000 NetApp-500.002/lib/NetApp/Aggregate.pm000644 067073 067073 00000033421 11763415465 020137 0ustar00pmoorepmoore000000 000000 package NetApp::Aggregate; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use English; use Carp; use Class::Std; use Params::Validate qw( :all ); use Regexp::Common; use NetApp::Aggregate::Plex; use NetApp::Aggregate::RAIDGroup; { my %filer_of :ATTR( get => 'filer' ); my %name_of :ATTR( get => 'name' ); my %state_of :ATTR; my %status_of :ATTR; my %options_of :ATTR; my %volumes_of :ATTR; my %plex_of :ATTR( get => 'plex' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { filer => { isa => 'NetApp::Filer' }, name => { type => SCALAR }, state => { type => HASHREF }, status => { type => HASHREF }, options => { type => HASHREF }, volumes => { type => HASHREF }, plex => { type => HASHREF }, }); $filer_of{$ident} = $args{filer}; $name_of{$ident} = $args{name}; $state_of{$ident} = $args{state}; $status_of{$ident} = $args{status}; $options_of{$ident} = $args{options}; $volumes_of{$ident} = $args{volumes}; $plex_of{$ident} = NetApp::Aggregate::Plex->new( $args{plex} ); } sub get_states { return keys %{ $state_of{ident shift} }; } sub get_state { my $self = shift; my $ident = ident $self; my $state = shift; return $state_of{$ident}->{$state}; } sub get_statuses { # Stati? Oh, hell no... return keys %{ $status_of{ident shift} }; } sub get_status { my $self = shift; my $ident = ident $self; my $status = shift; return $status_of{$ident}->{$status}; } sub get_options { return keys %{ $options_of{ident shift} }; } sub get_option { my $self = shift; my $ident = ident $self; my $option = shift; if ( exists $options_of{$ident}->{$option} ) { return $options_of{$ident}->{$option}; } else { return undef; } } sub set_option { my $self = shift; my $option = shift; my $value = shift; my $ident = ident $self; my $name = $self->get_name; my @command = ( qw(aggr options), $name, $option, $value ); $self->get_filer->_run_command( command => @command ); $options_of{$ident}->{$option} = $value; return 1; } sub get_volume_names { return keys %{ $volumes_of{ident shift} }; } sub get_volumes { my $self = shift; my @volumes = (); foreach my $volume ( $self->get_volume_names ) { push @volumes, $self->get_filer->get_volume( $volume ); } return @volumes; } sub get_volume { my $self = shift; my $ident = ident $self; my $name = shift; if ( not exists $volumes_of{$ident}->{$name} ) { croak( "No such volume $name in aggregate ", $self->get_name, "\n", ); } return $self->get_filer->get_volume( $name ); } sub create_volume { my $self = shift; my (%args) = validate( @_, { name => { type => SCALAR }, size => { type => SCALAR }, space => { type => SCALAR, regexp => qr{^(none|filer|volume)$}, optional => 1 }, language => { type => SCALAR, optional => 1 }, source_filer => { type => SCALAR, depends => [qw( source_volume )], optional => SCALAR }, source_folume => { type => SCALAR, depends => [qw( source_filer )], optional => 1 }, }); if ( ref $args{source_filer} && $args{source_filer}->isa("NetApp::Filer") ) { $args{source_filer} = $args{source_filer}->get_hostname; } if ( ref $args{source_volume} && $args{source_volume}->isa("NetApp::Volume") ) { $args{source_volume} = $args{source_volume}->get_name; } if ( $args{source_filer} && ( $args{space} || $args{language} ) ) { croak( "Mutually exclusive options: space and/or language may not\n", "be specified when source_filer/source_volume are given.\n", ); } my @command = ( qw( vol create ), $args{name} ); if ( $args{language} ) { push @command, '-l', $args{language}; } if ( $args{space} ) { push @command, '-s', $args{space}; } push @command, $self->get_name, $args{size}; if ( $args{source_filer} ) { push @command, '-S', join( ':', $args{source_filer}, $args{source_volume} ); } $self->get_filer->_run_command( command => \@command ); return $self->get_filer->get_volume( name => $args{name} ); } sub destroy_volume { my $self = shift; my $ident = ident $self; my (%args) = validate( @_, { name => { type => SCALAR }, }); my $aggrname = $self->get_name; if ( not $volumes_of{$ident}->{$args{name}} ) { croak("No such volume $args{name} in aggregate $aggrname\n"); } $self->get_filer->_run_command( command => [qw(vol destroy), $args{name}, '-f'], ); delete $volumes_of{$ident}->{$args{name}}; return 1; } sub get_qtree_names { my $self = shift; return map { $_->get_name } $self->get_qtrees; } sub get_qtree { my $self = shift; my $name = shift; return $self->get_filer->get_qtree( $name ); } sub get_qtrees { my $self = shift; my @qtrees = (); foreach my $volume ( $self->get_volumes ) { push @qtrees, $volume->get_qtrees; } return @qtrees; } sub get_snapshots { return NetApp::Snapshot->_get_snapshots( parent => shift ); } sub get_snapshot { my $self = shift; my ($name) = validate_pos( @_, { type => SCALAR } ); return grep { $_->get_name eq $name } $self->get_snapshots; } sub create_snapshot { my $self = shift; my ($name) = validate_pos( @_, { type => SCALAR } ); return NetApp::Snapshot->_create_snapshot( parent => $self, name => $name, ); } sub delete_snapshot { my $self = shift; my ($name) = validate_pos( @_, { type => SCALAR } ); return NetApp::Snapshot->_delete_snapshot( parent => $self, name => $name, ); } sub get_snapshot_deltas { return NetApp::Snapshot->_get_snapshot_deltas( parent => shift ); } sub get_snapshot_reserved { return NetApp::Snapshot->_get_snapshot_reserved( parent => shift ); } sub set_snapshot_reserved { my $self = shift; my ($reserved) = validate_pos( @_, { type => SCALAR } ); return NetApp::Snapshot->_set_snapshot_reserved( parent => $self, reserved => $reserved, ); } sub get_snapshot_schedule { return NetApp::Snapshot->_get_snapshot_schedule( parent => shift, @_ ); } sub set_snapshot_schedule { return NetApp::Snapshot->_set_snapshot_schedule( parent => shift, @_ ); } sub rename { my $self = shift; my $ident = ident $self; my (%args) = validate( @_, { newname => { type => SCALAR }, }); my $oldname = $self->get_name; $self->get_filer->_run_command( command => [qw(aggr rename), $oldname, $args{newname}], ); $name_of{$ident} = $args{newname}; return 1; } sub offline { my $self = shift; my $ident = ident $self; my (%args) = validate( @_, { cifsdelaytime => { type => SCALAR, optional => 1 }, }); my @command = ( qw(aggr offline), $self->get_name ); if ( $args{cifsdelaytime} ) { push @command, '-t', $args{cifsdelaytime}; } $self->get_filer->_run_command( command => \@command, ); delete $state_of{$ident}->{online}; delete $state_of{$ident}->{restricted}; $state_of{$ident}->{offline} = 1; return 1; } sub online { my $self = shift; my $ident = ident $self; my (%args) = validate( @_, { force => { type => SCALAR, optional => 1 }, }); my @command = ( qw( aggr online ), $self->get_name ); if ( $args{force} ) { push @command, '-f'; } $self->get_filer->_run_command( command => \@command, ); delete $state_of{$ident}->{offline}; delete $state_of{$ident}->{restricted}; $state_of{$ident}->{online} = 1; return 1; } sub restrict { my $self = shift; my $ident = ident shift; my (%args) = validate( @_, { cifsdelaytime => { type => SCALAR, optional => 1 }, }); my @command = ( qw(aggr restrict), $self->get_name ); if ( $args{cifsdelaytime} ) { push @command, '-t', $args{cifsdelaytime}; } $self->get_filer->_run_command( command => \@command, ); delete $state_of{$ident}->{offline}; delete $state_of{$ident}->{online}; $state_of{$ident}->{restricted} = 1; return 1; } } # Class methods for parsing aggr command output sub _parse_aggr_status_headers { my $class = shift; my $header = shift; my $indices = {}; my $index = 0; my ($aggr) = ( $header =~ /(^\s+Aggr\s+)/ ) or croak( "Unable to match 'Aggr' column header\n" ); $indices->{aggr} = [ 0, length($aggr) ]; $index += length($aggr); my ($state) = ( $header =~ /(State\s+)/ ) or croak( "Unable to match 'State' column header\n" ); $indices->{state} = [ $index, length($state) ]; $index += length($state); my ($status) = ( $header =~ /(Status\s+)/ ) or croak( "Unable to match 'Status' column header\n" ); $indices->{status} = [ $index, length($status) ]; $index += length($status); $indices->{options} = [ $index ]; return $indices; } sub _parse_aggr_status_aggregate { my $class = shift; my %args = validate( @_, { indices => { type => HASHREF }, line => { type => SCALAR }, aggregate => { type => HASHREF, default => {}, optional => 1 }, }); my $indices = $args{indices}; my $aggregate = $args{aggregate}; my $line = $args{line}; if ( $line =~ m{Volumes: } ) { return $aggregate; } foreach my $column ( qw( aggr state status options ) ) { my $value = ""; if ( $indices->{$column}->[1] ) { $value = substr( $line, $indices->{$column}->[0], $indices->{$column}->[1] ); } else { $value = substr( $line, $indices->{$column}->[0] ); } $value =~ s/$RE{ws}{crop}//g; if ( $column eq 'aggr' ) { if ( $value ) { $aggregate->{name} = $value; my ($name) = split( /\s+/, $line ); if ( length($name) > length($value) ) { $aggregate->{name} = $name; $line =~ s/^$name/$value/; } } } else { foreach my $entry ( split( /[,\s]+/, $value ) ) { my ($key,$value); if ( $entry =~ /=/ ) { ($key,$value) = split( /=/, $entry, 2 ); } else { ($key,$value) = ($entry,1); } $aggregate->{$column}->{$key} = $value; } } } return $aggregate; } sub _parse_aggr_status_volumes { my $class = shift; my %args = validate( @_, { volumes => { type => HASHREF }, line => { type => SCALAR }, }); my $volumes = $args{volumes}; my $line = $args{line}; $line =~ s/Volumes://g; $line =~ s/$RE{ws}{crop}//g; $line =~ s/,//g; foreach my $volume ( split( /\s+/, $line ) ) { $volumes->{$volume}++; } return 1; } sub _parse_aggr_status_plex { my $class = shift; my $line = shift; $line =~ s/$RE{ws}{crop}//g; my ($name,$state) = ( $line =~ m{Plex\s+(\S+): (.*)} ) or croak( "Unable to parse Plex name and state:\n$line\n" ); return { name => $name, state => { map { $_ => 1 } split( /[,\s]+/, $state ) }, }; } sub _parse_aggr_status_raidgroup { my $class = shift; my $line = shift; $line =~ s/$RE{ws}{crop}//g; my ($name,$state) = ( $line =~ m{RAID group\s+(\S+): (.*)} ) or croak( "Unable to parse RAIDGroup name and state:\n$line\n" ); return { name => $name, state => { map { $_ => 1 } split( /[,\s]+/, $state ) }, }; } 1; NetApp-500.002/lib/NetApp/Aggregate.pod000644 067073 067073 00000015646 11113273352 020300 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Aggregate -- OO class for creating and managing NetApp filer aggregates =head1 SYNOPSIS use NetApp::Filer; use NetApp::Aggregate; my $filer = NetApp::Filer->new({ .... }); my @aggregate_names = $filer->get_aggregate_names; my @aggregates = $filer->get_aggregates; my $aggregate = $filer->get_aggregate( 'aggr01' ); =head1 DESCRIPTION This class encapsulates a single NetApp filer aggregate, and provides methods for querying information about the aggregate and it's sub-objects (eg. volumes), as well as methods for managing the aggregate itself. =head1 INSTANCE METHODS =head2 General Instance Methods =head3 get_filer Returns the NetApp::Filer object representing the filer on which the aggregate exists. =head3 get_name Returns the name of the aggregate as a string. =head3 get_states, get_statuses, get_options Each of these methods returns a list of strings, each of which represents a single state, status, or option for the aggregate. NOTE: All you English grammar pluralization rules fanatics can give up trying to convince the author to call that one method get_stati. =head3 get_state( $state ), get_status( $status ), get_option( $option ) Each of these methods returns the value for the specified state, status or option. If that particular key wasn't present, then this method will return undef. This makes it easy to tell the difference between a key that doesn't exist, and one that has a false value. =head3 get_plex Returns the NetApp::Aggregate::Plex object representing the plex on which the aggregate lives. =head2 Volume Specific Methods =head3 get_volume_names Returns a list of the volume names which are contained within this aggregate. =head3 get_volumes Returns a list of NetApp::Volume objects, each of which represents one of the volumes in the aggregate. =head3 get_volume( $name ) Returns a single NetApp::Volume object representing the specified volume. If that volume doesn't exist on the aggregate, then a fatal exception is raised. =head3 create_volume( %args ) This method creates a flexible volume in the aggregate, and returns the NetApp::Volume object representing the new volume. The arguments are as follows. All values are simple strings, unless otherwise noted. $aggregate->create_volume( # Required arguments name => $name, size => $size, # Optional arguments space => 'none' | 'file' | 'volume', language => $language, source_filer => $source_filer, source_volume => $source_volume, ); Both the source_filer and source_volume arguments must be given when creating a flexcache volume. The space and language arguments may not be specified with the source_filer/source_volume arguments. =head3 destroy_volume( %args ) Destroys the specified volume. Note that since this API is not designed to be used interactively, the -f (force) argument is always used. Be sure you really want to destroy the volume, programatically. $aggregate->destroy_volume( # Required argument name => $name, ); The $name must be a string, and it must be one of the volumes in the $aggregate. =head2 Qtree Specific Methods =head3 get_qtree_names Returns a list of strings, each of which is the name of a qtree on the aggregate. =head3 get_qtrees Returns a list of NetApp::Qtree objects, each of which represents a single qtree on the aggregate. =head3 get_qtree( $name ) Returns a single NetApp::Qtree object for the specified qtree name. The name must in the form of a pathname, for example: /vol/volume_name/qtree_name The qtree_name is optional if querying the object for a volume's qtree. This method simply returns nothing if the specified qtree doesn't exist on the aggregate. =head2 Snapshot Specific Methods =head3 get_snapshots Returns a list of NetApp::Snapshot objects for each of the snapshots of the aggregate. =head3 get_snapshot( $name ) Returns a single NetApp::Snapshot object matching the specified name, if it exists for the aggregate. =head3 create_snapshot( $name ) Creates a snapshot of the aggregate with the specified name. =head3 delete_snapshot( $name ) Deletes a snapshot of the aggregate with the specified name. =head3 get_snapshot_deltas Returns a list of NetApp::Snapshot::Delta objects for each snapshot delta for the aggregate. =head3 get_snapshot_reserved Returns a string representing the amount of reserved space, as a percentage. This string does NOT include the % sign. =head3 set_snapshot_reserved( $percentage ) Sets the snapshot reserved space to the specified percentage, which should also NOT include the % sign. =head3 get_snapshot_schedule Returns a NetApp::Snapshot::Schedule object representing the snapshot schedule for the aggregate. =head3 set_snapshot_schedule( %args ) Sets the snapshot schedule for the aggregate based on the arguments passed. The argument syntax is: $aggregate->set_snapshot_schedule( weekly => $weekly, daily => $daily, hourly => $hourly, hourlist => [ $hour1, $hour2, $hour3, .... ], ); =head1 TO BE IMPLEMENTED NOTE: Currently, all of the following methods have yet to be implemented, but will be soon. This documentation serves as a guideline for how to implement the perl API for each associates CLI function. =head2 NetApp::Aggregate->create( ... ) my $aggregate = NetApp::Aggregate->create( # Required arguments filer => $filer, # NetApp::Filer object name => $aggregate_name, # Required but mutually exclusive arguments # Either 'disks' OR 'diskcount and/or disksize' disks => [ [ $disk1, $disk2, .... ], [ $diskn, $diskn+1, .... ], ], diskcount => $diskcount, disksize => $disksize, # Optional arguments raidtype => 'raid0' | 'raid4' | 'raid-dp', raidsize => $raidsize, disktype => 'ATA' | 'FCAL' | 'LUN' | 'SAS' | 'SATA' | 'SCSI', rpm => $rpm, mirrored => $boolean, ); =head2 $aggregate->add( ... ) $aggregate->add( # Required arguments name => $aggregate_name, # Required but mutually exclusive arguments # Either 'disks' OR 'diskcount and/or disksize' disks => [ [ $disk1, $disk2, .... ], [ $diskn, $diskn+1, .... ], ], diskcount => $diskcount, disksize => $disksize, # Optional arguments raidgroup => $raidgroup, force => 1, ); =head2 $aggregate->destroy() NOTE: This always uses the -force option, since this API is not interactive. =head2 $aggregate->offline() $aggregate->offline( # Optional arguments cifsdelaytime => $cifsdelaytime, ); =head2 $aggregate->online() NOTE: It is unclear whether or not we should always imply -f (force => 1), or whether we should treat the prompted scenario as an error, and raise an exception. Since forcing an aggregate online can result in data loss when -f is used, perhaps we should force that state to be cleaned up first. =head2 $aggregate->rename( $newname ) =head2 $aggregate->restrict( ... ) $aggregate->restrict( # Optional arguments cifsdelaytime => $cifsdelaytime, ); =cut NetApp-500.002/lib/NetApp/Filer/000755 067073 067073 00000000000 11763415704 016745 5ustar00pmoorepmoore000000 000000 NetApp-500.002/lib/NetApp/Filer.pm000644 067073 067073 00000070077 11763415473 017321 0ustar00pmoorepmoore000000 000000 package NetApp::Filer; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use English; use Carp; use Class::Std; use Params::Validate qw( :all ); use IPC::Cmd qw( run ); use Regexp::Common; use Net::Telnet; use Clone qw(clone); use Data::Dumper; use Memoize; use NetApp::Filer::TimeoutCache; use NetApp::Filer::Version; use NetApp::Filer::License; use NetApp::Filer::Option; use NetApp::Filer::Export; { my %hostname_of :ATTR( get => 'hostname' ); my %username_of :ATTR( get => 'username' ); my %protocol_of :ATTR; my %ssh_identity_of :ATTR; my %ssh_command_of :ATTR; my %telnet_password_of :ATTR; my %telnet_timeout_of :ATTR; my %telnet_session_of :ATTR; my %telnet_session_by; # NOT an ATTR. Keyed on hostname/username my %command_status_of :ATTR; my %command_error_of :ATTR; my %command_stdout_of :ATTR; my %command_stderr_of :ATTR; my %version_of :ATTR( get => 'version' ); my %cache_enabled_of :ATTR; my %cache_of :ATTR; my %snapmirror_state_of :ATTR; sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { hostname => { type => SCALAR, }, username => { type => SCALAR, default => 'root', optional => 1, }, protocol => { type => SCALAR, regex => qr{^(ssh|telnet)$}, default => 'ssh', optional => 1, }, telnet_password => { type => SCALAR, optional => 1, }, telnet_timeout => { type => SCALAR, default => 60, optional => 1, }, ssh_identity => { type => SCALAR, optional => 1, }, ssh_command => { type => ARRAYREF, default => [qw( ssh )], optional => 1, }, cache_enabled => { type => SCALAR, default => 0, optional => 1, }, cache_expiration => { type => SCALAR, default => 10, optional => 1, }, }); $hostname_of{$ident} = $args{hostname}; $username_of{$ident} = $args{username}; $protocol_of{$ident} = $args{protocol}; $command_stdout_of{$ident} = []; $command_stderr_of{$ident} = []; if ( $protocol_of{$ident} eq 'ssh' ) { if ( $args{telnet_password} ) { $telnet_password_of{$ident} = $args{telnet_password}; } $ssh_command_of{$ident} = clone $args{ssh_command}; if ( $args{ssh_identity} ) { if ( not -f $args{ssh_identity} ) { croak("No such ssh_identity file: $args{ssh_identity}\n"); } $ssh_identity_of{$ident} = $args{ssh_identity}; push( @{ $ssh_command_of{$ident} }, '-i', $ssh_identity_of{$ident} ); } push( @{ $ssh_command_of{$ident} }, '-l', $username_of{$ident}, $hostname_of{$ident} ); } else { $telnet_timeout_of{$ident} = $args{telnet_timeout}; $telnet_password_of{$ident} = $args{telnet_password}; $telnet_session_by{ $args{hostname}, $args{username} } ||= $self->_telnet_connect(); $telnet_session_of{$ident} = $telnet_session_by{ $args{hostname}, $args{username} }; } $self->_run_command( command => [qw( version )], ); my @stdout = $self->_get_command_stdout; $version_of{$ident} = NetApp::Filer::Version->new({ string => $stdout[0], }); $cache_enabled_of{$ident} = $args{cache_enabled}; return 1 if not $args{cache_enabled}; $cache_of{$ident} = { get_aggregate => {}, get_volume => {}, get_qtree => {}, }; foreach my $method ( keys %{ $cache_of{$ident} } ) { if ( $args{cache_expiration} ) { tie %{ $cache_of{$ident}->{$method} }, 'NetApp::Filer::TimeoutCache', lifetime => $args{cache_expiration}; memoize( $method, SCALAR_CACHE => [ HASH => $cache_of{$ident}->{$method} ], LIST_CACHE => 'MERGE', ); } else { memoize $method; } } } sub _telnet_connect { my $self = shift; my $ident = ident $self; my $timeout = $telnet_timeout_of{$ident}; my $hostname = $hostname_of{$ident}; my $username = $username_of{$ident}; my $password = $telnet_password_of{$ident}; my $session = Net::Telnet->new( Timeout => $timeout, Prompt => '/> |\*> /', ); if ( $ENV{NETAPP_TELNET_DEBUG} ) { $session->input_log('/var/tmp/netapp-telnet-debug.log'); } $session->open( $hostname ); $session->waitfor('/login:/'); $session->print( $username ); $session->waitfor('/Password:/'); $session->print( $password ); eval { $session->waitfor( $session->prompt ) }; if ( $@ ) { croak( "Unable to authenticate to $hostname: $@\n" ); } return $session; } sub _run_command { my $self = shift; my $ident = ident $self; my $protocol = $protocol_of{$ident}; if ( $protocol eq 'ssh' ) { return $self->_run_ssh_command(@_); } else { return $self->_run_telnet_command(@_); } } sub _run_telnet_command { my $self = shift; my $ident = ident $self; my %args = validate( @_, { command => { type => ARRAYREF }, nonfatal => { type => SCALAR, optional => 1 }, }); my @command = (); foreach my $argument ( @{ $args{command} } ) { if ( $argument =~ /[()]/ ) { push @command, qq{'$argument'}; } else { push @command, $argument; } } my $command = join(" ",@command); my @results; eval { @results = $telnet_session_of{$ident}->cmd($command); }; my $error = $@; if ( $error ) { croak( "Remote telnet command execution failed!!\n", "Command: $command\n", "Error: $error\n", ); } chomp @results; my @stdout = (); my @stderr = (); # XXX: Get rid of the command we sent, which will be the first # line in the results, and the part of the prompt that we # don't pattern match, which will be the last line. This # keeps getting uglier.... Sometimes the command is NOT the # first line of output... if ( $results[0] =~ /$command/ ) { shift @results; } pop @results; my $command_first = $command[0]; my $command_second = $command[1] || ''; foreach my $result ( @results ) { # XXX: OK, this may get out of hand, but this assumption # is not always correct. We have found at least one case # where a non-error is prefixed with the command name. If # we have to add a lot of exceptions here, we'll need a # more scalable solution. # # OK, we have two now.... Using telnet sucks.... # # Yep... This is starting to get ugly.... if ( $result =~ /^snap reclaimable: Approximately/ ) { push @stdout, $result; } elsif ( $result =~ /^vol size: .* has size/ ) { push @stdout, $result; } elsif ( $result =~ /^snap delta: No snapshots exist/ ) { push @stdout, $result; } elsif ( $result =~ /^$command_first:/ || $result =~ /^$command_first $command_second:/ ) { push @stderr, $result; } else { push @stdout, $result; } } $command_stdout_of{$ident} = [ @stdout ]; $command_stderr_of{$ident} = [ @stderr ]; if ( @stderr ) { $command_status_of{$ident} = 0; if ( ! $args{nonfatal} ) { my $hostname = $self->get_hostname; croak( "Error running '$command' via telnet on $hostname:\n", @stderr, ); } } else { $command_status_of{$ident} = 1; } return $command_status_of{$ident}; } sub _run_ssh_command { my $self = shift; my $ident = ident $self; my %args = validate( @_, { command => { type => ARRAYREF }, nonfatal => { type => SCALAR, optional => 1 }, }); my $command = join(" ",@{ $args{command} }); my @command = @{ $self->_get_ssh_command }; foreach my $argument ( @{ $args{command} } ) { if ( $argument =~ /[()]/ ) { push @command, qq{'$argument'}; } else { push @command, $argument; } } my @results = run( command => \@command ); my $full_command = join(" ",@command); $command_status_of{$ident} = $results[0]; $command_error_of{$ident} = $results[1]; my $stdout = join( '', @{ $results[3] } ); $command_stdout_of{$ident} = [ split( /\n/, $stdout ) ]; my $stderr = join( '', @{ $results[4] } ); $command_stderr_of{$ident} = [ split( /\n/, $stderr ) ]; if ( not $command_status_of{$ident} ) { croak( "Remote ssh command execution failed!!\n", "Command: $full_command\n", "Command_Error code: $command_error_of{$ident}\n", "STDERR: $stderr\n", ); } if ( $stderr && ! $args{nonfatal} ) { my $hostname = $self->get_hostname; croak( "Error running '$command' via ssh on $hostname:\n", $stderr, ); } return $command_status_of{$ident}; } sub _get_command_stdout { return @{ $command_stdout_of{ident shift} }; } sub _get_command_stderr { return @{ $command_stderr_of{ident shift} }; } sub _get_command_status { return $command_status_of{ident shift}; } sub _get_command_error { return $command_error_of{ident shift}; } sub _get_ssh_command { return $ssh_command_of{ident shift}; } sub _clear_cache { my $self = shift; my $ident = ident $self; my (%args) = validate( @_, { method => { type => SCALAR }, key => { type => SCALAR, optional => 1 }, }); if ( not $cache_enabled_of{$ident} ) { return 1; } if ( not exists $cache_of{$ident}->{ $args{method} } ) { croak("Invalid argument: $args{method} is not cached\n"); } if ( $args{key} ) { # XXX: The keys might be more complex than this... delete $cache_of{$ident}->{ $args{method} }->{ $args{key} }; } else { %{ $cache_of{$ident}->{ $args{method} } } = (); } return 1; } sub get_licenses { my $self = shift; $self->_run_command( command => [qw( license )], ); my @stdout = $self->_get_command_stdout; my @licenses = (); while ( my $line = shift @stdout ) { next if $line =~ /not licensed/; my $license = $self->_parse_license( $line ); push @licenses, NetApp::Filer::License->new( $license ); } return @licenses; } sub get_license { my $self = shift; my $service = shift; return grep { $_->get_service eq $service } $self->get_licenses; } sub add_license { my $self = shift; my $code = shift; return $self->_run_command( command => [qw(license add), $code ], ); } sub delete_license { my $self = shift; my $service = shift; return $self->_run_command( command => [qw(license delete), $service ], ); } sub get_options { my $self = shift; $self->_run_command( command => ['options'], ); my @stdout = $self->_get_command_stdout; my @options = (); while ( my $line = shift @stdout ) { my $option = $self->_parse_option( $line ); push @options, NetApp::Filer::Option->new ( $option ); } return @options; } sub get_aggregate_names { my $self = shift; $self->_run_command( command => [qw( aggr status )], ); my @stdout = $self->_get_command_stdout; my $indices = NetApp::Aggregate->_parse_aggr_status_headers( shift @stdout ); my @names = (); while ( my $line = shift @stdout ) { my $data = NetApp::Aggregate->_parse_aggr_status_aggregate( indices => $indices, line => $line, ); if ( $data->{name} ) { push( @names, $data->{name} ); } } return @names; } sub get_aggregates { my $self = shift; my @aggregates = (); foreach my $name ( $self->get_aggregate_names ) { push @aggregates, $self->get_aggregate( $name ); } return @aggregates; } sub get_aggregate { my $self = shift; my $name = shift; $self->_run_command( command => [qw( aggr status ), $name, '-v' ], ); my @stdout = $self->_get_command_stdout; my $indices = NetApp::Aggregate->_parse_aggr_status_headers( shift @stdout ); my $aggregate = {}; while ( my $line = shift @stdout ) { last if $line =~ /^\s+$/; NetApp::Aggregate->_parse_aggr_status_aggregate( indices => $indices, aggregate => $aggregate, line => $line, ); } my $volumes = {}; if ( $aggregate->{status}->{aggr} ) { while ( my $line = shift @stdout ) { last if $line =~ /^\s+$/; NetApp::Aggregate->_parse_aggr_status_volumes( volumes => $volumes, line => $line, ); } } my $plex = NetApp::Aggregate->_parse_aggr_status_plex( shift @stdout ); while ( my $line = shift @stdout ) { last if $line =~ /^\s+$/; push @{ $plex->{raidgroups} }, NetApp::Aggregate->_parse_aggr_status_raidgroup( $line ); } return NetApp::Aggregate->new({ filer => $self, %$aggregate, volumes => $volumes, plex => $plex, }); } sub create_aggregate { my $self = shift; my (%args) = validate( @_, { name => { type => SCALAR }, raidtype => { type => SCALAR, optional => 1 }, raidsize => { type => SCALAR, optional => 1 }, disktype => { type => SCALAR, optional => 1 }, diskcount => { type => SCALAR, optional => 1 }, disksize => { type => SCALAR, depends => [qw( diskcount )], optional => 1 }, rpm => { type => SCALAR, optional => 1 }, language => { type => SCALAR, optional => 1 }, snaplock => { type => SCALAR, optional => 1 }, mirrored => { type => SCALAR, optional => 1 }, traditional => { type => SCALAR, optional => 1 }, force => { type => SCALAR, optional => 1 }, disks => { type => ARRAYREF, optional => 1 }, }); my @command = ( qw( aggr create ), $args{name} ); if ( $args{force} ) { push @command, '-f'; } if ( $args{mirrored} ) { push @command, '-m'; } if ( $args{raidtype} ) { push @command, '-t', $args{raidtype}; } if ( $args{raidsize} ) { push @command, '-r', $args{raidsize}; } if ( $args{disktype} ) { push @command, '-T', $args{disktype}; } if ( $args{rpm} ) { push @command, '-R', $args{rpm}; } if ( $args{snaplock} ) { push @command, '-L', $args{snaplock}; } if ( $args{traditional} ) { push @command, '-v'; } if ( $args{language} ) { push @command, '-l', $args{language}; } if ( $args{diskcount} ) { if ( $args{disksize} ) { push @command, join( '@', $args{diskcount}, $args{disksize} ); } else { push @command, $args{diskcount}; } } if ( $args{disks} ) { if ( ref $args{disks}->[0] eq 'ARRAY' ) { push @command, '-d', @{ $args{disks}->[0] }; push @command, '-d', @{ $args{disks}->[1] }; } else { push @command, '-d', @{ $args{disks} }; } } $self->_run_command( command => \@command ); return $self->get_aggregate( $args{name} ); } sub destroy_aggregate { my $self = shift; my (%args) = validate( @_, { name => { type => SCALAR }, }); return $self->_run_command( command => [qw( aggr destroy ), $args{name}, '-f'], ); } sub get_volume_names { my $self = shift; $self->_run_command( command => [qw( vol status )], ); my @stdout = $self->_get_command_stdout; my $indices = NetApp::Volume->_parse_vol_status_headers( shift @stdout ); my @names = (); while ( my $line = shift @stdout ) { my $data = NetApp::Volume->_parse_vol_status_volume( indices => $indices, line => $line, ); if ( $data->{name} ) { push( @names, $data->{name} ); } } return @names; } sub get_volumes { my $self = shift; my @volumes = (); foreach my $name ( $self->get_volume_names ) { push @volumes, $self->get_volume( $name ); } return @volumes; } sub get_volume { my $self = shift; my $name = shift; $self->_run_command( command => [qw( vol status ), $name, '-v' ], ); my @stdout = $self->_get_command_stdout; my $indices = NetApp::Volume->_parse_vol_status_headers( shift @stdout ); my $volume = {}; while ( my $line = shift @stdout ) { last if $line =~ /^\s+$/; NetApp::Volume->_parse_vol_status_volume( indices => $indices, volume => $volume, line => $line, ); } my $plex = NetApp::Aggregate->_parse_aggr_status_plex( shift @stdout ); while ( my $line = shift @stdout ) { last if $line =~ /^\s+$/; push @{ $plex->{raidgroups} }, NetApp::Aggregate->_parse_aggr_status_raidgroup( $line ); } $volume->{ filer } = $self; $volume->{ plex } = $plex; return NetApp::Volume->new( $volume ); } sub get_qtree_names { return map { $_->get_name } shift->get_qtrees; } sub get_qtrees { return shift->_get_qtree_status; } sub get_qtree { return shift->_get_qtree_status( name => shift ); } sub _get_qtree_status { my $self = shift; my (%args) = validate( @_, { name => { type => SCALAR, optional => 1 }, volume => { isa => 'NetApp::Volume', optional => 1 }, }); if ( $args{volume} && $args{volume}->get_state('restricted') ) { return; } my @command = qw(qtree status -v -i); if ( $args{name} ) { my ($volume_name) = ( split( /\//, $args{name} ) )[2]; push @command, $volume_name; } elsif ( $args{volume} ) { push @command, $args{volume}->get_name; } $self->_run_command( command => \@command, ); my @stdout = $self->_get_command_stdout; splice( @stdout, 0, 2 ); # trash the two headers my @qtrees = (); while ( my $line = shift @stdout ) { my $qtree = NetApp::Qtree->_parse_qtree_status_qtree( $line ); $qtree->{ filer } = $self; push @qtrees, NetApp::Qtree->new( $qtree ); } if ( $args{name} ) { my ($qtree) = grep { $_->get_name eq $args{name} } @qtrees; return $qtree; } else { return @qtrees; } } sub create_qtree { my $self = shift; my (%args) = validate( @_, { name => { type => SCALAR }, mode => { type => SCALAR, optional => 1 }, security => { type => SCALAR, optional => 1 }, oplocks => { type => SCALAR, optional => 1 }, }); my @command = ( 'qtree', 'create', $args{name} ); if ( $args{mode} ) { push @command, '-m', sprintf( "%o", $args{mode} ); } $self->_run_command( command => \@command ); $self->_clear_cache( method => 'get_qtree' ); my $qtree = $self->get_qtree( $args{name} ); if ( not $qtree ) { croak( "Unable to retrieve the qtree object for $args{name},\n", "which we just created successfully!!\n", ); } if ( exists $args{security} ) { $qtree->set_security( $args{security} ); } if ( exists $args{oplocks} ) { $qtree->set_oplocks( $args{oplocks} ); } return $qtree; } sub set_snapmirror_state { my $self = shift; my $ident = ident $self; my $state = shift; if ( $state !~ /^(off|on)$/ ) { croak( "Invalid snapmirror state '$state'\n", "Must be either 'off' or 'on'\n", ); } $self->_run_command( command => [qw( snapmirror $state )] ); $snapmirror_state_of{$ident} = $state; return 1; } sub get_snapmirror_state { my $self = shift; my $ident = ident $self; if ( $snapmirror_state_of{$ident} !~ /^(off|on)$/ ) { $self->get_snapmirrors; } return $snapmirror_state_of{$ident}; } sub get_snapmirrors { return shift->_get_snapmirrors; } sub _get_snapmirrors { my $self = shift; my $ident = ident $self; my (%args) = validate( @_, { volume => { isa => 'NetApp::Volume', optional => 1 }, }); my @command = qw( snapmirror status -l ); if ( $args{volume} ) { push @command, $args{volume}->get_name; } $self->_run_command( command => \@command, ); my @stdout = $self->_get_command_stdout; my @snapmirrors = (); my $snapmirror = {}; while ( defined (my $line = shift @stdout) ) { if ( $line =~ /Snapmirror is (on|off)/ ) { $snapmirror_state_of{$ident} = $1; next; } if ( $line =~ /^\s*$/ ) { if ( keys %$snapmirror ) { $snapmirror->{ filer } = $self; push @snapmirrors, NetApp::Snapmirror->new( $snapmirror ); $snapmirror = {}; } next; } $snapmirror = NetApp::Snapmirror->_parse_snapmirror_status( snapmirror => $snapmirror, line => $line, ); } if ( keys %$snapmirror ) { $snapmirror->{ filer } = $self; push @snapmirrors, NetApp::Snapmirror->new( $snapmirror ); } return @snapmirrors; } sub get_temporary_exports { return grep { $_->get_type eq 'temporary' } shift->get_exports; } sub get_permanent_exports { return grep { $_->get_type eq 'permanent' } shift->get_exports; } sub get_active_exports { return grep { $_->get_active } shift->get_exports; } sub get_inactive_exports { return grep { not $_->get_active } shift->get_exports; } sub get_exports { my $self = shift; $self->_run_command( command => [qw( exportfs )], ); my @stdout = $self->_get_command_stdout; my %temporary = (); while ( defined (my $line = shift @stdout) ) { my $export = NetApp::Filer::Export->_parse_export( $line ); $export->{ filer } = $self; $export->{ type } = 'temporary'; $temporary{ $export->{path} } = NetApp::Filer::Export->new( $export ); } $self->_run_command( command => [qw( rdfile /etc/exports )], ); @stdout = $self->_get_command_stdout; my %permanent = (); while ( defined (my $line = shift @stdout) ) { next if $line =~ /^#/; next if $line =~ /^\s*$/; my $export = NetApp::Filer::Export->_parse_export( $line ); $export->{ filer } = $self; $export->{ type } = 'permanent'; my $permanent = NetApp::Filer::Export->new( $export ); my $temporary = $temporary{ $export->{path} }; if ( $temporary ) { if ( $temporary->compare( $permanent ) ) { delete $temporary{ $export->{path} }; } else { $permanent->set_active( 0 ); } } $permanent{ $export->{path} } = $permanent; } my @exports = ( values %temporary, values %permanent, ); return @exports; } } sub _parse_license { my $class = shift; my $line = shift; $line =~ s/$RE{ws}{crop}//g; my @fields = split( /\s+/, $line ); my $license = { service => $fields[0], expired => "", }; if ( $fields[1] eq 'site' ) { $license->{type} = 'site'; $license->{code} = $fields[2]; } else { $license->{type} = 'node'; $license->{code} = $fields[1]; } if ( $line =~ /expired \((\d+ \w+ \d+)\)/ ) { $license->{expired} = $1; } return $license; } sub _parse_option { my $class = shift; my $line = shift; $line =~ s/$RE{ws}{crop}//g; $line =~ s/\(.*\)$//g; $line =~ s/$RE{ws}{crop}//g; my @fields = split( /\s+/, $line ); if ( not defined $fields[1] ) { $fields[1] = ''; } my $option = { name => $fields[0], value => $fields[1], }; return $option; } 1; NetApp-500.002/lib/NetApp/Filer.pod000644 067073 067073 00000023453 11117556522 017455 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Filer -- OO Class for managing NetApp Filer devices =head1 SYNOPSIS use NetApp::Filer; my $filer = NetApp::Filer->new({ hostname => $hostname_of_nasfiler, ssh_identity => "/path/to/ssh/identify/file", }); my $filer = NetApp::Filer->new({ hostname => $hostname_of_nasfiler, protocol => 'telnet', telnet_password => $telnet_password, }); =head1 DESCRIPTION This class implements methods for communication with a NetApp Filer device. Both ssh and telnet are supported, but only ssh is really recommended. NetApp doesn't support concurrent access via telnet, and the error checking using ssh is far more robust. Not to mention, you can configure secure access via ssh without using passwords, but telnet access will always require a password. =head1 METHODS =head2 Filer Specific Methods =head3 new( $args_ref ) This method takes a hash reference of arguments, and returns a NetApp::Filer object to be used to communicate with the specified filer. The arguments are as follows: NetApp::Filer->new({ # Required arguments hostname => $hostname, # Optional arguments username => $username, ssh_identify => $ssh_identity, ssh_command => [ @ssh_command ], protocol => 'ssh' | 'telnet', telnet_password => $telnet_password, telnet_timeout => $telnet_timeout, cache_enabled => 0 || 1, cache_expiration => $cache_expiration, }); =over =item (required) hostname The value of this argument is a string, which is the hostname of the filer to connect to. =item (optional) username The username to use for communication. Defaults to 'root'. =item (optional) ssh_identify The ssh identify file to use for ssh communication. If not specified then ssh will be invoked without the -i argument, and will use whatever default identify file is setup for the current user. In practice, this argument will almost always be required, but the code allows it to be optional. If the specified file doesn't exist, then a fatal exception is raised. =item (optional) ssh_command An array reference representing the ssh command to be used to communication. Defaults to just ['ssh']. Don't use this argument to specify the identity via -i. Instead, use the ssh_identify argument. If you need to specify certain ssh options, for example StrictHostKeyChecking, then use this argument. For example: my $filer = NetApp::Filer->new({ hostname => $somenasfiler, ssh_command => [qw( ssh -o StrictHostKeyChecking=no )], }); =item (optional) protocol This option is a string, either 'ssh' or 'telnet'. The default, and recommended, protocol is ssh. While telnet is supported, only one concurrent root telnet session per filer is allowed, and the error checking over telnet is far less robust than ssh. =item (optional) telnet_password This option is a string, and specified the root password to use when connecting via telnet. Note that password based ssh connectivity is not supported, and telnet access, while supported, is not recommended. The author uses the telnet support for only one thing: installing the ssh keys, and configuring ssh access. =item (optional) cache_enabled NOTE: The caching mechanism is considered experimental. For one thing, it depends on using a patched version of Memoize::Expire, which is still not yet available on CPAN. Use with caution. This option has a boolean value, and is used to disable the internal caching of the results of several API calls. By default, the cache is disabled. If enabled, then the result of any of the following NetApp::Filer methods will be cached, using Memoize: get_aggregate get_volume get_qtree To enable caching of these API calls, set cache_enabled to a true value. The cached values will expire (see the next option), unless the expiration value is set to 0. =item (optional) cache_expiration This option is an integer, and is the number of seconds to cache results of the above API calls. The default value is 10 seconds. Setting this value to 0 will prevent the cached values from expiring at all. =back =head3 get_version Returns a NetApp::Filer::Version object. =head3 get_licenses Returns a list of NetApp::Filer::License objects, each of which represents a single licensed service on the filer. Note that if the service is "not licensed", it is ignored. Only services with active of expired licensed are returned. =head3 get_license( $service ) Returns a single NetApp::Filer::License object for the specified service. =head3 add_license( $code ) Adds a license using the specified code. Returns a boolean value only. =head3 delete_license( $service ) Deleted the license for the specified service. Returns a boolean value only. =head2 Aggregate Specific Methods =head3 get_aggregate_names Returns a list of strings, each of which is the name of an aggregate on the filer. =head3 get_aggregates Returns a list of NetApp::Aggregate objects, each of which represents an aggregate on the filer. =head3 get_aggregate( $name ) Returns a single NetApp::Aggregate object for the specified aggregate name. =head3 create_aggregate( %args ) Create an aggregate using the specified arguments, and returns the NetApp::Aggregate object that represents it. The arguments are as follows: my $aggregate = $filer->create_aggregate( # Required arguments name => $name, # Optional arguments raidtype => 'raid0' | 'raid4' | 'raid_dp', raidsize => $raidsize, disktype => 'ATA' | 'FCAL' | 'LUN' | 'SAS' | 'SATA' | 'SCSI', diskcount => $diskcount, disksize => $disksize, rpm => $rpm, language => $language, snaplock => 'Compliance' | 'Enterprise', mirrored => 1, # -m traditional => 1, # -v force => 1, # -f disks => [ # To specify a single set of disks: 'disk1', 'disk2', .... # To specify two sets of disks: [ 'disk1', 'disk2', .... ], [ 'diskn', 'disktn+1', .... ], ], ); =head3 destroy_aggregate( %args ) Destroy an aggregate using the specified arguments. The arguments are as follows: $filer->destroy_aggregate( # Required arguments name => $name, ); =head2 Volume Specific Methods =head3 get_volume_names Returns a list of strings, each of which is the name of a volume on the filer. =head3 get_volumes Returns a list of NetApp::Volume objects, each of which represents a volume on the filer. =head3 get_volume( $name ) Returns a single NetApp::Volume object for the specified volume name. =head2 Qtree Specific Methods =head3 get_qtree_names Returns a list of strings, each of which is the name of a qtree on the filer. =head3 get_qtrees Returns a list of NetApp::Qtree objects, each of which represents a single qtree on the filer. =head3 get_qtree( $name ) Returns a single NetApp::Qtree object for the specified qtree name. The name must in the form of a pathname, for example: /vol/volume_name/qtree_name The qtree_name is optional if querying the object for a volume's qtree. =head3 create_qtree( %args ) Creates a qtree on the filer. The arguments are as follows: $filer->create_qtree( # Required arguments name => $name, # Optional arguments mode => $mode, security => 'unix' | 'ntfs' | 'mixed', oplocks => 0 | 1, ); =over =item (required) name The name of the qtree to create. =item (optional) mode The UNIX mode bits to use when creating the qtree. =item (optional) security The security of the qtree. This must be one of: unix, ntfs, or mixed. =item (optional) oplocks This option specified whether or not oplocks are to be enabled on the qtree. The value is interpreted in a boolean context, true meaning "enabled" and false meaning "disabled". =back =head2 Snapmirror Specific Methods =head3 set_snapmirror_state( $state ) Sets the snapmirror state on the filer to the specified value, which must be either of the strings "off" or "on". =head3 get_snapmirror_state Returns a string, either "off" or "on", indicating whether or not snapmirror is turned off or on for this filer. =head3 get_snapmirrors Returns a list of NetApp::Snapmirror objecte, each of which represents a single snapmirror relationship on the filer. =head2 Export Specific Methods There is one general purpose method to retrieve all of the NFS exports on a filer, and 4 special purpose ones that make it easy to see the difference between the contents of /etc/exports, and the live exports reported by "exportfs". =head3 get_exports Returns a list of NetApp::Filer::Export objects, each of which represents an NFS export on the filer. =head3 get_permanent_exports Returns a list of NetApp::Filer::Export objects, each of which represents a permanent export, which is one found in the /etc/exports file. =head3 get_temporary_exports Returns a list of NetApp::Filer::Export objects, each of which represents a temporary export, which is one NOT found in the /etc/exports file. Temporary exports are ones created manually, using "exportfs -io", or by using the "exportfs -b" option to fence clients, or any other command which creates a live NFS export that has not yet been written to /etc/exports, and which will not survive a reboot of the filer. =head3 get_active_exports Returns a list of NetApp::Filer::Export objects, each of which represents a active export. Active exports are those reported by the "exportfs" command. They can be permanent, if they are found in /etc/exports, or temporary, if created by hand. =head3 get_inactive_exports Returns a list of NetApp::Filer::Export objects, each of which represents a inactive export. An inactive export is a permanent export found in /etc/exports, but which is NOT found in the list of active exports reported by "exportfs". If the options of a permanent export are changed, but not saved to /etc/exports (eg. re-export something with "exportfs -io"), then the active, temporary export for that same path, and the inactive, permanent export in /etc/exports can both exist concurrently. =cut NetApp-500.002/lib/NetApp/Qtree.pm000644 067073 067073 00000010121 11763415477 017324 0ustar00pmoorepmoore000000 000000 package NetApp::Qtree; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use English; use Carp; use Class::Std; use Params::Validate qw( :all ); use Regexp::Common; { my %filer_of :ATTR( get => 'filer' ); my %volume_name_of :ATTR( get => 'volume_name' ); my %name_of :ATTR( get => 'name' ); my %security_of :ATTR( get => 'security' ); my %oplocks_of :ATTR( get => 'oplocks' ); my %status_of :ATTR( get => 'status' ); my %id_of :ATTR( get => 'id' ); my %vfiler_of :ATTR( get => 'vfiler' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { filer => { isa => 'NetApp::Filer' }, volume_name => { type => SCALAR }, name => { type => SCALAR }, security => { type => SCALAR }, oplocks => { type => SCALAR }, status => { type => SCALAR }, id => { type => SCALAR }, vfiler => { type => SCALAR, optional => 1 }, }); $filer_of{$ident} = $args{filer}; $volume_name_of{$ident} = $args{volume_name}; $name_of{$ident} = $args{name}; $security_of{$ident} = $args{security}; $oplocks_of{$ident} = $args{oplocks}; $status_of{$ident} = $args{status}; $id_of{$ident} = $args{id}; if ( $args{vfiler} ) { $vfiler_of{$ident} = $args{vfiler}; } } sub get_volume { my $self = shift; return $self->get_filer->get_volume( $self->get_volume_name ); } sub get_aggregate { return shift->get_volume->get_aggregate; } sub set_security { my $self = shift; my $ident = ident $self; my $security = shift; if ( $security !~ /^(unix|ntfs|mixed)$/ ) { croak("Invalid qtree security value: $security\n"); } my $name = $self->get_name; $self->get_filer->_run_command( command => [qw( qtree security ), $name, $security ], ); $security_of{$ident} = $security; } sub set_oplocks { my $self = shift; my $ident = ident $self; my $state = shift; my $enable = $state ? 'enable' : 'disable'; my $name = $self->get_name; $self->get_filer->_run_command( command => [qw( qtree oplocks ), $name, $enable ], ); $oplocks_of{$ident} = $enable eq 'enable' ? 1 : 0; } sub get_temporary_exports { return grep { $_->get_type eq 'temporary' } shift->get_exports; } sub get_permanent_exports { return grep { $_->get_type eq 'permanent' } shift->get_exports; } sub get_active_exports { return grep { $_->get_active } shift->get_exports; } sub get_inactive_exports { return grep { not $_->get_active } shift->get_exports; } sub get_export { my $self = shift; my ($path) = validate_pos( @_, { type => SCALAR } ); return grep { $_->get_path eq $path } $self->get_exports; } sub get_exports { my $self = shift; my @exports = (); foreach my $export ( $self->get_filer->get_exports ) { if ( $export->get_path eq $self->get_name ) { push @exports, $export; } elsif ( $export->get_actual eq $self->get_name ) { push @exports, $export; } } return @exports; } } sub _parse_qtree_status_qtree { my $class = shift; my $line = shift; my $qtree = {}; my @data = split( /\s+/, $line ); $qtree->{volume_name} = shift @data; $qtree->{name} = "/vol/$qtree->{volume_name}"; if ( $data[0] !~ /^(unix|ntfs|mixed)$/ ) { $qtree->{name} .= "/" . shift @data; } $qtree->{security} = $data[0]; $qtree->{oplocks} = $data[1] eq 'enabled' ? 1 : 0; $qtree->{status} = $data[2]; $qtree->{id} = $data[3]; if ( $data[4] ) { $qtree->{vfiler} = $data[4]; } return $qtree; } 1; NetApp-500.002/lib/NetApp/Qtree.pod000644 067073 067073 00000003316 11113273352 017461 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Qtree -- OO class for creating and managing qtrees =head1 SYNOPSIS use NetApp::Filer; use NetApp::Qtree; my $filer = NetApp::Filer->new( .... ); # Create a tree, with all options in one call my $qtree = $filer->create_qtree( name => "/vol/vol1/qtreename", oplocks => 1, mode => 0755, security => 'unix', ); # Alternately, you can create it, and then change things my $qtree = $filer->create_qtree( name => "/vol/vol1/qtreename", mode => 0755, ); # The mode must be set when created $qtree->set_oplock(1); $qtree->set_security('unix'); =head1 DESCRIPTION This class encapsulates a single NetApp qtree, and provides methods for querying information about the qtree, as well as methods for managing it. =head1 METHODS =head2 set_security( $security ) This method method takes a single argument, which is the security value to set on the qtree. It must have one of the following values: unix ntfs mixed =head2 get_security Returns a string containing the current security setting of the qtree. =head2 set_oplocks( $boolean ) This method takes a boolean argument, and sets the oplocks attribute of the qtree to "enabled" if the value is true, and "disabled" if the value is false. =head2 get_oplocks Returns true is the oplocks are set to "enabled", false if they are set to "disabled". =head2 get_status Returns the status value for the qtree. It waill have the values such as: normal snapmirrored =head2 get_id Returns the qtree id. =head2 get_vfiler Returns the vfiler which owns the qtree. If vfilers are not licensed on the filer, this method will simply return a false value. =cut NetApp-500.002/lib/NetApp/Snapmirror/000755 067073 067073 00000000000 11763415704 020040 5ustar00pmoorepmoore000000 000000 NetApp-500.002/lib/NetApp/Snapmirror.pm000644 067073 067073 00000010102 11763415504 020366 0ustar00pmoorepmoore000000 000000 package NetApp::Snapmirror; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use English; use Carp; use Class::Std; use Params::Validate qw( :all ); use Regexp::Common; use NetApp::Snapmirror::Source; use NetApp::Snapmirror::Destination; { my %filer_of :ATTR( get => 'filer' ); my %source_of :ATTR( get => 'source' ); my %destination_of :ATTR( get => 'destination' ); my %status_of :ATTR( get => 'status' ); my %progress_of :ATTR( get => 'progress' ); my %state_of :ATTR( get => 'state' ); my %lag_of :ATTR( get => 'lag' ); my %mirror_timestamp_of :ATTR( get => 'mirror_timestamp' ); my %base_snapshot_of :ATTR( get => 'base_snapshot' ); my %current_transfer_type_of :ATTR( get => 'current_transfer_type' ); my %current_transfer_error_of :ATTR( get => 'current_transfer_error' ); my %contents_of :ATTR( get => 'contents' ); my %last_transfer_type_of :ATTR( get => 'last_transfer_type' ); my %last_transfer_size_of :ATTR( get => 'last_transfer_size' ); my %last_transfer_duration_of :ATTR( get => 'last_transfer_duration' ); my %last_transfer_from_of :ATTR( get => 'last_transfer_from' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { filer => { isa => 'NetApp::Filer' }, source => { type => HASHREF, optional => 1 }, destination => { type => HASHREF }, status => { type => SCALAR }, progress => { type => SCALAR }, state => { type => SCALAR }, lag => { type => SCALAR }, mirror_timestamp => { type => SCALAR }, base_snapshot => { type => SCALAR }, current_transfer_type => { type => SCALAR }, current_transfer_error => { type => SCALAR }, contents => { type => SCALAR }, last_transfer_type => { type => SCALAR }, last_transfer_size => { type => SCALAR }, last_transfer_duration => { type => SCALAR }, last_transfer_from => { type => SCALAR }, }); $filer_of{$ident} = $args{filer}; if ( $args{source} ) { $source_of{$ident} = NetApp::Snapmirror::Source->new( $args{source} ); } $destination_of{$ident} = NetApp::Snapmirror::Destination->new( $args{destination} ); $status_of{$ident} = $args{status}; $progress_of{$ident} = $args{progress}; $state_of{$ident} = $args{state}; $lag_of{$ident} = $args{lag}; $mirror_timestamp_of{$ident} = $args{mirror_timestamp}; $base_snapshot_of{$ident} = $args{base_snapshot}; $current_transfer_type_of{$ident} = $args{current_transfer_type}; $current_transfer_error_of{$ident} = $args{current_transfer_error}; $contents_of{$ident} = $args{contents}; $last_transfer_type_of{$ident} = $args{last_transfer_type}; $last_transfer_size_of{$ident} = $args{last_transfer_size}; $last_transfer_duration_of{$ident} = $args{last_transfer_duration}; $last_transfer_from_of{$ident} = $args{last_transfer_from}; } } sub _parse_snapmirror_status { my $class = shift; my (%args) = validate( @_, { snapmirror => { type => HASHREF }, line => { type => SCALAR }, }); my $snapmirror = $args{snapmirror}; my $line = $args{line}; my ($key,$value) = split( /:\s+/, $line, 2 ); # 'Last Transfer Type' => 'last_transfer_type' $key =~ s/\s/_/g; $key = lc($key); if ( $value eq '-' ) { $value = ''; } if ( $key eq 'source' || $key eq 'destination' ) { if ( my ($hostname,$volume) = split( /:/, $value ) ) { $snapmirror->{$key} = { hostname => $hostname, volume => $volume, }; } } else { $snapmirror->{$key} = $value; } return $snapmirror; } 1; NetApp-500.002/lib/NetApp/Snapmirror.pod000644 067073 067073 00000003114 11113273352 020531 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Snapmirror -- OO class for snapmirror relationships =head1 SYNOPSIS use NetApp::Filer; use NetApp::Snapmirror; my $filer = NetApp::Filer->new( .... ); my @snapmirrors = $filer->get_snapmirrors; my $volume = $filer->get_volume( .... ); my @snapmirrors = $volume->get_snapmirrors; =head1 DESCRIPTION This class encapsulates a single snapmirror relationship, and provides methods for querying information about it, as well as methods for managing it. =head1 METHODS =head2 get_filer Returns the NetApp::Filer object for the filer on which this snapmirror relationship is defined. =head2 get_source Returns a NetApp::Snapmirror::Source object representing the source filer/volume for this snapmirror relationship. =head2 get_destination Returns a NetApp::Snapmirror::Destination object representing the source filer/volume for this snapmirror relationship. =head2 Miscellaneous get_* methods All of the following get methods return strings which match the values found for each of the obvious keywords in the output of "snapmirror status -l": =over =item get_status =item get_progress =item get_state =item get_lag =item get_mirror_timestamp =item get_base_snapshot =item get_current_transfer_type =item get_current_transfer_error =item get_contents =item get_last_transfer_type =item get_last_transfer_size =item get_last_transfer_duration =item get_last_transfer_from =back NOTE: In a future release, when snapshots are supported as a proper object, the return value of get_snapshot will almost certainly return such an object. =cut NetApp-500.002/lib/NetApp/Snapshot/000755 067073 067073 00000000000 11763415704 017503 5ustar00pmoorepmoore000000 000000 NetApp-500.002/lib/NetApp/Snapshot.pm000644 067073 067073 00000025262 11763415511 020044 0ustar00pmoorepmoore000000 000000 package NetApp::Snapshot; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use English; use Carp; use Class::Std; use Params::Validate qw( :all ); use Regexp::Common; use NetApp::Snapshot::Delta; use NetApp::Snapshot::Schedule; { my %parent_of :ATTR( get => 'parent' ); my %name_of :ATTR( get => 'name' ); my %date_of :ATTR( get => 'date' ); my %used_of :ATTR( get => 'used' ); my %total_of :ATTR( get => 'total' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { parent => { type => OBJECT }, name => { type => SCALAR }, date => { type => SCALAR }, used => { type => SCALAR }, total => { type => SCALAR }, }); $parent_of{$ident} = $args{parent}; $name_of{$ident} = $args{name}; $date_of{$ident} = $args{date}; $used_of{$ident} = $args{used}; $total_of{$ident} = $args{total}; } sub get_filer { return shift->get_parent->get_filer; } sub get_snapshot_deltas { my $self = shift; return $self->_get_snapshot_deltas( parent => $self->get_parent, from => $self, ); } sub get_reclaimable { my $self = shift; if ( $self->get_parent->isa("NetApp::Aggregate") ) { croak("Aggregate snapshots do not support 'snap reclaimable'\n"); } $self->get_filer->_run_command( command => [ qw( snap reclaimable ), $self->get_parent->get_name, $self->get_name ], nonfatal => 1, ); my @stdout = $self->get_filer->_get_command_stdout; my @stderr = $self->get_filer->_get_command_stderr; while ( defined (my $line = shift @stdout) ) { if ( $line =~ /Approximately (\d+)/ ) { return $1; } } carp( "Unable to determine reclaimable space for ", $self->get_parent->get_name, ":", $self->get_name, "\n", @stderr, ); return undef; } sub restore { my $self = shift; my (%args) = validate( @_, { type => { type => SCALAR, regexp => qr{^(vol|file)$}, default => 'vol', optional => 1 }, from_path => { type => SCALAR, optional => 1 }, to_path => { type => SCALAR, optional => 1 }, }); if ( $args{type} eq 'file' && ! $args{from_path} ) { croak( "Missing required argment 'from_path'\n", "File restores must specify the from_path\n", ); } if ( $args{type} eq 'vol' && $args{to_path} ) { croak( "Invalid argument 'to_path'\n", "Volume restores can not specify to_path\n", ); } my @command = qw( snap restore ); if ( $self->get_parent->isa("NetApp::Aggregate" ) ) { push @command, '-A'; } if ( $args{to_path} ) { push @command, '-r', $args{to_path}; } push @command, ( qw( -f -s ), $self->get_name, qw( -t ), $args{type}, ); if ( $args{type} eq 'vol' ) { push @command, $self->get_parent->get_name; } else { push @command, $args{from_path}; } return $self->get_filer->_run_command( command => \@command, ); } sub rename { my $self = shift; my $ident = ident $self; my ($newname) = validate_pos( @_, { type => SCALAR }, ); my @command = qw( snap rename ); if ( $self->get_parent->isa("NetApp::Aggregate") ) { push @command, '-A'; } push @command, $self->get_name, $newname; $self->_run_command( command => \@command, ); $name_of{$ident} = $newname; return 1; } } # NOTE: These are class methods, since you can request snapshots, # deltas, etc from an aggregate, volume, or a specific snapshot. sub _get_snapshots { my $class = shift; my (%args) = validate( @_, { parent => { type => OBJECT }, }); my $parent = $args{parent}; my @command = qw( snap list ); if ( $parent->isa("NetApp::Aggregate") ) { push @command, '-A'; } push @command, $parent->get_name; $parent->get_filer->_run_command( command => \@command, ); my @stdout = $parent->get_filer->_get_command_stdout; my @snapshots = (); while ( defined (my $line = shift @stdout) ) { next if $line =~ /^(Volume|Aggregate)/; next if $line =~ /^working/; next if $line =~ /^\s*$/; last if $line =~ /No snapshots exist/; next if $line =~ m:^\s*%/used:; next if $line =~ /^-+/; my $snapshot = $class->_parse_snap_list( $line ); push @snapshots, NetApp::Snapshot->new({ parent => $parent, %$snapshot, }); } return @snapshots; } sub _create_snapshot { my $class = shift; my (%args) = validate( @_, { parent => { type => OBJECT }, name => { type => SCALAR }, }); my $parent = $args{parent}; my @command = qw( snap create ); if ( $parent->isa("NetApp::Aggregate") ) { push @command, '-A'; } push @command, $args{name}; return $parent->get_filer->_run_command( command => \@command, ); } sub _delete_snapshot { my $class = shift; my (%args) = validate( @_, { parent => { type => OBJECT }, name => { type => SCALAR }, }); my $parent = $args{parent}; my @command = qw( snap delete ); if ( $parent->isa("NetApp::Aggregate") ) { push @command, '-A'; } push @command, $args{name}; return $parent->get_filer->_run_command( command => \@command, ); } sub _set_snapshot_schedule { my $class = shift; my (%args) = validate( @_, { parent => { type => OBJECT }, weekly => { type => SCALAR }, daily => { type => SCALAR }, hourly => { type => SCALAR }, hourlist => { type => ARRAYREF, optional => 1 }, }); my $parent = $args{parent}; my @command = qw( snap sched ); if ( $parent->isa("NetApp::Aggregate") ) { push @command, '-A'; } push @command, $parent->get_name, $args{weekly}, $args{daily}; my $hourly = $args{hourly}; if ( $args{hourlist} ) { $hourly .= '@' . join( ',', @{ $args{hourlist} } ); } push @command, $args{hourly}; return $parent->get_filer->_run_command( command => \@command, ); } sub _get_snapshot_schedule { my $class = shift; my (%args) = validate( @_, { parent => { type => OBJECT }, }); my $parent = $args{parent}; my @command = qw( snap sched ); if ( $parent->isa("NetApp::Aggregate") ) { push @command, '-A'; } push @command, $parent->get_name; $parent->get_filer->_run_command( command => \@command, ); my @stdout = $parent->get_filer->_get_command_stdout; my $schedule = NetApp::Snapshot::Schedule->_parse_snap_sched( shift @stdout ); return NetApp::Snapshot::Schedule->new({ parent => $parent, %$schedule, }); } sub _set_snapshot_reserved { my $class = shift; my (%args) = validate( @_, { parent => { type => OBJECT }, reserved => { type => SCALAR }, }); my $parent = $args{parent}; my $reserved = $args{reserved}; my @command = qw( snap reserve ); if ( $parent->isa("NetApp::Aggregate") ) { push @command, '-A'; } push @command, $parent->get_name, $reserved; return $parent->get_filer->_run_command( command => \@command, ); } sub _get_snapshot_reserved { my $class = shift; my (%args) = validate( @_, { parent => { type => OBJECT }, }); my $parent = $args{parent}; my $parent_class = ref $parent; my @command = qw( snap reserve ); if ( $parent->isa("NetApp::Aggregate") ) { push @command, '-A'; } push @command, $parent->get_name; $parent->get_filer->_run_command( command => \@command, ); my @stdout = $parent->get_filer->_get_command_stdout; my $line = shift @stdout; if ( $line =~ /reserve is (\d+)%/ ) { return $1; } else { croak( "Unable to determine snapshot reserve for $parent_class", $parent->get_name, "\n", ); } } sub _get_snapshot_deltas { my $class = shift; my (%args) = validate( @_, { parent => { type => OBJECT }, from => { isa => 'NetApp::Snapshot', optional => 1 }, to => { isa => 'NetApp::Snapshot', depends => [qw( from )], optional => 1 }, }); my $parent = $args{parent}; my @command = qw( snap delta ); if ( $parent->isa("NetApp::Aggregate") ) { push @command, '-A'; } push @command, $parent->get_name; if ( $args{from} ) { push @command, $args{from}->get_name; } if ( $args{to} ) { push @command, $args{to}->get_name; } $parent->get_filer->_run_command( command => \@command, ); my @stdout = $parent->get_filer->_get_command_stdout; my @deltas = (); my $summary = 0; while ( defined( my $line = shift @stdout) ) { next if $line =~ /^\s*$/; next if $line =~ /^(Volume|Aggregate|working|From)/; next if $line =~ /^[-\s]+$/; last if $line =~ /No snapshots exist/; if ( $line =~ /^Summary/ ) { $summary = 1; next; } my $delta = NetApp::Snapshot::Delta->_parse_snap_delta( $line ); push @deltas, NetApp::Snapshot::Delta->new({ summary => $summary, %$delta, }); } return @deltas; } sub _parse_snap_list { my $class = shift; my $line = shift; $line =~ m{ ^ \s* \d+% \s+ \( \s* (\d+) % \) \s+ \d+% \s+ \( \s* (\d+) % \) \s+ ( \w+ \s+ \d+ \s+ \d+ : \d+ ) \s+ (\S+) }x; return { used => $1, total => $2, date => $3, name => $4, }; } 1; NetApp-500.002/lib/NetApp/Snapshot.pod000644 067073 067073 00000003501 11113273352 020174 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Snapshot -- OO class for creating and managing snapshots =head1 SYNOPSIS use NetApp::Filer; use NetApp::Snapshot; my $filer = NetApp::Filer->new( .... ); =head1 DESCRIPTION This class encapsulates a single NetApp snapshot, and provides methods for querying information about the snapshot, as well as methods for managing it. =head1 METHODS =head2 get_parent Returns the NetApp::Aggregate or NetApp::Volume object for the aggregate or volume for which object is a snapshot. =head2 get_name Returns a string representing the name of the snapshot. =head2 get_date Returns the date the snapshot was created. =head2 get_used Returns the percentage of space used by snapshot. =head2 get_total Returns the percentage of total space used by the snapshot. =head2 get_snapshot_deltas Returns an array of NetApp::Snapshot:Delta objects, each representing a single delta for this snapshot. =head2 get_reclaimable Returns the amount of reclaimable space, if the snapshot is deleted. Note that experimentally, this command has a lot of failure scenarios, most of which are reasonable (there are a lot of cases where you can't query this data). Therefore, unlike most of the methods in this API, it doesn't raise a fatal exception if it can't query the information, it simply generates warnings. =head2 rename( $newname ) Renames the snapshot to the specified name. =head2 restore( %args ) This method is an interface to the "snap restore" command. The argument syntax is: $snapshot->restore( type => 'vol' | 'file', # Defaults to vol from_path => $from_path, to_path => $to_path, ); The 'type' argument maps to the -t CLI argument, and the 'to_path' argument maps to the -r CLI argument. Refer to the na_snap(1) man page, and the "snap restore" documentation for further information. =cut NetApp-500.002/lib/NetApp/Volume/000755 067073 067073 00000000000 11763415704 017153 5ustar00pmoorepmoore000000 000000 NetApp-500.002/lib/NetApp/Volume.pm000644 067073 067073 00000047116 11763415515 017522 0ustar00pmoorepmoore000000 000000 package NetApp::Volume; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use English; use Carp; use Class::Std; use Params::Validate qw( :all ); use Regexp::Common; use NetApp::Volume::Source; { my %filer_of :ATTR( get => 'filer' ); my %name_of :ATTR( get => 'name' ); my %state_of :ATTR; my %status_of :ATTR; my %options_of :ATTR; my %source_of :ATTR( get => 'source' ); my %plex_of :ATTR( get => 'plex' ); my %aggregate_name_of :ATTR( get => 'aggregate_name' ); my %clone_names_of :ATTR; my %parent_name_of :ATTR( get => 'parent_name' ); my %snapshot_name_of :ATTR( get => 'snapshot_name' ); my %path_of :ATTR( get => 'path' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { filer => { isa => 'NetApp::Filer' }, name => { type => SCALAR }, state => { type => HASHREF }, status => { type => HASHREF }, options => { type => HASHREF }, plex => { type => HASHREF }, aggregate_name => { type => SCALAR, optional => 1 }, source => { type => HASHREF, optional => 1 }, clone_names => { type => ARRAYREF, default => [], optional => 1 }, parent_name => { type => SCALAR, optional => 1 }, snapshot_name => { type => SCALAR, optional => 1 }, }); $filer_of{$ident} = $args{filer}; $name_of{$ident} = $args{name}; $state_of{$ident} = $args{state}; $status_of{$ident} = $args{status}; $options_of{$ident} = $args{options}; $plex_of{$ident} = NetApp::Aggregate::Plex->new( $args{plex} ); if ( $args{aggregate_name} ) { $aggregate_name_of{$ident} = $args{aggregate_name}; } if ( $args{source} ) { $source_of{$ident} = NetApp::Volume::Source->new( $args{source} ); } $clone_names_of{$ident} = $args{clone_names}; if ( $args{parent_name} ) { $parent_name_of{$ident} = $args{parent_name}; } if ( $args{snapshot_of} ) { $snapshot_name_of{$ident} = $args{snapshot_name}; } $path_of{$ident} = "/vol/$args{name}"; } sub get_states { return keys %{ $state_of{ident shift} }; } sub get_state { my $self = shift; my $ident = ident $self; my $state = shift; return $state_of{$ident}->{$state}; } sub get_statuses { # Stati? Oh, hell no... return keys %{ $status_of{ident shift} }; } sub get_status { my $self = shift; my $ident = ident $self; my $status = shift; return $status_of{$ident}->{$status}; } sub get_options { return keys %{ $options_of{ident shift} }; } sub get_option { my $self = shift; my $ident = ident $self; my $option = shift; if ( exists $options_of{$ident}->{$option} ) { return $options_of{$ident}->{$option}; } else { return undef; } } sub set_option { my $self = shift; my $option = shift; my $value = $option eq 'root' ? '-f' : shift; my $ident = ident $self; my $name = $self->get_name; my @command = ( qw(vol options), $name, $option, $value ); $self->get_filer->_run_command( command => @command ); if ( $option eq 'root' ) { $options_of{$ident}->{$option} = 1; } else { $options_of{$ident}->{$option} = $value; } return 1; } sub get_aggregate { my $self = shift; return $self->get_filer->get_aggregate( $self->get_aggregate_name ); } sub get_qtree_names { my $self = shift; return map { $_->get_name } $self->get_qtrees; } sub get_qtree { my $self = shift; my $name = shift || "/vol/" . $self->get_name; return $self->get_filer->get_qtree( $name ); } sub get_qtrees { my $self = shift; return $self->get_filer->_get_qtree_status( volume => $self ); } sub get_language { my $self = shift; my $name = $self->get_name; $self->get_filer->_run_command( command => [qw(vol language), $name], ); my @stdout = $self->get_filer->_get_command_stdout; my $language = ""; while ( my $line = shift @stdout ) { if ( $line =~ /Volume language is (\S+)/ ) { $language = $1; } } if ( not $language ) { croak( "Unable to determine language for volume $name\n", ); } return $language; } sub set_language { my $self = shift; my $language = shift; my $name = $self->get_name; return $self->get_filer->_run_command( command => [qw(vol language), $name, $language], ); } sub get_size { my $self = shift; my $name = $self->get_name; $self->get_filer->_run_command( command => [qw(vol size), $name], ); my @stdout = $self->get_filer->_get_command_stdout; my $size = ""; while ( defined(my $line = shift @stdout) ) { if ( $line =~ /has size (\S+)\./ ) { $size = $1; } } if ( not $size ) { croak("Unable to determine size of volume $name\n"); } return $size; } sub set_size { my $self = shift; my $size = shift; return $self->get_filer->_run_command( command => [qw(vol size), $self->get_name, $size], ); } sub get_maxfiles { my $self = shift; my $name = $self->get_name; $self->get_filer->_run_command( command => ['maxfiles', $name], ); my @stdout = $self->get_filer->_get_command_stdout; my $maxfiles = ""; while ( my $line = shift @stdout ) { if ( $line =~ /is currently (\d+)/ ) { $maxfiles = $1; } } if ( not $maxfiles ) { croak("Unable to determine maxfiles of volume $name\n"); } return $maxfiles; } sub set_maxfiles { my $self = shift; my $maxfiles = shift; return $self->get_filer->_run_command( command => ['maxfiles', $self->get_name, $maxfiles], ); } sub get_clone_names { my $self = shift; my $ident = ident $self; return @{ $clone_names_of{$ident} }; } sub get_clones { my $self = shift; my @clones = (); foreach my $clone_name ( $self->get_clone_names ) { push @clones, $self->get_filer->get_volume( $clone_name ); } return @clones; } sub is_clone { my $self = shift; return ( $self->get_parent_name ? 1 : 0 ); } sub get_parent { my $self = shift; if ( $self->is_clone ) { return $self->get_filer->get_volume( $self->get_parent_name ); } else { return; } } sub get_snapmirrors { my $self = shift; return $self->get_filer->_get_snapmirrors( volume => $self ); } sub get_snapshots { return NetApp::Snapshot->_get_snapshots( parent => shift ); } sub get_snapshot { my $self = shift; my ($name) = validate_pos( @_, { type => SCALAR } ); return grep { $_->get_name eq $name } $self->get_snapshots; } sub create_snapshot { my $self = shift; my ($name) = validate_pos( @_, { type => SCALAR } ); return NetApp::Snapshot->_create_snapshot( parent => $self, name => $name, ); } sub delete_snapshot { my $self = shift; my ($name) = validate_pos( @_, { type => SCALAR } ); return NetApp::Snapshot->_delete_snapshot( parent => $self, name => $name, ); } sub delete_all_snapshots { croak(__PACKAGE__ . "->delete_all_snapshots not yet implemented\n"); # XXX: This one's tricky to implement. Should we parse the # output, and attempt to return a list of what was delete, and # what was busy? Probably too ugly. my $self = shift; return $self->get_filer->_run_command( command => [ qw( snap delete -a -f -q ), $self->get_name ], ); } sub get_snapshot_deltas { return NetApp::Snapshot->_get_snapshot_deltas( parent => shift ); } sub get_snapshot_reserved { return NetApp::Snapshot->_get_snapshot_reserved( parent => shift ); } sub set_snapshot_reserved { my $self = shift; my ($reserved) = validate_pos( @_, { type => SCALAR } ); return NetApp::Snapshot->_set_snapshot_reserved( parent => $self, reserved => $reserved, ); } sub get_snapshot_schedule { return NetApp::Snapshot->_get_snapshot_schedule( parent => shift, @_ ); } sub set_snapshot_schedule { return NetApp::Snapshot->_set_snapshot_schedule( parent => shift, @_ ); } sub enable_snapshot_autodelete { my $self = shift; return $self->get_filer->_run_command( command => [ qw(snap autodelete), $self->get_name, qw(on) ], ); } sub disable_snapshot_autodelete { my $self = shift; return $self->get_filer->_run_command( command => [ qw(snap autodelete), $self->get_name, qw(off) ], ); } sub reset_snapshot_autodelete { my $self = shift; return $self->get_filer->_run_command( command => [ qw(snap autodelete), $self->get_name, qw(reset) ], ); } sub set_snapshot_autodelete_option { my $self = shift; my ($name,$value) = validate_pos( @_, { type => SCALAR }, { type => SCALAR }, ); my @command = ( qw( snap autodelete ), $self->get_name, $name, $value, ); return $self->get_filer->_run_command( command => \@command, ); } sub get_snapshot_autodelete_option { my $self = shift; my ($name) = validate_pos( @_, { type => SCALAR }, ); my @command = ( qw( snap autodelete ), $self->get_name ); $self->get_filer->_run_command( command => \@command, ); my @stdout = $self->get_filer->_get_command_stdout; my $found = 0; my $value = ""; while ( defined (my $line = shift @stdout) ) { if ( $line =~ /^$name\s*:\s*(.*)/ ) { $found = 1; $value = $1; $value = "" if $value eq '(not specified)'; } } if ( not $found ) { croak("Invalid autodelete option name '$name'\n"); } return $value; } sub get_temporary_exports { return grep { $_->get_type eq 'temporary' } shift->get_exports; } sub get_permanent_exports { return grep { $_->get_type eq 'permanent' } shift->get_exports; } sub get_active_exports { return grep { $_->get_active } shift->get_exports; } sub get_inactive_exports { return grep { not $_->get_active } shift->get_exports; } sub get_export { my $self = shift; my ($path) = validate_pos( @_, { type => SCALAR } ); return grep { $_->get_path eq $path } $self->get_exports; } sub get_exports { my $self = shift; return grep { $_->get_path eq $self->get_path || $_->get_actual eq $self->get_path } $self->get_filer->get_exports; } sub create_export { my $self = shift; my (%args) = validate( @_, { exportas => { type => SCALAR, optional => 1 }, type => { type => SCALAR, optional => 1 }, nosuid => { type => SCALAR, optional => 1 }, anon => { type => SCALAR, optional => 1 }, sec => { type => ARRAYREF, optional => 1 }, root => { type => ARRAYREF, optional => 1 }, rw => { type => ARRAYREF, optional => 1 }, ro => { type => ARRAYREF, optional => 1 }, rw_all => { type => SCALAR, optional => 1 }, ro_all => { type => SCALAR, optional => 1 }, }); if ( $args{exportas} ) { $args{actual} = $self->get_path, $args{path} = delete $args{exportas}, } else { $args{path} = $self->get_path; } my $export = NetApp::Filer::Export->new( \%args ); return $export->update; } sub destroy_export { my $self = shift; # XXX: Hmm.... } sub offline { my $self = shift; my $ident = ident $self; my (%args) = validate( @_, { cifsdelaytime => { type => SCALAR, optional => 1 }, }); my @command = ( qw(vol offline), $self->get_name ); if ( $args{cifsdelaytime} ) { push @command, '-t', $args{cifsdelaytime}; } $self->get_filer->_run_command( command => \@command, ); delete $state_of{$ident}->{online}; delete $state_of{$ident}->{restricted}; $state_of{$ident}->{offline} = 1; return 1; } sub online { my $self = shift; my $ident = ident $self; my (%args) = validate( @_, { force => { type => SCALAR, optional => 1 }, }); my @command = ( qw( vol online ), $self->get_name ); if ( $args{force} ) { push @command, '-f'; } $self->get_filer->_run_command( command => \@command, ); delete $state_of{$ident}->{offline}; delete $state_of{$ident}->{restricted}; $state_of{$ident}->{online} = 1; return 1; } sub rename { my $self = shift; my $ident = ident shift; my (%args) = validate( @_, { newname => { type => SCALAR }, }); my $oldname = $self->get_name; $self->get_filer->_run_command( command =>[qw(vol rename), $oldname, $args{newname}], ); $name_of{$ident} = $args{newname}; return 1; } sub restrict { my $self = shift; my $ident = ident shift; my (%args) = validate( @_, { cifsdelaytime => { type => SCALAR, optional => 1 }, }); my @command = ( qw(vol restrict), $self->get_name ); if ( $args{cifsdelaytime} ) { push @command, '-t', $args{cifsdelaytime}; } $self->get_filer->_run_command( command => \@command, ); delete $state_of{$ident}->{offline}; delete $state_of{$ident}->{online}; $state_of{$ident}->{restricted} = 1; return 1; } } sub _parse_vol_status_headers { my $class = shift; my $header = shift; my $indices = {}; my $index = 0; my ($volume) = ( $header =~ /(^\s+Volume\s+)/ ) or croak( "Unable to match 'Volume' column header\n" ); $indices->{volume} = [ 0, length($volume) ]; $index += length($volume); my ($state) = ( $header =~ /(State\s+)/ ) or croak( "Unable to match 'State' column header\n" ); $indices->{state} = [ $index, length($state) ]; $index += length($state); my ($status) = ( $header =~ /(Status\s+)/ ) or croak( "Unable to match 'Status' column header\n" ); $indices->{status} = [ $index, length($status) ]; $index += length($status); my ($options) = ( $header =~ /(Options\s*)/ ) or croak( "Unable to match 'Options' column header\n" ); $indices->{options} = [ $index ]; if ( $header =~ /Source/ ) { $indices->{options}->[1] = length($options); $index += length($options); $indices->{source} = [ $index ]; } $indices->{length} = $index + 1; return $indices; } sub _parse_vol_status_volume { my $class = shift; my %args = validate( @_, { indices => { type => HASHREF }, line => { type => SCALAR }, volume => { type => HASHREF, default => {}, optional => 1 }, }); my $indices = $args{indices}; my $volume = $args{volume}; my $line = $args{line}; if ( $line =~ /Clone, backed by volume '(.*)', snapshot '(.*)'/ ) { $volume->{parent_name} = $1; $volume->{snapshot_name} = $2; return $volume; } elsif ( $line =~ /Volume has clones: (.*)/ ) { my $clones = $1; $volume->{clone_names} = [ split( /[,\s]+/, $clones ) ]; return $volume; } elsif ( $line =~ /Containing aggregate: (\S+)/ ) { my $aggrname = $1; $aggrname =~ s/'//g; if ( $aggrname ne '' ) { $volume->{aggregate_name} = $aggrname; } return $volume; } if ( length($line) < $indices->{length} ) { $line .= " " x ( $indices->{length} - length($line) ); } foreach my $column ( qw( volume state status options source ) ) { my $value = ""; next unless $indices->{$column}; if ( defined $indices->{$column}->[1] ) { $value = substr( $line, $indices->{$column}->[0], $indices->{$column}->[1] ); } else { $value = substr( $line, $indices->{$column}->[0] ); } $value =~ s/$RE{ws}{crop}//g; if ( $column eq 'volume' ) { if ( $value ) { $volume->{name} = $value; my ($name) = split( /\s+/, $line ); if ( length($name) > length($value) ) { $volume->{name} = $name; $line =~ s/^$name/$value/; } } } elsif ( $column eq 'source' ) { my ($hostname,$source) = split( /:/, $value ); $volume->{source} = { hostname => $hostname, volume => $source, }; $indices->{options}->[1] = undef; delete $indices->{source}; } else { foreach my $entry ( split( /[,\s]+/, $value ) ) { my ($key,$value); if ( $entry =~ /=/ ) { ($key,$value) = split( /=/, $entry, 2 ); } else { ($key,$value) = ($entry,1); } $volume->{$column}->{$key} = $value; } } } return $volume; } 1; NetApp-500.002/lib/NetApp/Volume.pod000644 067073 067073 00000017670 11113273352 017660 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Volume -- OO class for creating and managing NetApp filer volumes =head1 SYNOPSIS use NetApp::Filer; use NetApp::Aggregate; my $filer = NetApp::Filer->new({ .... }); my @volume_names = $filer->get_volume_names; my @volumes = $filer->get_volumes; my $volume = $filer->get_volume( 'volname' ); =head1 DESCRIPTION This class encapsulates a single NetApp filer volume, and provides methods for querying information about the volume and it's sub-objects (eg. qtrees), as well as methods for managing the volume itself. =head1 INSTANCE METHODS =head2 get_filer Returns the NetApp::Filer object representing the filer on which the aggregate exists. =head2 get_name Returns the name of the volume as a string. =head2 get_states, get_statuses, get_options Each of these methods returns a list of strings, each of which represents a single state, status, or option for the volume. NOTE: All you English grammar pluralization rules fanatics can give up trying to convince the author to call that one method get_stati. =head2 get_state( $state ), get_status( $status ), get_option( $option ) Each of these methods returns the value for the specified state, status or option. If that particular key wasn't present, then this method will return undef. This makes it easy to tell the difference between a key that doesn't exist, and one that has a false value. =head2 set_option( $option => $value ) This method sets a single option to the specified value. It always returns true, and raises a fatal exception if it can not set the option. =head2 get_aggregate_name Returns the name of the aggregate on which the volume lives. For a "traditonal" volume, this will be a false value. =head2 get_aggregate Returns the NetApp::Aggregate object representing the aggregate on which the volume lives. For a "traditonal" volume, this will be a false value. =head2 get_qtree_names Returns a list of strings, each of which is the name of a qtree on the volume. =head2 get_qtrees Returns a list of NetApp::Qtree objects, each of which represents a single qtree on the volume. =head2 get_qtree( $name ) Returns a single NetApp::Qtree object for the specified qtree name. The name must in the form of a pathname, for example: /vol/volume_name/qtree_name The qtree_name is optional if querying the object for a volume's qtree. This method simply returns nothing if the specified qtree doesn't exist on the volume. =head2 get_language Returns a string representing the language code for the volume. =head2 set_language( $language ) Set the language code to the specified value. Always returns a true value, or raises a fatal exception if the language code can not be set. =head2 get_size Returns the size of the volume as a string. =head2 set_size( $size ) This method sets the size of the volume to the specified value. In all cases, the $size value is of the same form accepted by the create() method, and the underlying ONTAP CLI command: [+|-] k|m|g|t =head2 get_maxfiles Returns the maxfiles value for the volume. =head2 set_maxfiles( $maxfiles ) Sets the maxfiles value for the volume. =head2 is_clone Returns true if the volume is a clone, false otherwise. =head2 get_parent_name Returns a string representing the name of the parent volume, if this volume is a clone. =head2 get_parent Returns a NetApp::Volume object representing the parent volume, if this volume is a clone. =head2 get_snapshot_name Returns a string representing the snapshot name, if the volume is a clone. =head2 get_snapshot NOT YET IMPLEMENTED. This will return a NetApp::Snapshot object, once the API is extended to support snapshots (RSN, I'm sure...) =head2 get_snapmirrors Returns a list of NetApp::Snapmirror objects, each of which represents a snapmirror relationship for this volume. =head2 offline( %args ) Takes the volume offline. The arguments are as follows: $volume->offline( # Optional arguments cifsdelaytime => $cifsdelaytime, ); =head2 online( %args ) Bring the volume online. The arguments are as follows: $volume->online( # Optional arguments force => 1, ); =head2 rename( %args ) Renames the volume to the specified newname. Always returns a true value, and raises a fatal exception if the name can not be changed. The arguments are as follows: $volume->rename( # Required arguments newname => $newname, ); =head2 restrict( %args ) Puts the volume into the restricted state. The arguments are as follows: $volume->restrict( # Optional arguments cifsdelaytime => $cifsdelaytime, ); =head2 Snapshot Specific Methods =head3 get_snapshots Returns a list of NetApp::Snapshot objects for each of the snapshots of the volume. =head3 get_snapshot( $name ) Returns a single NetApp::Snapshot object matching the specified name, if it exists for the volume. =head3 create_snapshot( $name ) Creates a snapshot of the volume with the specified name. =head3 delete_snapshot( $name ) Deletes a snapshot of the volume with the specified name. =head3 get_snapshot_deltas Returns a list of NetApp::Snapshot::Delta objects for each snapshot delta for the volume. =head3 get_snapshot_reserved Returns a string representing the amount of reserved space, as a percentage. This string does NOT include the % sign. =head3 set_snapshot_reserved( $percentage ) Sets the snapshot reserved space to the specified percentage, which should also NOT include the % sign. =head3 get_snapshot_schedule Returns a NetApp::Snapshot::Schedule object representing the snapshot schedule for the volume. =head3 set_snapshot_schedule( %args ) Sets the snapshot schedule for the volume based on the arguments passed. The argument syntax is: $volume->set_snapshot_schedule( weekly => $weekly, daily => $daily, hourly => $hourly, hourlist => [ $hour1, $hour2, $hour3, .... ], ); =head3 enable_shapshot_autodelete This method turns on snapshot autodelete for the volume. =head3 disable_snapshot_autodelete This method turns off snapshot autodelete for the volume. =head3 reset_snapshot_autodelete This method resets snapshot autodelete for the volume to the filer defaults. =head3 set_snapshot_autodelete_option( $name => $value ) Sets the specified snapshot autodelete option ($name) to the specified $value. =head3 get_snapshot_autodelete_option( $name ) Returns the value of the specified autodelete option ($name). Note that if the prefix is "(not specified)", then the value returned is the empty string. =head1 UNIMPLEMENTED COMMANDS The following ONTAP vol commands are not implemented, because the same functionality and information is provided through this API via some other means. =head2 container The aggregate containing the volume can be obtained using: $volume->get_aggregate; which will return the NetApp::Aggregate object for it. =head1 TO BE IMPLEMENTED All other commands will be implemented in a future release of this API. Commands for flexible volumes will most likely have preference over traditional volumes. =head2 autosize It's not yet clear just how this one should be implemented, since the command does several things. It enables and disables the autosize feature, or resets it to defaults, and it also sets the maximum and incremental sizes to autosize to. This could be implemented a few different ways, for example: $volume->autosize( # Optional arguments maximum => $maximum, incremental => $incremental, # Optional, but mutually exclusive: on => 1, off => 1, reset => 1, ); That seems a little clumsy, though. Perhaps a better interface would be to have methods to control the state of the feature: $volume->enable_autosize; $volume->disable_autosize; $volume->reset_autosize; and then methods to set/get the autosize values: $volume_set_autosize( # Required but mutually exclusive options maximum => $maximum, incremental => $incremental, ); $volume->get_autosize; =cut NetApp-500.002/lib/NetApp/Volume/Source.pm000644 067073 067073 00000001161 11763415630 020746 0ustar00pmoorepmoore000000 000000 package NetApp::Volume::Source; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use Class::Std; use Params::Validate qw( :all ); { my %hostname_of :ATTR( get => 'hostname' ); my %volume_of :ATTR( get => 'volume' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { hostname => { type => SCALAR }, volume => { type => SCALAR }, }); $hostname_of{$ident} = $args{hostname}; $volume_of{$ident} = $args{volume}; } } 1; NetApp-500.002/lib/NetApp/Snapshot/Delta.pm000644 067073 067073 00000003673 11763415614 021103 0ustar00pmoorepmoore000000 000000 package NetApp::Snapshot::Delta; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use Carp; use Class::Std; use Params::Validate qw( :all ); { my %from_of :ATTR( get => 'from' ); my %to_of :ATTR( get => 'to' ); my %changed_of :ATTR( get => 'changed' ); my %time_of :ATTR( get => 'time' ); my %rate_of :ATTR( get => 'rate' ); my %summary_of :ATTR( get => 'summary' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { from => { type => SCALAR }, to => { type => SCALAR }, changed => { type => SCALAR }, time => { type => SCALAR }, rate => { type => SCALAR }, summary => { type => SCALAR }, }); $from_of{$ident} = $args{from}; $to_of{$ident} = $args{to}; $changed_of{$ident} = $args{changed}; $time_of{$ident} = $args{time}; $rate_of{$ident} = $args{rate}; $summary_of{$ident} = $args{summary}; } sub is_summary { return shift->get_summary; } } sub _parse_snap_delta { my $class = shift; my $line = shift; $line =~ s/Active File System/active/g; my @line = split /\s+/, $line; my $from = shift @line; my $to = shift @line; my $changed = shift @line; my $time = shift @line; my $next = shift @line; my $rate; if ( $next =~ /^\d{2}:\d{2}$/ ) { $time .= " $next"; $rate = shift @line; } else { $rate = $next; } if ( @line || ! defined $from || ! defined $to || ! defined $changed || ! defined $time || ! defined $rate ) { croak("Unable to parse snapshot delta: $line\n"); } return { from => $from, to => $to, changed => $changed, time => $time, rate => $rate, }; } 1; NetApp-500.002/lib/NetApp/Snapshot/Delta.pod000644 067073 067073 00000001545 11113273352 021233 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Snapshot::Delta -- OO class which represents a single snapshot delta =head1 SYNOPSIS use NetApp::Filer; use NetApp::Snapshot; my $filer = NetApp::Filer->new({ .... }); my $volume = $filer->get_volume( $volname ); my @deltas = $volume->get_snapshot_deltas; foreach my $snapshot ( $volume->get_snapshots ) { my @deltas = $snapshot->get_snapshot_deltas; } =head1 DESCRIPTION This class encapsulates a single snapshot delta. =head1 INSTANCE METHODS There are 5 key instance methods, each of this returns the data from the column of the same name in the snap delta table. =over =item get_from =item get_to =item get_changed =item get_time =item get_rate =back =head2 is_summary This method returns true of false, indicating that the delta was a summary, as opposed to an individual delta. =cut NetApp-500.002/lib/NetApp/Snapshot/Schedule.pm000644 067073 067073 00000003265 11763415620 021600 0ustar00pmoorepmoore000000 000000 package NetApp::Snapshot::Schedule; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use Carp; use Class::Std; use Params::Validate qw( :all ); { my %parent_of :ATTR( get => 'parent' ); my %weekly_of :ATTR( get => 'weekly' ); my %daily_of :ATTR( get => 'daily' ); my %hourly_of :ATTR( get => 'hourly' ); my %hourlist_of :ATTR; sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { parent => { type => OBJECT }, weekly => { type => SCALAR }, daily => { type => SCALAR }, hourly => { type => SCALAR }, hourlist => { type => ARRAYREF, default => [], optional => 1 }, }); $parent_of{$ident} = $args{parent}; $weekly_of{$ident} = $args{weekly}; $daily_of{$ident} = $args{daily}; $hourly_of{$ident} = $args{hourly}; $hourlist_of{$ident} = $args{hourlist}; } sub get_hourlist { return @{ $hourlist_of{ident shift} }; } } sub _parse_snap_sched { my $class = shift; my $line = shift; my ($weekly,$daily,$hourly,$hourlist) = (split( /[@\s]+/, $line ))[2..5]; if ( $hourlist ) { $hourlist = [ split( /,/, $hourlist ) ]; } else { $hourlist = []; } if ( $weekly !~ /^\d+$/ || $daily !~ /^\d+$/ || $hourly !~ /^\d+$/ ) { croak("Unable to parse snap sched: $line\n"); } return { weekly => $weekly, daily => $daily, hourly => $hourly, hourlist => $hourlist, }; } 1; NetApp-500.002/lib/NetApp/Snapshot/Schedule.pod000644 067073 067073 00000002010 11113273352 021722 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Snapshot::Schedule -- OO class which represents a snapshot schedule =head1 SYNOPSIS use NetApp::Filer; use NetApp::Aggregate; use NetApp::Volume; use NetApp::Snapshot; my $filer = NetApp::Filer->new({ .... }); my $volume = $filer->get_volume( $volname ); my $schedule = $volume->get_snapshot_schedule; $volume->set_snapshot_schedule( weekly => 0, daily => 2, hourly => 4, hourlist => [ 4, 8, 12, 16 ], ); =head1 DESCRIPTION This class encapsulates a snapshot schedule for an aggregate of volume. =head1 INSTANCE METHODS =head2 get_parent This method returns the parent object for the schedule, which is either a NetApp::Aggregate or NetApp::Volume object. =head2 get_weekly, get_daily, get_hourly These methods return the number of weekly, daily, or hourly snapshots in the schedule. =head2 get_hourlist This method returns a list of integers, each of which is one of the hours at which to create an hourly snapshot. =cut NetApp-500.002/lib/NetApp/Snapmirror/Destination.pm000644 067073 067073 00000001173 11763415601 022655 0ustar00pmoorepmoore000000 000000 package NetApp::Snapmirror::Destination; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use Class::Std; use Params::Validate qw( :all ); { my %hostname_of :ATTR( get => 'hostname' ); my %volume_of :ATTR( get => 'volume' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { hostname => { type => SCALAR }, volume => { type => SCALAR }, }); $hostname_of{$ident} = $args{hostname}; $volume_of{$ident} = $args{volume}; } } 1; NetApp-500.002/lib/NetApp/Snapmirror/Source.pm000644 067073 067073 00000001166 11763415604 021641 0ustar00pmoorepmoore000000 000000 package NetApp::Snapmirror::Source; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use Class::Std; use Params::Validate qw( :all ); { my %hostname_of :ATTR( get => 'hostname' ); my %volume_of :ATTR( get => 'volume' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { hostname => { type => SCALAR }, volume => { type => SCALAR }, }); $hostname_of{$ident} = $args{hostname}; $volume_of{$ident} = $args{volume}; } } 1; NetApp-500.002/lib/NetApp/Filer/Export.pm000644 067073 067073 00000030366 11763415546 020600 0ustar00pmoorepmoore000000 000000 package NetApp::Filer::Export; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use Carp; use Class::Std; use Params::Validate qw( :all ); { my %filer_of :ATTR( get => 'filer' ); my %type_of :ATTR( get => 'type' ); my %active_of :ATTR( get => 'active', set => 'active' ); my %path_of :ATTR( get => 'path' ); my %actual_of :ATTR( get => 'actual' ); my %nosuid_of :ATTR( get => 'nosuid', set => 'nosuid' ); my %anon_of :ATTR( get => 'anon', set => 'anon' ); my %sec_of :ATTR; my %root_of :ATTR; my %rw_all_of :ATTR( get => 'rw_all' ); my %ro_all_of :ATTR( get => 'ro_all' ); my %rw_of :ATTR; my %ro_of :ATTR; sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { filer => { isa => 'NetApp::Filer' }, type => { type => SCALAR, default => 'permanent', regex => qr{^(permanent|temporary)$}, optional => 1 }, active => { type => SCALAR, default => 1, optional => 1 }, path => { type => SCALAR }, actual => { type => SCALAR, default => "", optional => 1 }, nosuid => { type => SCALAR, default => 0, optional => 1 }, anon => { type => SCALAR | UNDEF, default => undef, optional => 1 }, sec => { type => ARRAYREF, default => [qw(sys)], optional => 1 }, root => { type => ARRAYREF, default => [], optional => 1 }, rw_all => { type => SCALAR, optional => 1 }, rw => { type => ARRAYREF, default => [], optional => 1 }, ro_all => { type => SCALAR, optional => 1 }, ro => { type => ARRAYREF, default => [], optional => 1 }, }); if ( exists $args{rw_all} && @{ $args{rw} } ) { croak("Mutually exclusive arguments: rw_all and rw\n"); } if ( exists $args{ro_all} && @{ $args{ro} } ) { croak("Mutually exclusive arguments: ro_all and ro\n"); } if ( ! @{ $args{rw} } && ! exists $args{rw_all} && ! @{ $args{ro} } && ! exists $args{ro_all} ) { $args{rw_all} = 1; } $filer_of{$ident} = $args{filer}; $path_of{$ident} = $args{path}; $type_of{$ident} = $args{type}; $active_of{$ident} = $args{active}; $actual_of{$ident} = $args{actual}; $nosuid_of{$ident} = $args{nosuid}; $anon_of{$ident} = $args{anon}; $sec_of{$ident} = $args{sec}; $root_of{$ident} = $args{root}; if ( $args{rw_all} ) { $rw_all_of{$ident} = $args{rw_all}; $rw_of{$ident} = []; } else { $rw_of{$ident} = $args{rw}; } if ( $args{ro_all} ) { $ro_all_of{$ident} = $args{ro_all}; $ro_of{$ident} = []; } else { $ro_of{$ident} = $args{ro}; } } sub get_rw { my $self = shift; my $ident = ident $self; return @{ $rw_of{$ident} }; } sub set_rw_all { my $self = shift; my $ident = ident $self; my ($rw_all) = validate_pos( @_, { type => BOOLEAN } ); $rw_of{$ident} = []; $rw_all_of{$ident} = $rw_all; } sub set_rw { my $self = shift; my $ident = ident $self; my ($rw) = validate_pos( @_, { type => ARRAYREF } ); $self->set_rw_all(0); $rw_of{$ident} = $rw; } sub has_rw { my $self = shift; my $ident = ident $self; my ($rw) = validate_pos( @_, { type => SCALAR } ); return grep { $_ eq $rw } @{ $rw_of{$ident} }; } sub add_rw { my $self = shift; my $ident = ident $self; my ($rw) = validate_pos( @_, { type => SCALAR } ); if ( $self->get_rw_all ) { return; } else { if ( not $self->has_rw( $rw ) ) { push @{ $rw_of{$ident} }, $rw; } } return 1; } sub remove_rw { my $self = shift; my $ident = ident $self; my ($rw) = validate_pos( @_, { type => SCALAR } ); if ( $self->get_rw_all ) { return; } else { if ( $self->has_rw( $rw ) ) { $rw_of{$ident} = [ grep { $_ ne $rw } @{ $rw_of{$ident} } ]; } } return 1; } sub get_ro { my $self = shift; my $ident = ident $self; return @{ $ro_of{$ident} }; } sub set_ro_all { my $self = shift; my $ident = ident $self; my ($ro_all) = validate_pos( @_, { type => BOOLEAN } ); $ro_of{$ident} = []; $ro_all_of{$ident} = $ro_all; } sub set_ro { my $self = shift; my $ident = ident $self; my ($ro) = validate_pos( @_, { type => ARRAYREF } ); $self->set_ro_all(0); $ro_of{$ident} = $ro; } sub has_ro { my $self = shift; my $ident = ident $self; my ($ro) = validate_pos( @_, { type => SCALAR } ); return grep { $_ eq $ro } @{ $ro_of{$ident} }; } sub add_ro { my $self = shift; my $ident = ident $self; my ($ro) = validate_pos( @_, { type => SCALAR } ); if ( $self->get_ro_all ) { return; } else { if ( not $self->has_ro( $ro ) ) { push @{ $ro_of{$ident} }, $ro; } } return 1; } sub remove_ro { my $self = shift; my $ident = ident $self; my ($ro) = validate_pos( @_, { type => SCALAR } ); if ( $self->get_ro_all ) { return; } else { if ( $self->has_ro( $ro ) ) { $ro_of{$ident} = [ grep { $_ ne $ro } @{ $ro_of{$ident} } ]; } } return 1; } sub get_sec { my $self = shift; my $ident = ident $self; return @{ $sec_of{$ident} }; } sub set_sec { my $self = shift; my $ident = ident $self; my ($sec) = validate_pos( @_, { type => ARRAYREF } ); $sec_of{$ident} = $sec; } sub has_sec { my $self = shift; my $ident = ident $self; my ($sec) = validate_pos( @_, { type => SCALAR } ); return grep { $_ eq $sec } @{ $sec_of{$ident} }; } sub add_sec { my $self = shift; my $ident = ident $self; my ($sec) = validate_pos( @_, { type => SCALAR } ); if ( not $self->has_sec( $sec ) ) { push @{ $sec_of{$ident} }, $sec; } } sub remove_sec { my $self = shift; my $ident = ident $self; my ($sec) = validate_pos( @_, { type => SCALAR } ); if ( $self->has_sec( $sec ) ) { $sec_of{$ident} = [ grep { $_ ne $sec } @{ $sec_of{$ident} } ]; } } sub get_root { my $self = shift; my $ident = ident $self; return @{ $root_of{$ident} }; } sub set_root { my $self = shift; my $ident = ident $self; my ($root) = validate_pos( @_, { type => ARRAYREF } ); $root_of{$ident} = $root; } sub has_root { my $self = shift; my $ident = ident $self; my ($root) = validate_pos( @_, { type => SCALAR } ); return grep { $_ eq $root } @{ $root_of{$ident} }; } sub add_root { my $self = shift; my $ident = ident $self; my ($root) = validate_pos( @_, { type => SCALAR } ); if ( not $self->has_root( $root ) ) { push @{ $root_of{$ident} }, $root; } } sub remove_root { my $self = shift; my $ident = ident $self; my ($root) = validate_pos( @_, { type => SCALAR } ); if ( $self->has_root( $root ) ) { $root_of{$ident} = [ grep { $_ ne $root } @{ $root_of{$ident} } ]; } } sub update { my $self = shift; my $ident = ident $self; my @options = (); if ( $self->get_actual ) { push @options, "actual=" . $self->get_actual; } if ( defined $self->get_anon ) { push @options, "anon=" . $self->get_anon; } if ( $self->get_nosuid ) { push @options, "nosuid"; } if ( $self->get_ro_all ) { push @options, "ro"; } elsif ( my @ro = $self->get_ro ) { push @options, "ro=" . join( ':', @ro ); } if ( $self->get_rw_all ) { push @options, "rw"; } elsif ( my @rw = $self->get_rw ) { push @options, "rw=" . join( ':', @rw ); } if ( my @root = $self->get_root ) { push @options, "root=" . join( ':', @root ); } if ( my @sec = $self->get_sec ) { push @options, "sec=" . join( ':', @sec ); } my $options = join ',', @options; my $argument = $self->get_type eq 'permanent' ? '-p' : '-io'; $self->get_filer->_run_command( command => [ 'exportfs', $argument, $options, $self->get_path, ], ); if ( $self->get_type eq 'permanent' ) { $active_of{$ident} = 1; } return 1; } sub compare { my $self = shift; my ($other) = validate_pos( @_, { isa => 'NetApp::Filer::Export' }, ); if ( $self->get_actual ne $other->get_actual ) { return; } if ( $self->get_nosuid ne $other->get_nosuid ) { return; } if ( defined $self->get_anon && defined $other->get_anon ) { if ( $self->get_anon ne $other->get_anon ) { return; } } elsif ( defined $self->get_anon || defined $other->get_anon ) { return; } if ( $self->get_rw_all && ! $other->get_rw_all ) { return; } if ( ! $self->get_rw_all && $other->get_rw_all ) { return; } if ( $self->get_ro_all && ! $other->get_ro_all ) { return; } if ( ! $self->get_ro_all && $other->get_ro_all ) { return; } if ( join( ',', sort $self->get_rw) ne join( ',', sort $other->get_rw ) ) { return; } if ( join( ',', sort $self->get_ro) ne join( ',', sort $other->get_ro ) ) { return; } if ( join( ',', sort $self->get_sec) ne join( ',', sort $other->get_sec ) ) { return; } if ( join( ',', sort $self->get_root) ne join( ',', sort $other->get_root ) ) { return; } return 1; } } sub _parse_export { my $class = shift; my $line = shift; chomp($line); $line =~ s/\s*$//; my ($path,$options) = split /\s+/, $line, 2; chomp($options); $options =~ s/^-//; my $export = { path => $path, }; foreach my $option ( split /,/, $options ) { my ($key,$value) = split /=/, $option; if ( $key eq 'nosuid' ) { $export->{$key} = 1 } elsif ( $key eq 'ro' || $key eq 'rw' ) { if ( $value ) { $export->{$key} = [ split /:/, $value ]; } else { $export->{ $key . '_all' } = 1; } } elsif ( $key eq 'sec' || $key eq 'root' ) { $export->{$key} = [ split /:/, $value ]; } elsif ( $key eq 'actual' || $key eq 'anon' ) { $export->{$key} = $value; } else { croak( "Unrecognized export option '$key'\n", "Exports entry: $line\n", ); } } return $export; } 1; NetApp-500.002/lib/NetApp/Filer/Export.pod000644 067073 067073 00000022532 11113273352 020724 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Filer::Export -- OO Class for representing NFS exports =head1 SYNOPSIS use NetApp::Filer; my $filer = NetApp::Filer->new({ ... }); # Filer methods for querying exports: my @exports = $filer->get_exports; my @temporary_exports = $filer->get_temporary_exports; my @permanent_exports = $filer->get_permanent_exports; my @active_exports = $filer->get_active_exports; my @inactive_exports = $filer->get_inactive_exports; # Methods for accessing export attributes foreach my $export ( @exports ) { } # Methods for changing export attributes =head1 DESCRIPTION This class encapsulates a single NFS export on a NetApp filer, and provides methods for managing them. There are related methods in the NetApp::Filer class for manging exports as a whole, but the methods in this class are specific to a single NFS export. =head2 API specific attributes This API also attempts to bring some sanity to how exports are managed, and some consistency to the interface. Most of the attributes of an export are fairly obvious, and they map directly to the options supported by "exportfs" and the /etc/exports file. This API introduces two new attributes: 'type' and 'active'; =head3 The type attribute In order to distinguish between exports which are temporary (i.e. NOT saved to /etc/exports) and those which are permanent (i.e. ARE saved to /etc/exports), this API support a "type", which be either of: permanent temporary A temporary export is one which was created using "exportfs -io", and which was not saved to /etc/exports. These exports will not survive a reboot of the filer. A permanent export is one which is found in /etc/exports. =head3 The active attribute Since you can change the export options for a filesystem temporarily (for example, by using the "fencing" option -b, or just manually specifying different options and re-exporting using -io), some permanent exports may not be in effect on the system. The active attribute is used to track these. If the active attribute is true, then the export is currently in effect. Almost by definition, all temporary exports are always active. However, if a permanent export is not in effect because a temporary export for the same pathname has been created, then such an export is considerd inactive. =head2 Global vs. Limited ro/rw Attributes The "ro" and "rw" export options really have two different modes of use. If either option is specified with no "=a[:b[:c...]]" list, then it means ALL hosts. Since this API provides methods for adding and removing entries from those lists, it treats the "all" cases special, by managing thenm as separate attributes. To specify global readonly or readwrite access, use the following options: ro_all rw_all These have boolean values. The "rw" and "ro" attributes/options are ARRAY references, each containing the list of entries for an "rw=" or "ro=" list for managing limited access. =head2 Change and Update Semantics There are several methods for changing the attributes of an export object, but in ALL cases, these merely change the object in memory. In order for the attribute change to take effect, the update method must be called, which will generate and execute the appropriate "exportfs" command. For example, suppose you wanted to remove root access for a specific hostname from all exports on a filer: my $untrusted = 'unsafe.foo.com'; my @exports = $filer->get_exports; foreach my $export ( @exports ) { if ( $export->has_root( $untrusted ) ) { $export->remove_root( $untrusted ); $export->update; } } The "remove_root" method simply removes the entry from the object in memory. The "update" method re-exports that filesystem to make the change take effect on the filer. =head1 METHODS =head2 get_filer Returns the NetApp::Filer object for the filer on which this export exists. =head2 get_type Returns a string with one of the following values: temporary permanent indicating whether or not this particular export has been written to /etc/exports. =head2 get_active Returns a boolean value, false only if the type is "permanent", and the same export was not found in the list of currently active exports (i.e. not found in the output of "exportfs"). A temporary export is always active, by definition. =head2 get_path Returns a string representing the path for the export. Note that this may not necessarily be the same as the actual pathname of the underlying volume or qtree. =head2 get_actual Returns a string representing the "actual" path of the underlying volume or qtree for the export. If a volume or qtree as been exported using a different name, this is the actual path of the underlying object. If this export option was not used, this method will return an empty string. =head2 get_nosuid Returns a boolean value, indicating whether or not the "nosuid" option is used by the export. =head2 set_nosuid( $boolean ) This method takes a single argument, interpreted in boolean context, an sets the "nosuid" option for the export. =head2 get_anon Returns the value of the "anon" option, if set. Since this option can have the value of "0", it returns undef when this option has not been set. WARNING: be careful interpreting this in a simple boolean context. To test whether or not this option has been set use "defined". =head2 set_anon( $anon ) Takes a single argument, and sest the "anon" opton to that value. To unset this option, pass an undefined value: $export->set_anon( undef ); =head2 get_sec Returns a list of the "sec" option values. =head2 set_sec( $arrayref ) Takes a single argument, an array reference of "sec" values, which can be any of: none, sec, krb5, krb5i, or krb5p. This API does no validation of these values, so if an invalid value is given, this will result in a fatal exception when the "update" method is called. =head2 has_sec( $sec ) Takes a single string argument, and returns true if that value is found in the list of "sec" options, false otherwise. =head2 add_sec( $sec ) Takes a single string argument, and adds that value to the list of "sec" options, if not already present. =head2 remove_sec( $sec ) Takes a single string argument, and removes that value from the list of "sec" options, if present. =head2 get_root Returns a list of the "root" option values. =head2 set_root( $arrayref ) Takes a single argument, an array reference of "root" values, which can be any combination of hostnames, IP addresses, or networks. Again, no data validation is performed, so bogus values will not be detected until the export is updated on the filer, using the "update" method. To clear the root option entirely, simply pass an empty array reference. =head2 has_root( $root ) Takes a single string argument, and returns true if that value is found in the list of "root" options, false otherwise. =head2 add_root( $root ) Takes a single string argument, and adds that value to the list of "root" options, if not already present. =head2 remove_root( $root ) Takes a single string argument, and removes that value from the list of "root" options, if present. =head2 get_ro_all Returns a boolean value, indicating whether or not the "ro_all" option has been set. =head2 set_ro_all( $boolean ) Takes a single boolean argument, and sets the "ro_all" option to it's value. Setting "ro_all" to a true value will clear the "ro" list, if it exists. Also, if "ro_all" is true, then the following methods will quietly do nothing: has_ro add_ro remove_ro The "ro_all" option must be cleared (set to a false value) first. =head2 get_ro Returns a list of the "ro" entries, if any. Returns nothing if "ro_all" has been set. =head2 set_ro( $arrayref ) Takes a single argument, an array reference of "ro" values. Setting the "ro" list explicitly will set clear "ro_all" (set it to a false value). =head2 has_ro( $ro ) Takes a single argument, and returns true if that value is found in the list of "ro" options, false otherwise. If "ro_all" is true, then it always returns false. =head2 add_ro( $ro ) Takes a single string argument, and adds that value to the list of "ro" options, if not already present. If "ro_all" is true, then this method will do nothing. =head2 remove_ro( $ro ) Takes a single string argument, and removes that value from the list of "ro" options, if present. If "ro_all" is true, then this method does nothing. =head2 get_rw_all, set_rw_all, get_rw, set_rw, has_rw, add_rw, remove_rw All of these methods behave exactly the same as their "ro" counterparts described immediately above. They apply to the "rw" option, instead of "ro", but if that isn't obvious... =head2 update This method re-exports the export, using "exportfs". If ANY of the object attributes have been changed programmatically, those changes will not take effect on the filer until this method has been called. Note that updating an export will not necessarily change it's "type" from temporary to permanent, unless the "type" is explicitly changed. =head2 compare( $export ) This method takes a single NetApp::Filer::Export object, and compares the current object (that is, the one on which the method was called) to it. If they have the same basic export options, it returns true, otherwise, it returns false. Only the following options are compared: actual nosuid anon sec root rw/rw_all ro/ro_all =cut NetApp-500.002/lib/NetApp/Filer/License.pm000644 067073 067073 00000001554 11763415552 020673 0ustar00pmoorepmoore000000 000000 package NetApp::Filer::License; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use Class::Std; use Params::Validate qw( :all ); { my %service_of :ATTR( get => 'service' ); my %type_of :ATTR( get => 'type' ); my %code_of :ATTR( get => 'code' ); my %expired_of :ATTR( get => 'expired' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { service => { type => SCALAR }, type => { type => SCALAR }, code => { type => SCALAR }, expired => { type => SCALAR }, }); $service_of{$ident} = $args{service}; $type_of{$ident} = $args{type}; $code_of{$ident} = $args{code}; $expired_of{$ident} = $args{expired}; } } 1; NetApp-500.002/lib/NetApp/Filer/License.pod000644 067073 067073 00000001534 11113273352 021024 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Filer::License -- OO Class for representing NetApp Filer licenses =head1 SYNOPSIS use NetApp::Filer; my $filer = NetApp::Filer->new({ ... }); my @licenses = $filer->get_licenses; $filer->add_license( $code ); $filer->delete_license( 'cifs' ); my $license = $filer->get_license( 'nfs' ); =head1 DESCRIPTION This class is used to encapsulate the NetApp Filer license information. =head1 METHODS =head2 get_service Returns the name of the service for the license. =head2 get_type Returns either 'site' or 'node', depending on whether or not the license was in fact a site license. =head2 get_code Returns the code for the license =head2 get_expired Returns a false value if the license is not expired, and if it is expired, it returns the data the license expired, for example: "26 Jun 2008" =cut NetApp-500.002/lib/NetApp/Filer/Option.pm000644 067073 067073 00000001142 11763415556 020556 0ustar00pmoorepmoore000000 000000 package NetApp::Filer::Option; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use Class::Std; use Params::Validate qw( :all ); { my %name_of :ATTR( get => 'name' ); my %value_of :ATTR( get => 'value' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { name => { type => SCALAR }, value => { type => SCALAR }, }); $name_of{$ident} = $args{name}; $value_of{$ident} = $args{value}; } } 1; NetApp-500.002/lib/NetApp/Filer/Option.pod000644 067073 067073 00000001031 11117736072 020711 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Filer::Option -- OO Class for representing NetApp Filer options =head1 SYNOPSIS use NetApp::Filer; my $filer = NetApp::Filer->new({ ... }); my @options = $filer->get_options; my $options = $filer->get_option( $name ); $filer->set_option( name => $name, value => $value, ); =head1 DESCRIPTION This class is used to encapsulate the NetApp Filer options. =head1 METHODS =head2 get_name Returns the name of the option. =head2 get_value Returns the value for the option. =cut NetApp-500.002/lib/NetApp/Filer/TimeoutCache.pm000644 067073 067073 00000002616 11763415564 021666 0ustar00pmoorepmoore000000 000000 package NetApp::Filer::TimeoutCache; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use English; use Carp; use Params::Validate qw( :all ); sub TIEHASH { my $class = shift; my (%args) = validate( @_, { lifetime => { type => SCALAR, regex => qr{^\d+$} }, }); if ( $args{lifetime} <= 0 ) { croak("Invalid argument: lifetime must be a positive integer\n"); } my %self = ( lifetime => $args{lifetime}, cache => {}, ); return bless \%self => $class; } sub STORE { my $self = shift; my ($key, $value) = @_; $self->{cache}->{$key} = { expiration => $self->{lifetime} + time, value => $value, }; return $value; } sub FETCH { my $self = shift; my $key = shift; return $self->{cache}->{$key}->{value}; } sub DELETE { my $self = shift; my $key = shift; my $value = $self->{cache}->{$key}->{value}; delete $self->{cache}->{$key}; return $value; } sub CLEAR { return shift->{cache} = {}; } sub EXISTS { my $self = shift; my $key = shift; if ( not exists $self->{cache}->{$key} ) { return 0; } my $data = $self->{cache}->{$key}; if ( $data->{expiration} > time ) { return 1; } else { return 0; } } 1; NetApp-500.002/lib/NetApp/Filer/Version.pm000644 067073 067073 00000002274 11763415571 020737 0ustar00pmoorepmoore000000 000000 package NetApp::Filer::Version; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use Carp; use Class::Std; use Params::Validate qw( :all ); use Data::Dumper; use overload '""' => 'get_string'; { my %string_of :ATTR( get => 'string' ); my %release_of :ATTR( get => 'release' ); my %major_of :ATTR( get => 'major' ); my %minor_of :ATTR( get => 'minor' ); my %subminor_of :ATTR( get => 'subminor' ); my %patchlevel_of :ATTR( get => 'patchlevel' ); my %date_of :ATTR( get => 'date' ); sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { string => { type => SCALAR }, }); $string_of{$ident} = $args{string}; $args{string} =~ m{ NetApp \s+ Release \s+ (\S+) : \s+ (.*) }gmx || croak ("Invalid version string: $args{string}\n"); $release_of{$ident} = $1; $date_of{$ident} = $2; ( $major_of{$ident}, $minor_of{$ident}, $subminor_of{$ident}, $patchlevel_of{$ident} ) = split( /[\.L]+/, $release_of{$ident} ); } } 1; NetApp-500.002/lib/NetApp/Filer/Version.pod000644 067073 067073 00000002520 11113273352 021063 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Filer::Version -- OO Class for representing NetApp Filer versions =head1 SYNOPSIS use NetApp::Filer; my $filer = NetApp::Filer->new({ ... }); # The "version" is: NetApp Release 7.2.2: Sat Mar 24 20:38:59 PDT 2007 my $version = $filer->get_version; # $version->isa("NetApp::Filer::Version") print $version->get_release, "\n"; # prints "7.2.2" print $version->get_date, "\n"; # prints "Sat Mar 24 20:38:59 PDT 2007" print $version->get_string, "\n"; print "$version\n"; # Both print the same thing, the second one through operator overloading, # namely the original, unparsed version string print $version->get_version, "\n"; # prints "v7.2.2" =head1 DESCRIPTION This class is used to encapsulate the NetApp Filer version string, and provide access to the components of the string as a numeric release, a perl version, and a date string. =head1 METHODS =head2 get_release Returns the NetApp numerical release as a string, for example: 7.2.2 =head2 get_date Returns the NetApp release date as a string, for example: Sat Mar 24 20:38:59 PDT 2007 =head2 get_string Returns the unparsed version string in it's entirety: NetApp Release 7.2.2: Sat Mar 24 20:38:59 PDT 2007 =head2 get_version Returns the NetApp release as a perl version object. =cut NetApp-500.002/lib/NetApp/Aggregate/Plex.pm000644 067073 067073 00000002437 11763415525 021047 0ustar00pmoorepmoore000000 000000 package NetApp::Aggregate::Plex; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use English; use Carp; use Class::Std; use Params::Validate qw( :all ); use Regexp::Common; { my %name_of :ATTR( get => 'name' ); my %state_of :ATTR; my %raidgroups_of :ATTR; sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { name => { type => SCALAR }, state => { type => HASHREF }, raidgroups => { type => ARRAYREF }, }); $name_of{$ident} = $args{name}; $state_of{$ident} = $args{state}; $raidgroups_of{$ident} = []; foreach my $raidgroup ( @{ $args{raidgroups} } ) { push @{ $raidgroups_of{$ident} }, NetApp::Aggregate::RAIDGroup->new( $raidgroup ); } } sub get_raidgroups { my $self = shift; my $ident = ident $self; return @{ $raidgroups_of{$ident} }; } sub get_states { return keys %{ $state_of{ident shift} }; } sub get_state { my $self = shift; my $ident = ident $self; my $state = shift; return $state_of{$ident}->{$state}; } } 1; NetApp-500.002/lib/NetApp/Aggregate/Plex.pod000644 067073 067073 00000001443 11113273352 021176 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Aggregate::Plex -- OO Class for representing NetApp plexes =head1 SYNOPSIS use NetApp::Filer; use NetApp::Aggregate; my $aggregate = $filer->get_aggregate( $name ); my $plex = $aggregate->get_plex; my @raidgroups = $plex->get_raidgroups; =head1 DESCRIPTION This class is used to encapsulate a NetApp plex, and provide access to the name and states of the plex. =head1 METHODS =head2 get_name Returns the name of the plex as a string. =head2 get_raidgroups Returns a list of NetApp::Aggregate::RAIDGroup objects, one for each RAIDGroup in the Plex. =head2 get_states Returns a list of strings, each of which represents a single state for the plex. =head2 get_state( $state ) Returns true if the plex has the given state, false otherwise. =cut NetApp-500.002/lib/NetApp/Aggregate/RAIDGroup.pm000644 067073 067073 00000001563 11763415531 021667 0ustar00pmoorepmoore000000 000000 package NetApp::Aggregate::RAIDGroup; our $VERSION = '500.002'; $VERSION = eval $VERSION; ## no critic: StringyEval use strict; use warnings; use English; use Carp; use Class::Std; use Params::Validate qw( :all ); use Regexp::Common; { my %name_of :ATTR( get => 'name' ); my %state_of :ATTR; sub BUILD { my ($self,$ident,$args_ref) = @_; my @args = %$args_ref; my (%args) = validate( @args, { name => { type => SCALAR }, state => { type => HASHREF }, }); $name_of{$ident} = $args{name}; $state_of{$ident} = $args{state}; } sub get_states { return keys %{ $state_of{ident shift} }; } sub get_state { my $self = shift; my $ident = ident $self; my $state = shift; return $state_of{$ident}->{$state}; } } 1; NetApp-500.002/lib/NetApp/Aggregate/RAIDGroup.pod000644 067073 067073 00000001255 11117736121 022025 0ustar00pmoorepmoore000000 000000 =head1 NAME NetApp::Aggregate::RAIDGroup -- OO Class for representing NetApp raidgroups =head1 SYNOPSIS use NetApp::Filer; use NetApp::Aggregate; my $aggregate = $filer->get_aggregate( $name ); my $raidgroup = $aggregate->get_raidgroup; =head1 DESCRIPTION This class is used to encapsulate a NetApp raidgroup, and provide access to the name and states of the raidgroup. =head1 METHODS =head2 get_name Returns the name of the raidgroup as a string. =head2 get_states Returns a list of strings, each of which represents a single state for the raidgroup. =head2 get_state( $state ) Returns true if the raidgroup has the given state, false otherwise. =cut NetApp-500.002/inc/Module/000755 067073 067073 00000000000 11763415704 015745 5ustar00pmoorepmoore000000 000000 NetApp-500.002/inc/Module/Install/000755 067073 067073 00000000000 11763415704 017353 5ustar00pmoorepmoore000000 000000 NetApp-500.002/inc/Module/Install.pm000644 067073 067073 00000025015 11763415677 017725 0ustar00pmoorepmoore000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # 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.93'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # 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: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; 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" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. 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" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. 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)); use Cwd (); use File::Find (); use File::Path (); use FindBin; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } 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} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; 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 $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 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_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). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2010 Adam Kennedy. NetApp-500.002/inc/Module/Install/Base.pm000644 067073 067073 00000001766 11763415700 020571 0ustar00pmoorepmoore000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.93'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 NetApp-500.002/inc/Module/Install/Can.pm000644 067073 067073 00000003333 11763415700 020410 0ustar00pmoorepmoore000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.93'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 NetApp-500.002/inc/Module/Install/Fetch.pm000644 067073 067073 00000004627 11763415700 020747 0ustar00pmoorepmoore000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.93'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; NetApp-500.002/inc/Module/Install/Makefile.pm000644 067073 067073 00000020232 11763415700 021421 0ustar00pmoorepmoore000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.93'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { 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} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # 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 } sub makemaker_args { my $self = shift; my $args = ( $self->{makemaker_args} ||= {} ); %$args = ( %$args, @_ ); return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); if ( -d 'xt' and ($ENV{RELEASE_TESTING} or $self->author) ) { File::Find::find( \&_wanted_t, 'xt' ); } $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. 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->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; $DB::single = 1; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } elsif ( -d 'xt' and ($self->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; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # 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 $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; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 435 NetApp-500.002/inc/Module/Install/Metadata.pm000644 067073 067073 00000036361 11763415700 021436 0ustar00pmoorepmoore000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.93'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract author version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords }; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { 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; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $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->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { 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"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub _extract_license { if ( $_[0] =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyrights?|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; 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; } } } else { return; } } 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[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; NetApp-500.002/inc/Module/Install/Win32.pm000644 067073 067073 00000003403 11763415700 020607 0ustar00pmoorepmoore000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.93'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; NetApp-500.002/inc/Module/Install/WriteAll.pm000644 067073 067073 00000002222 11763415700 021426 0ustar00pmoorepmoore000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.93';; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { $self->makemaker_args( PL_FILES => {} ); } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1;