Test-File-1.442/000755 000765 000024 00000000000 12770775304 013572 5ustar00brianstaff000000 000000 Test-File-1.442/Changes000644 000765 000024 00000016056 12770775302 015073 0ustar00brianstaff000000 000000 Revision history for Perl module Test::File 1.442 2016-09-22T15:35:50Z * Update to stable release. This fixes an upcoming Perl @INC issue that removes the current directory from the default list. This affects only the test files which use a private library. If you already have this installed you don't need to update. 1.441_01 2016-09-19T21:44:45Z * Fix for missing . in @INC (Github #14 https://github.com/briandfoy/test-file/issues/14) This relates to CVE-2016-1238 1.44 2015-07-06T00:29:56Z * Fix file_has_* tests to work on Windows (RJBS) GitHub #13 1.43_02 2015-06-24T15:21:57Z * check file_mode_has tests for Windows 1.43 2015-06-22T21:44:37Z * Don't install README.pod 1.42 2015-06-16T17:58:11Z * Fix problem with META* specifying requirements (RT #105210) 1.41 - 2014-09-12 * Adjust the UTF-8 and encoding tests to work with older perls 1.40 - 2014-09-12 * Fix up tests for UTF-8 checks 1.39 - 2014-09-11 * Allow tests to run in parallel (RT #89908 and RT #91862) 1.38 - 2014-09-11 * Add xmikew's mtime test functions. GitHub issue #8 1.37 - 2014-09-11 * Uncomment accidently commented symlink_target_is_absolute_ok 1.36 - 2014-01-01 * Fix RT #89849 - bad line counts on latest dev version of Perl 1.35 - 2013-10-10 * Fix RT #89175 - don't distribute MYMETA* * add dir_exists_ok and dir_contains_ok * add file_contains_* functions 1.34 - 2012-06-02 * Fixed problem in links.t. (RT #76853) Thanks to Matthew Musgrove (Mr. Muskrat) and Savio Dimatteo (DARKSMO) for the patch(es). 1.33 - 2012-02-19 * Fixed problem in MANIFEST file. (RT #37676) 1.32 - 2012-02-17 * Fixed qr//mx patterns to work with older Perls. (RT #74365) Thanks to Paul Howarth for the patch. * Fixed incorrect spelling of "privileges" in SKIP blocks. (RT #74483) * Skip testing of symlinks on Windows. (RT #57682) * Fixed automatically generated test name for owner_isnt. (RT #37676) 1.31 - 2012-01-24 * Added some SKIP blocks to avoid test failures when running as root. (D'oh!) 1.30 - 2012-01-23 * Added dir_exists_ok and dir_contains_ok * Added file_contains_like and file_contains_unlike * Fixed a few grammatical errors in POD 1.28_01 - 2011-08-11 * Fixes some Windows tests, I think. RT #57682 1.28 - 2009-05-31 * Make the man pages after all 1.27 - 2009-05-21 * Fix to the tests for 1.26 which didn't account for an extra setup test. 1.26 - 2009-05-15 Don't create man pages for the module (RT #45977) 1.25_001 - 2008-07-15 * Adding some symlink features, more later * Refactoring and separating many tests - test coverage at 90% now * This is really a test release for my new Module::Release 1.25 - 2008-06-10 * Same as 1.24_03, but with a user release version number. The new features are the ones in 1.24, but this time the tests should all pass :) 1.24_03 - 2008-05-25 * Make some adjustments in checking the error messages in test_files.t to make them work across platforms * Remove links.t from the distribution. It doesn't really test anything yet. 1.24_02 - 2008-05-25 * Add a binmode before writing to files so they come out right on Windows. Stupid rookie mistake. :( 1.24_01 - 2008-05-24 * Trial version to fix test ordering problem in 1.24 * Removed setup.t, which turned into setup_common but wasn't updated for the new features in 1.24 (so files were missing in other test files) 1.24 - 2008-05-20 * David Wheeler sent a patch to add file_line_count_is, so I also added file_line_count_isnt and file_line_count_between. * There aren't any other improvements, so you don't need to upgrade unless you want the new functions. 1.23 - 2008-04-23 * [BUG FIX] owner_is and group_is now fail if the owner or group does not exist. 1.22_01 - 2008-04-20 * [BUG FIX] owner_is and group_is were passing with non-existent users and groups. Now I check the arguments to see if they actually exist before I test. This is a developer release to let CPAN Testers take a whack at it first. 1.22 - 2007-10-31 * fixed problem with file path separators in t/rt/30346.t * no need to upgrade if you were already able to install this 1.21 - 2007-10-30 * Fix RT #30346 ( file_not_empty_ok passes if file doesn't exist) * require 5.006 from now on 1.19 - 2007-10-27 * distro cleanups after moving from CVS to SVN 1.18 - 2007-01-09 * updated copyright and license info * no code changes, so no need to upgrade 1.17 - 2006-11-24 * Updated tests for Test::More 0.65's change in error reporting * Added LICENSE field to docs * No need to upgrade it you already have this installed 1.16 - 2006-07-08 * updated the plan for links.t to have the right number of tests * no need to upgrade if you already have this installed. 1.15 - 2006-05-17 * Updated the distro for copyright and kwalitee. No need to upgrade. 1.14 - 2006-03-08 * Added Dylan Martin's test for group_is and group_isnt * No need to upgrade unless you need these features 1.13 - 2005-12-31 * You need the latest Test::Builder::Tester (0.32 right now) to get the owner.t test to pass. I've noted that in the PREREQ_PM. * You don't need to upgrade if you already have Test::File installed. If you run into a test problem, ensure you have the latest Test::Builder::Tester and try again. 1.12 - 2005-12-25 * Added the tests owner_is() and owner_isnt() from Dylan Martin 1.11 - 2005-10-02 * Some strings were mistakenly single-quoted. I meant to interpolate but didn't use double quotes. Should I lose my Perl license? :) * Upgrade to get the interpolated error messages. 1.10 - 2005-06-05 * Fixed Windows testing with patch from Tom Metro. Now that I have a Windows box, I don't need to guess on some of this stuff. * There is a minor code change, but you don't need to rush to upgrade if you already have an installed version. 1.09 - 2005-03-08 * Added POD coverage tests: no need to upgrade 1.08 - 2005-01-06 * added a patch from David Wheeler to canonicalize paths for the platform. If the paths look like unix paths, I split them on / and reconstruct them with File::Spec->catdir. * Some functions don't work with Win32, so I detect that inside those functions and automatically skip the test if I think I'm on a Windows machine. 1.07 - 2005-01-03 Shawn Sorichetti contributed two new funtions: file_mode_is() and file_mode_isnt(). We can now test files by their mode. 1.06 - 2004-09-05 * Fixed tests that failed if you ran them with root privileges, which don't actually completely depend on file permissions 1.05 - 2004-09-02 * fixed a documentation bug dealing with file sizes * cleaned up the distribution a bit * You don't need to upgrade if you already have this module 0.9 - 2004-07-04 * ported tests to Test::More * cleaned up dist files, especially Makefile.PL * fixed up some doc issues in File.pm * no change in functionality 0.05 - 2002-09-23 * initial version Test-File-1.442/examples/000755 000765 000024 00000000000 12770775303 015407 5ustar00brianstaff000000 000000 Test-File-1.442/INSTALL.SKIP000644 000765 000024 00000000156 12770775302 015370 0ustar00brianstaff000000 000000 README\.pod README.* # things that might be in local directories after fooling # around with them \.DS_Store Test-File-1.442/lib/000755 000765 000024 00000000000 12770775303 014337 5ustar00brianstaff000000 000000 Test-File-1.442/LICENSE000644 000765 000024 00000017401 12770775302 014600 0ustar00brianstaff000000 000000 The Test::File module is licensed under the same terms as perl itself, under the Artistic License 2.0. Artistic License 2.0 Copyright (c) 2000-2006, The Perl Foundation. http://www.perlfoundation.org/artistic_license_2_0 Preamble This license establishes the terms under which a given free software Package may be copied, modified, distributed, and/or redistributed. The intent is that the Copyright Holder maintains some artistic control over the development of that Package while still keeping the Package available as open source and free software. You are always permitted to make arrangements wholly outside of this license directly with the Copyright Holder of a given Package. If the terms of this license do not permit the full use that you propose to make of the Package, you should contact the Copyright Holder and seek a different licensing arrangement. Definitions "Copyright Holder" means the individual(s) or organization(s) named in the copyright notice for the entire Package. "Contributor" means any party that has contributed code or other material to the Package, in accordance with the Copyright Holder's procedures. "You" and "your" means any person who would like to copy, distribute, or modify the Package. "Package" means the collection of files distributed by the Copyright Holder, and derivatives of that collection and/or of those files. A given Package may consist of either the Standard Version, or a Modified Version. "Distribute" means providing a copy of the Package or making it accessible to anyone else, or in the case of a company or organization, to others outside of your company or organization. "Distributor Fee" means any fee that you charge for Distributing this Package or providing support for this Package to another party. It does not mean licensing fees. "Standard Version" refers to the Package if it has not been modified, or has been modified only in ways explicitly requested by the Copyright Holder. "Modified Version" means the Package, if it has been changed, and such changes were not explicitly requested by the Copyright Holder. "Original License" means this Artistic License as Distributed with the Standard Version of the Package, in its current version or as it may be modified by The Perl Foundation in the future. "Source" form means the source code, documentation source, and configuration files for the Package. "Compiled" form means the compiled bytecode, object code, binary, or any other form resulting from mechanical transformation or translation of the Source form. Permission for Use and Modification Without Distribution (1) You are permitted to use the Standard Version and create and use Modified Versions for any purpose without restriction, provided that you do not Distribute the Modified Version. Permissions for Redistribution of the Standard Version (2) You may Distribute verbatim copies of the Source form of the Standard Version of this Package in any medium without restriction, either gratis or for a Distributor Fee, provided that you duplicate all of the original copyright notices and associated disclaimers. At your discretion, such verbatim copies may or may not include a Compiled form of the Package. (3) You may apply any bug fixes, portability changes, and other modifications made available from the Copyright Holder. The resulting Package will still be considered the Standard Version, and as such will be subject to the Original License. Distribution of Modified Versions of the Package as Source (4) You may Distribute your Modified Version as Source (either gratis or for a Distributor Fee, and with or without a Compiled form of the Modified Version) provided that you clearly document how it differs from the Standard Version, including, but not limited to, documenting any non-standard features, executables, or modules, and provided that you do at least ONE of the following: (a) make the Modified Version available to the Copyright Holder of the Standard Version, under the Original License, so that the Copyright Holder may include your modifications in the Standard Version. (b) ensure that installation of your Modified Version does not prevent the user installing or running the Standard Version. In addition, the Modified Version must bear a name that is different from the name of the Standard Version. (c) allow anyone who receives a copy of the Modified Version to make the Source form of the Modified Version available to others under (i) the Original License or (ii) a license that permits the licensee to freely copy, modify and redistribute the Modified Version using the same licensing terms that apply to the copy that the licensee received, and requires that the Source form of the Modified Version, and of any works derived from it, be made freely available in that license fees are prohibited but Distributor Fees are allowed. Distribution of Compiled Forms of the Standard Version or Modified Versions without the Source (5) You may Distribute Compiled forms of the Standard Version without the Source, provided that you include complete instructions on how to get the Source of the Standard Version. Such instructions must be valid at the time of your distribution. If these instructions, at any time while you are carrying out such distribution, become invalid, you must provide new instructions on demand or cease further distribution. If you provide valid instructions or cease distribution within thirty days after you become aware that the instructions are invalid, then you do not forfeit any of your rights under this license. (6) You may Distribute a Modified Version in Compiled form without the Source, provided that you comply with Section 4 with respect to the Source of the Modified Version. Aggregating or Linking the Package (7) You may aggregate the Package (either the Standard Version or Modified Version) with other packages and Distribute the resulting aggregation provided that you do not charge a licensing fee for the Package. Distributor Fees are permitted, and licensing fees for other components in the aggregation are permitted. The terms of this license apply to the use and Distribution of the Standard or Modified Versions as included in the aggregation. (8) You are permitted to link Modified and Standard Versions with other works, to embed the Package in a larger work of your own, or to build stand-alone binary or bytecode versions of applications that include the Package, and Distribute the result without restriction, provided the result does not expose a direct interface to the Package. Items That are Not Considered Part of a Modified Version (9) Works (including, but not limited to, modules and scripts) that merely extend or make use of the Package, do not, by themselves, cause the Package to be a Modified Version. In addition, such works are not considered parts of the Package itself, and are not subject to the terms of this license. General Provisions (10) Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. (11) If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. (12) This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. (13) This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation Test-File-1.442/Makefile.PL000644 000765 000024 00000006023 12770775302 015543 0ustar00brianstaff000000 000000 package Test::File; use strict; use warnings; =encoding utf8 =head1 The build file for Test::File This build file is a modulino; it works as both a build script and a module. To build the distribution, run this file normally: % perl Makefile.PL But, it's more interesting than that. You can load it with C and call C to get the data structure it passes to C: my $package = require '/path/to/Makefile.PL'; my $arguments = $package->arguments; Note that C-ing a file makes an entry in C<%INC> for exactly that name. If you try to C another file with the same name, even from a different path, C thinks it has already loaded the file. As such, I recommend you always require the full path to the file. The return value of the C is a package name (in this case, the name of the main module. Use that to call the C method. Even if this distribution needs a higher version of Perl, this bit only needs v5.8. You can play with the data structure with a primitive Perl. =cut use File::Spec::Functions qw(catfile); my $module = __PACKAGE__; ( my $dist = $module ) =~ s/::/-/g; my $github = 'https://github.com/briandfoy/test-file'; my $main_file = catfile( 'lib', split /::/, "$module.pm" ); my %WriteMakefile = ( 'MIN_PERL_VERSION' => '5.008', 'NAME' => $module, 'VERSION_FROM' => $main_file, 'ABSTRACT_FROM' => $main_file, 'LICENSE' => 'perl', 'AUTHOR' => 'brian d foy ', 'CONFIGURE_REQUIRES' => { 'ExtUtils::MakeMaker' => '6.64', 'File::Spec::Functions' => '0', }, 'BUILD_REQUIRES' => { }, 'TEST_REQUIRES' => { 'Test::More' => '0.95', 'Test::Builder::Tester' => '1.04', 'Test::Builder' => '1.001006', 'Test::utf8' => '0', }, 'PREREQ_PM' => { }, 'META_MERGE' => { 'meta-spec' => { version => 2 }, keywords => ['testing','file'], resources => { repository => { type => 'git', url => "$github.git", web => $github, }, bugtracker => { web => "$github/issues", }, homepage => $github, }, no_index => { package => [ qw( version Local ) ], directory => [ qw( t/inc inc ) ], file => [ qw( t/lib/test.pm ) ], namespace => [ qw( Local ) ], }, }, clean => { FILES => qq|$dist-*| }, ); sub arguments { \%WriteMakefile } do_it() unless caller; sub do_it { my $MM ='ExtUtils::MakeMaker'; my $MM_version = eval{ "$MM " . $WriteMakefile{'CONFIGURE_REQUIRES'}{'ExtUtils::MakeMaker'} } || "$MM 6.64"; eval "use $MM_version; 1" or die "Could not load $MM_version: $@"; eval "use Test::Manifest 1.21"; my $arguments = arguments(); my $minimum_perl = $arguments->{MIN_PERL_VERSION} || '5.008'; eval "require $minimum_perl;" or die $@; WriteMakefile( %$arguments ); } BEGIN { use ExtUtils::MM_Unix; package ExtUtils::MM_Unix; my $original = \&ExtUtils::MM_Unix::init_dirscan; no warnings 'redefine'; *init_dirscan = sub { &$original; delete $_[0]{PM}{'README.pod'}; $_[0]; }; } no warnings; __PACKAGE__; Test-File-1.442/MANIFEST000644 000765 000024 00000001175 12770775304 014727 0ustar00brianstaff000000 000000 Changes examples/README INSTALL.SKIP lib/Test/File.pm LICENSE Makefile.PL MANIFEST This list of files MANIFEST.SKIP README.pod t/dm_skeleton.t t/file_contains.t t/file_contains_encoded.t t/file_contains_utf8.t t/file_mtime.t t/file_sizes.t t/line_counters.t t/link_counts.t t/links.t t/load.t t/normalize.t t/obviously_non_multi_user.t t/owner.t t/pod.t t/pod_coverage.t t/rt/30346.t t/setup_common t/test_dirs.t t/test_files.t t/test_manifest t/win32.t xt/changes.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Test-File-1.442/MANIFEST.SKIP000644 000765 000024 00000002007 12770775302 015465 0ustar00brianstaff000000 000000 #!start included /usr/local/perls/perl-5.20.0/lib/5.20.0/ExtUtils/MANIFEST.SKIP # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b \b_darcs\b \B\.cvsignore$ # Avoid VMS specific MakeMaker generated files \bDescrip.MMS$ \bDESCRIP.MMS$ \bdescrip.mms$ # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ \bBuild.bat$ \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.tmp$ \.# \.rej$ # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid Devel::Cover and Devel::CoverX::Covered files. \bcover_db\b \bcovered\b # Avoid MYMETA files ^MYMETA\. #!end included /usr/local/perls/perl-5.20.0/lib/5.20.0/ExtUtils/MANIFEST.SKIP .releaserc .lwpcookies Test-.* \.travis\.yml Test-File-1.442/META.json000664 000765 000024 00000003224 12770775304 015216 0ustar00brianstaff000000 000000 { "abstract" : "test file attributes", "author" : [ "brian d foy " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.140640", "keywords" : [ "testing", "file" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-File", "no_index" : { "directory" : [ "t", "inc", "t/inc", "inc" ], "file" : [ "t/lib/test.pm" ], "namespace" : [ "Local" ], "package" : [ "version", "Local" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.64", "File::Spec::Functions" : "0" } }, "runtime" : { "requires" : { "perl" : "5.008" } }, "test" : { "requires" : { "Test::Builder" : "1.001006", "Test::Builder::Tester" : "1.04", "Test::More" : "0.95", "Test::utf8" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/briandfoy/test-file/issues" }, "homepage" : "https://github.com/briandfoy/test-file", "repository" : { "type" : "git", "url" : "https://github.com/briandfoy/test-file.git", "web" : "https://github.com/briandfoy/test-file" } }, "version" : "1.442" } Test-File-1.442/META.yml000664 000765 000024 00000001614 12770775303 015046 0ustar00brianstaff000000 000000 --- abstract: 'test file attributes' author: - 'brian d foy ' build_requires: Test::Builder: '1.001006' Test::Builder::Tester: '1.04' Test::More: '0.95' Test::utf8: '0' configure_requires: ExtUtils::MakeMaker: '6.64' File::Spec::Functions: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.140640' keywords: - testing - file license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test-File no_index: directory: - t - inc - t/inc - inc file: - t/lib/test.pm namespace: - Local package: - version - Local requires: perl: '5.008' resources: bugtracker: https://github.com/briandfoy/test-file/issues homepage: https://github.com/briandfoy/test-file repository: https://github.com/briandfoy/test-file.git version: '1.442' Test-File-1.442/README.pod000644 000765 000024 00000007375 12770775302 015245 0ustar00brianstaff000000 000000 =pod =encoding utf8 =for HTML =for HTML Coverage Status =for HTML =for HTML =head1 The Test::File module This is the I for the L Perl module, which provides convenience test functions to check file attributes and data in a L fashion. You're probably looking at this because you don't know where else to find what you're looking for. Read this once and you might never have to read one again for any Perl module. =head2 Documentation To read about L, look at the embedded documentation in the module itself. Inside the distribution, you can format it with L: % perldoc lib/Test/File.pm If you have already installed the module, you can specify the module name instead of the file location: % perldoc Test::File You can read the documentation and inspect the meta data on one of the CPAN web interfaces, such as L or L: =over 4 =item * L =item * L =back The standard module documentation has example uses in the SYNOPSIS section, but you can also look in the I directory (if it's there), or look at the test files in I. =head2 Installation You can install this module with a CPAN client, which will resolve and install the dependencies: % cpan Test::File % cpanm Test::File You can also install directly from the distribution directory, which will also install the dependencies: % cpan . % cpanm . You could install just this module manually: % perl Makefile.PL % make % make test % make install You probably don't want to do that unless you're fiddling with the module and only want to run the tests without installing anything. =head2 Source location The meta data, such as the source repository and bug tracker, is in I or the I files it creates. You can find that on those CPAN web interfaces, but you can also look at files directly in the source repository: =over 4 =item * L =back If you find a problem, file a ticket in the L: =over 4 =item * L =back =head2 Getting help Although I'm happy to hear from module users in private email, that's the best way for me to forget to do something. Besides the issue trackers, you can find help at L or L, both of which have many competent Perlers who can answer your question, almost in real time. They might not know the particulars of this module, but they can help you diagnose your problem. You might like to read L. =head2 Copyright and License You should have received a I file, but the license is also noted in the module files. About the only thing you can't do is pretend that you wrote code that you didn't. =head2 Good luck! Enjoy, brian d foy, bdfoy@cpan.org =cut Test-File-1.442/t/000755 000765 000024 00000000000 12770775303 014034 5ustar00brianstaff000000 000000 Test-File-1.442/xt/000755 000765 000024 00000000000 12770775303 014224 5ustar00brianstaff000000 000000 Test-File-1.442/xt/changes.t000644 000765 000024 00000000203 12770775302 016013 0ustar00brianstaff000000 000000 use Test::More; eval 'use Test::CPAN::Changes'; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; changes_ok(); Test-File-1.442/t/dm_skeleton.t000644 000765 000024 00000002761 12770775302 016532 0ustar00brianstaff000000 000000 use strict; use Test::Builder::Tester; use Test::More 0.95; use Test::File; require "./t/setup_common"; subtest setup => sub { ok( defined &Test::File::_dm_skeleton, "_dm_skeleton is defined" ); }; my $readable = 'readable'; my $not_there = 'not_there'; my $test_name = 'This is my test name'; subtest fake_non_multi_user_dm_skeleton => sub { local $^O = 'dos'; ok( Test::File::_obviously_non_multi_user(), "Is not multi user" ); is( Test::File::_dm_skeleton(), 'skip', "Skip on single user systems" ); is( Test::File::_dm_skeleton($readable), 'skip', "Skip on single user systems" ); is( Test::File::_dm_skeleton($not_there), 'skip', "Skip on single user systems" ); }; subtest fake_non_multi_user => sub { local $^O = 'MSWin32'; diag "$^O\n";; ok( ! Test::File::_obviously_non_multi_user(), "Is multi user" ); }; subtest fake_non_multi_user_missing_file => sub { local $^O = 'MSWin32'; ok( ! Test::File::_obviously_non_multi_user(), "Is multi user" ); test_out( "not ok 1" ); test_diag( "File [$not_there] does not exist!\n" . " # Failed test at $0 line " . line_num(+4) . "." ); Test::File::_dm_skeleton( $not_there ); test_test(); }; subtest fake_non_multi_user_empty => sub { local $^O = 'MSWin32'; ok( ! Test::File::_obviously_non_multi_user(), "Is multi user" ); test_out( "not ok 1" ); test_diag( "File name not specified!\n" . " # Failed test at $0 line " . line_num(+4) . "." ); Test::File::_dm_skeleton(); test_test(); }; done_testing(); Test-File-1.442/t/file_contains.t000644 000765 000024 00000010754 12770775302 017044 0ustar00brianstaff000000 000000 use strict; use warnings; use Test::Builder::Tester; use Test::More 0.95; use Test::File; require "./t/setup_common"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # my $file = 'min_file'; my $contents = do { open FH, $file; local $/; }; close FH; my $pattern1 = 'x' x 11; $pattern1 = qr/(?mx:^ $pattern1 $)/; my $pattern2 = 'x' x 40; $pattern2 = qr/(?mx:^ $pattern2 $)/; my $bad_pattern = 'x' x 20; $bad_pattern = qr/(?mx:^ $bad_pattern $)/; # like : single pattern test_out( "ok 1 - min_file contains $pattern1" ); file_contains_like( $file, $pattern1 ); test_test(); test_out( "not ok 1 - bmoogle contains $pattern1" ); test_diag( 'File [bmoogle] does not exist!' ); test_fail(+1); file_contains_like( 'bmoogle', $pattern1 ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( "not ok 1 - not_readable contains $pattern1" ); test_diag( 'File [not_readable] is not readable!' ); test_fail(+1); file_contains_like( 'not_readable', $pattern1 ); test_test(); } test_out( "not ok 1 - min_file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_like( 'min_file', $bad_pattern ); test_test(); # unlike : single pattern test_out( "ok 1 - min_file doesn't contain $bad_pattern" ); file_contains_unlike( $file, $bad_pattern ); test_test(); test_out( "not ok 1 - bmoogle doesn't contain $bad_pattern" ); test_diag( 'File [bmoogle] does not exist!' ); test_fail(+1); file_contains_unlike( 'bmoogle', $bad_pattern ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( "not ok 1 - not_readable doesn't contain $bad_pattern" ); test_diag( 'File [not_readable] is not readable!' ); test_fail(+1); file_contains_unlike( 'not_readable', $bad_pattern ); test_test(); } test_out( "not ok 1 - min_file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_unlike( 'min_file', $pattern1 ); test_test(); # like : multiple patterns test_out( "ok 1 - min_file contains $pattern1" ); test_out( "ok 2 - min_file contains $pattern2" ); file_contains_like( $file, [ $pattern1, $pattern2 ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_like( $file, [ $pattern1, $pattern2 ], 'file has the goods' ); test_test(); test_out( "not ok 1 - bmoogle contains $pattern1" ); test_diag( 'File [bmoogle] does not exist!' ); test_fail(+1); file_contains_like( 'bmoogle', [ $pattern1, $pattern2 ] ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( "not ok 1 - not_readable contains $pattern1" ); test_diag( 'File [not_readable] is not readable!' ); test_fail(+1); file_contains_like( 'not_readable', [ $pattern1, $pattern2 ] ); test_test(); } test_out( "ok 1 - min_file contains $pattern1" ); test_out( "not ok 2 - min_file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_like( 'min_file', [ $pattern1, $bad_pattern ] ); test_test(); # unlike : multiple patterns test_out( "ok 1 - min_file doesn't contain $bad_pattern" ); test_out( "ok 2 - min_file doesn't contain $bad_pattern" ); file_contains_unlike( $file, [ $bad_pattern, $bad_pattern ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_unlike( $file, [ $bad_pattern, $bad_pattern ], 'file has the goods' ); test_test(); test_out( "not ok 1 - bmoogle doesn't contain $bad_pattern" ); test_diag( 'File [bmoogle] does not exist!' ); test_fail(+1); file_contains_unlike( 'bmoogle', [ $bad_pattern, $bad_pattern ] ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( "not ok 1 - not_readable doesn't contain $bad_pattern" ); test_diag( 'File [not_readable] is not readable!' ); test_fail(+1); file_contains_unlike( 'not_readable', [ $bad_pattern, $bad_pattern ] ); test_test(); } test_out( "ok 1 - min_file doesn't contain $bad_pattern" ); test_out( "not ok 2 - min_file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_unlike( 'min_file', [ $bad_pattern, $pattern1 ] ); test_test(); done_testing(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # sub like_diag { my ($string, $pattern, $verb) = @_; my $diag = ' ' x 18 . "'$string'\n"; $diag .= sprintf("%17s '%s'", $verb, $pattern); $diag =~ s/^/# /mg; test_err($diag); } Test-File-1.442/t/file_contains_encoded.t000644 000765 000024 00000005752 12770775302 020527 0ustar00brianstaff000000 000000 use strict; use warnings; use utf8; use Test::Builder::Tester; use Test::More 0.95; use Test::File; use Test::utf8; # Hello world! I am a string. Russian, courtesy of Google Translate my $string1 = 'Привет мир!'; my $string2 = 'Я строкой'; my $encoding = 'KOI8-R'; require "./t/setup_common"; my $file = '$file'; open my $fh, '>', $file or print "bail out! Could not write to $file: $!"; binmode($fh, ":encoding($encoding)"); $fh->print("$string1$/$/$/"); $fh->print("$string2$/"); $fh->close; my $contents = do { open $fh, '<', $file; binmode($fh, ":encoding($encoding)"); local $/; <$fh>; }; $fh->close; my $pattern1 = qr/$string1/; my $pattern2 = qr/$string2/; my $bad_pattern = 'x' x 20; $bad_pattern = qr/(?m:^$bad_pattern$)/; # like : single pattern test_out( "ok 1 - $file contains $pattern1" ); file_contains_encoded_like( $file, $encoding, $pattern1 ); test_test(); test_out( "not ok 1 - $file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_encoded_like( '$file', $encoding, $bad_pattern ); test_test(); # unlike : single pattern test_out( "ok 1 - $file doesn't contain $bad_pattern" ); file_contains_encoded_unlike( $file, $encoding, $bad_pattern ); test_test(); test_out( "not ok 1 - $file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_encoded_unlike( '$file', $encoding, $pattern1 ); test_test(); # like : multiple patterns test_out( "ok 1 - $file contains $pattern1" ); test_out( "ok 2 - $file contains $pattern2" ); file_contains_encoded_like( $file, $encoding, [ $pattern1, $pattern2 ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_encoded_like( $file, $encoding, [ $pattern1, $pattern2 ], 'file has the goods' ); test_test(); test_out( "ok 1 - $file contains $pattern1" ); test_out( "not ok 2 - $file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_encoded_like( '$file', $encoding, [ $pattern1, $bad_pattern ] ); test_test(); # unlike : multiple patterns test_out( "ok 1 - $file doesn't contain $bad_pattern" ); test_out( "ok 2 - $file doesn't contain $bad_pattern" ); file_contains_encoded_unlike( $file, $encoding, [ $bad_pattern, $bad_pattern ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_encoded_unlike( $file, $encoding, [ $bad_pattern, $bad_pattern ], 'file has the goods' ); test_test(); test_out( "ok 1 - $file doesn't contain $bad_pattern" ); test_out( "not ok 2 - $file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_encoded_unlike( '$file', $encoding, [ $bad_pattern, $pattern1 ] ); test_test(); done_testing(); sub like_diag { my ($string, $pattern, $verb) = @_; my $diag = ' ' x 18 . "'$string'\n"; $diag .= sprintf("%17s '%s'", $verb, $pattern); $diag =~ s/^/# /mg; test_err($diag); } Test-File-1.442/t/file_contains_utf8.t000644 000765 000024 00000005746 12770775302 020017 0ustar00brianstaff000000 000000 use strict; use warnings; use utf8; use Test::Builder::Tester; use Test::More 0.95; use Test::File; # Hello world from utf8 test file: # http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt my $string1 = 'Καλημέρα κόσμε'; my $string2 = 'コンニチハ'; require "./t/setup_common"; my $file = 'utf8_file'; open my $fh, '>', $file or print "bail out! Could not write to utf8_file: $!"; binmode($fh, ':encoding(UTF-8)'); $fh->print("$string1$/$/$/"); $fh->print("$string2$/"); $fh->close; my $contents = do { open $fh, '<', $file; binmode($fh, ':encoding(UTF-8)'); local $/; <$fh>; }; $fh->close; my $pattern1 = qr/(?m:^$string1$)/; my $pattern2 = qr/(?m:^$string2$)/; my $bad_pattern = 'x' x 20; $bad_pattern = qr/(?m:^$bad_pattern$)/; # like : single pattern test_out( "ok 1 - utf8_file contains $pattern1" ); file_contains_utf8_like( $file, $pattern1 ); test_test(); test_out( "not ok 1 - utf8_file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_utf8_like( 'utf8_file', $bad_pattern ); test_test(); # unlike : single pattern test_out( "ok 1 - utf8_file doesn't contain $bad_pattern" ); file_contains_utf8_unlike( $file, $bad_pattern ); test_test(); test_out( "not ok 1 - utf8_file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_utf8_unlike( 'utf8_file', $pattern1 ); test_test(); # like : multiple patterns test_out( "ok 1 - utf8_file contains $pattern1" ); test_out( "ok 2 - utf8_file contains $pattern2" ); file_contains_utf8_like( $file, [ $pattern1, $pattern2 ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_utf8_like( $file, [ $pattern1, $pattern2 ], 'file has the goods' ); test_test(); test_out( "ok 1 - utf8_file contains $pattern1" ); test_out( "not ok 2 - utf8_file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_utf8_like( 'utf8_file', [ $pattern1, $bad_pattern ] ); test_test(); # unlike : multiple patterns test_out( "ok 1 - utf8_file doesn't contain $bad_pattern" ); test_out( "ok 2 - utf8_file doesn't contain $bad_pattern" ); file_contains_utf8_unlike( $file, [ $bad_pattern, $bad_pattern ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_utf8_unlike( $file, [ $bad_pattern, $bad_pattern ], 'file has the goods' ); test_test(); test_out( "ok 1 - utf8_file doesn't contain $bad_pattern" ); test_out( "not ok 2 - utf8_file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_utf8_unlike( 'utf8_file', [ $bad_pattern, $pattern1 ] ); test_test(); done_testing(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # sub like_diag { my ($string, $pattern, $verb) = @_; my $diag = ' ' x 18 . "'$string'\n"; $diag .= sprintf("%17s '%s'", $verb, $pattern); $diag =~ s/^/# /mg; test_err($diag); } Test-File-1.442/t/file_mtime.t000644 000765 000024 00000004405 12770775302 016335 0ustar00brianstaff000000 000000 use warnings; use strict; use Test::Builder::Tester; use Test::More 0.95; use Test::File; require "./t/setup_common"; # Setup test env my $mtime_file = 'mtime_file'; ok( -e $mtime_file, 'mtime file exists ok' ) or die $!; my $curtime = time(); my $set_mtime = $curtime-60*10; # 10 minutes ago my $count = utime($set_mtime,$set_mtime,$mtime_file); ok( $count, 'utime reports it set mtime' ) or diag explain $count; my $mtime = ( stat($mtime_file) )[9]; ok ( $mtime == $set_mtime, 'utime successfully set mtime for testing' ) or diag "Got: $mtime, Expected: $set_mtime"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # file_mtime_age_ok test_out( 'ok 1 - file_mtime_age_ok success' ); file_mtime_age_ok( $mtime_file, 60*11, 'file_mtime_age_ok success' ); test_test( 'file_mtime_age_ok success works' ); test_out( 'not ok 1 - file_mtime_age_ok failure' ); test_err( qr/\s*#\s*Filename \[$mtime_file\] [^\n]+\n/ ); test_fail(+1); file_mtime_age_ok( $mtime_file, 60*9, 'file_mtime_age_ok failure' ); test_test( 'file_mime_age_ok failure works' ); # file_mtime_lt_ok test_out( 'ok 1 - file_mtime_lt_ok success' ); file_mtime_lt_ok( $mtime_file, time(), 'file_mtime_lt_ok success' ); test_test( 'file_mtime_lt_ok success works' ); test_out( 'not ok 1 - file_mtime_lt_ok failure' ); test_err( qr/\s*#\s*Filename \[$mtime_file\] [^\n]+\n/ ); test_fail(+1); file_mtime_lt_ok( $mtime_file, $curtime-60*11, 'file_mtime_lt_ok failure' ); test_test( 'file_mtime_lt_ok failure works' ); # file_mtime_gt_ok test_out( 'ok 1 - file_mtime_gt_ok success' ); file_mtime_gt_ok( $mtime_file, $curtime-60*11, 'file_mtime_gt_ok success' ); test_test( 'file_mtime_gt_ok success works' ); test_out( 'not ok 1 - file_mtime_gt_ok failure' ); test_err( qr/\s*#\s*Filename \[$mtime_file\] [^\n]+\n/ ); test_fail( +1 ); file_mtime_gt_ok( $mtime_file, $curtime-60*9, 'file_mtime_gt_ok failure' ); test_test( 'file_mtime_gt_ok failure works' ); # Test internal _stat_file function test_err( qr/\s*#\s*Filename \[.*?\] does not exist!\n/ ); Test::File::_stat_file( 'non-existent-file-12345', 9 ); test_test( '_stat_file on non-existent file works' ); test_err( qr/\s*#\s*Filename not specified!\n/ ); Test::File::_stat_file( undef ); test_test( '_stat_file no file provided works' ); done_testing(); Test-File-1.442/t/file_sizes.t000644 000765 000024 00000010070 12770775302 016352 0ustar00brianstaff000000 000000 use strict; use Test::Builder::Tester; use Test::More 0.95; use Test::File; require "./t/setup_common"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test_out( 'ok 1 - zero_file is empty' ); file_empty_ok( 'zero_file' ); test_test(); test_out( 'ok 1 - min_file is not empty' ); file_not_empty_ok( 'min_file' ); test_test(); subtest works => sub { my $file = 'min_file'; file_exists_ok( $file ); my $actual_size = -s $file; my $under_size = $actual_size - 3; my $over_size = $actual_size + 3; cmp_ok( $actual_size, '>', 10, "$file should be at least 10 bytes" ); test_out( "ok 1 - $file has right size" ); file_size_ok( $file, $actual_size ); test_test(); test_out( "ok 1 - $file is under $over_size bytes" ); file_max_size_ok( $file, $over_size ); test_test(); test_out( "ok 1 - $file is over $under_size bytes" ); file_min_size_ok( $file, $under_size ); test_test(); }; subtest wrong_size => sub { my $file = 'min_file'; file_exists_ok( $file ); my $actual_size = -s $file; my $under_size = $actual_size - 3; my $over_size = $actual_size + 3; cmp_ok( $actual_size, '>', 10, "$file should be at least 10 bytes" ); test_out( "not ok 1 - $file has right size" ); test_diag( "File [$file] has actual size [$actual_size] not [$under_size]!\n" . " # Failed test '$file has right size'\n" . " # at $0 line " . line_num(+5) . "." ); file_size_ok( $file, $under_size ); test_test(); test_out( "not ok 1 - $file is under $under_size bytes" ); test_diag( "File [$file] has actual size [$actual_size] greater than [$under_size]!\n" . " # Failed test '$file is under $under_size bytes'\n" . " # at $0 line " . line_num(+5) . "." ); file_max_size_ok( $file, $under_size ); test_test(); test_out( "not ok 1 - $file is over $over_size bytes" ); test_diag( "File [$file] has actual size [$actual_size] less than [$over_size]!\n" . " # Failed test '$file is over $over_size bytes'\n" . " # at $0 line " . line_num(+5) . "." ); file_min_size_ok( $file, $over_size ); test_test(); test_out( "not ok 1 - $file is empty" ); test_diag( "File [$file] exists with non-zero size!\n" . " # Failed test '$file is empty'\n" . " # at $0 line " . line_num(+5) . "." ); file_empty_ok( $file ); test_test(); test_out( "not ok 1 - zero_file is not empty" ); test_diag( "File [zero_file] exists with zero size!\n" . " # Failed test 'zero_file is not empty'\n" . " # at $0 line " . line_num(+5) . "." ); file_not_empty_ok( 'zero_file' ); test_test(); }; subtest doesnt_work_with_missing_file => sub { my $not_there = 'not_there'; ok( ! -e $not_there, "File [$not_there] doesn't exist (good)" ); test_out( "not ok 1 - $not_there has right size" ); test_diag( "File [$not_there] does not exist!\n" . " # Failed test '$not_there has right size'\n" . " # at $0 line " . line_num(+5) . "." ); file_size_ok( $not_there, 53 ); test_test(); test_out( "not ok 1 - $not_there is under 54 bytes" ); test_diag( "File [$not_there] does not exist!\n" . " # Failed test '$not_there is under 54 bytes'\n" . " # at $0 line " . line_num(+5) . "." ); file_max_size_ok( $not_there, 54 ); test_test(); test_out( "not ok 1 - $not_there is over 50 bytes" ); test_diag( "File [$not_there] does not exist!\n" . " # Failed test '$not_there is over 50 bytes'\n" . " # at $0 line " . line_num(+5) . "." ); file_min_size_ok( $not_there, 50 ); test_test(); test_out( "not ok 1 - $not_there is empty" ); test_diag( "File [$not_there] does not exist!\n" . " # Failed test '$not_there is empty'\n" . " # at $0 line " . line_num(+5) . "." ); file_empty_ok( $not_there ); test_test(); test_out( "not ok 1 - $not_there is not empty" ); test_diag( "File [$not_there] does not exist!\n" . " # Failed test '$not_there is not empty'\n" . " # at $0 line " . line_num(+5) . "." ); file_not_empty_ok( $not_there ); test_test(); }; done_testing(); Test-File-1.442/t/line_counters.t000644 000765 000024 00000012215 12770775302 017072 0ustar00brianstaff000000 000000 use strict; use Test::Builder::Tester; use Test::More 0.95; use Test::File; require "./t/setup_common"; subtest subs_defined => sub { my @subs = qw( file_line_count_between file_line_count_is file_line_count_isnt ); foreach my $sub ( @subs ) { no strict 'refs'; ok( defined &{$sub}, "$sub is defined" ); } }; my $file = 'min_file'; file_exists_ok( $file ); my @lines = do { local @ARGV = $file; <> }; cmp_ok( scalar @lines, ">", 1, "$file has at least one line" ); my $lines = @lines; my $linesm = $lines - 1; my $linesp = $lines + 1; subtest should_work => sub { test_out( "ok 1 - $file line count is between [$linesm] and [$linesp] lines" ); file_line_count_between( $file, $linesm, $linesp ); test_test(); test_out( "ok 1 - $file line count is between [$lines] and [$linesp] lines" ); file_line_count_between( $file, $lines, $linesp ); test_test(); test_out( "ok 1 - $file line count is between [$lines] and [$lines] lines" ); file_line_count_between( $file, $lines, $lines ); test_test(); test_out( "ok 1 - $file line count is $lines lines" ); file_line_count_is( $file, $lines ); test_test(); test_out( "ok 1 - $file line count is not $linesp lines" ); file_line_count_isnt( $file, $linesp ); test_test(); }; subtest missing_file => sub { my $missing = 'not_there'; file_not_exists_ok( $missing ); test_out( "not ok 1 - $missing line count is between [$linesm] and [$linesp] lines" ); test_diag( "File [$missing] does not exist!\n" . " # Failed test '$missing line count is between [$linesm] and [$linesp] lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_between( $missing, $linesm, $linesp ); test_test(); test_out( "not ok 1 - $missing line count is between [$lines] and [$linesp] lines" ); test_diag( "File [$missing] does not exist!\n" . " # Failed test '$missing line count is between [$lines] and [$linesp] lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_between( $missing, $lines, $linesp ); test_test(); test_out( "not ok 1 - $missing line count is between [$lines] and [$lines] lines" ); test_diag( "File [$missing] does not exist!\n" . " # Failed test '$missing line count is between [$lines] and [$lines] lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_between( $missing, $lines, $lines ); test_test(); test_out( "not ok 1 - $missing line count is $lines lines" ); test_diag( "File [$missing] does not exist!\n" . " # Failed test '$missing line count is $lines lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_is( $missing, $lines ); test_test(); test_out( "not ok 1 - $missing line count is not $lines lines" ); test_diag( "File [$missing] does not exist!\n" . " # Failed test '$missing line count is not $lines lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_isnt( $missing, $lines ); test_test(); }; subtest missing_line_count => sub { my $file = 'min_file'; file_exists_ok( $file ); test_out( "not ok 1 - $file line count is between [] and [] lines" ); test_diag( "file_line_count_between expects positive whole numbers for the second and third arguments. Got [] and []!\n" . " # Failed test '$file line count is between [] and [] lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_between( $file ); test_test(); test_out( "not ok 1 - $file line count is lines" ); test_diag( "file_line_count_is expects a positive whole number for the second argument. Got []!\n" . " # Failed test '$file line count is lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_is( $file ); test_test(); test_out( "not ok 1 - $file line count is not lines" ); test_diag( "file_line_count_is expects a positive whole number for the second argument. Got []!\n" . " # Failed test '$file line count is not lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_isnt( $file ); test_test(); }; subtest wrong_number => sub { my $name = "$file line count is $linesp lines"; test_out( "not ok 1 - $name" ); test_diag( "Expected [3] lines in [$file], got [$lines] lines!\n" . " # Failed test '$name'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_is( $file, $linesp ); test_test(); test_out( "ok 1 - $file line count is not $linesp lines" ); file_line_count_isnt( $file, $linesp ); test_test(); $name = "$file line count is not $lines lines"; test_out( "not ok 1 - $name" ); test_diag( "Expected something other than [$lines] lines in [$file], but got [$lines] lines!\n" . " # Failed test '$name'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_isnt( $file, $lines ); test_test(); my $linespp = $linesp + 1; $name = "$file line count is between [$linesp] and [$linespp] lines"; test_out( "not ok 1 - $name" ); test_diag( "Expected a line count between [$linesp] and [$linespp] in [$file], but got [$lines] lines!\n" . " # Failed test '$name'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_between( $file, $linesp, $linespp ); test_test(); }; done_testing(); Test-File-1.442/t/link_counts.t000644 000765 000024 00000004334 12770775302 016554 0ustar00brianstaff000000 000000 use strict; use Test::Builder::Tester; use Test::More 0.95; use_ok( 'Test::File' ); require "./t/setup_common"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Subroutines are defined subtest defined_subs => sub { my @subs = qw( link_count_is_ok link_count_gt_ok link_count_lt_ok ); foreach my $sub ( @subs ) { no strict 'refs'; ok( defined &{$sub}, "$sub is defined" ); } }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should work (single link) my $test_name = "This is my test name"; my $readable = 'readable'; my $readable_sym = 'readable_sym'; my $not_there = 'not_there'; my $dangle_sym = 'dangle_sym'; subtest should_work => sub { test_out( "ok 1 - $test_name\n ok 2 - $test_name\n ok 3 - $test_name" ); link_count_lt_ok( $readable, 100, $test_name ); link_count_gt_ok( $readable, 0, $test_name ); link_count_is_ok( $readable, 1, $test_name ); test_test(); test_out( "ok 1 - $readable has a link count of [1]" ); link_count_is_ok( $readable, 1 ); test_test(); }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should work (multipe links) # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should fail (missing file) # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # subtest bad_count => sub { test_out( "not ok 1 - $test_name" ); test_diag( "File [$readable] points has [1] links: expected [100]!\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); link_count_is_ok( $readable, 100, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "File [$readable] points has [1] links: expected less than [0]!\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); link_count_lt_ok( $readable, 0, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "File [readable] points has [1] links: expected more than [100]!\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); link_count_gt_ok( $readable, 100, $test_name ); test_test(); }; done_testing(); Test-File-1.442/t/links.t000644 000765 000024 00000011427 12770775302 015345 0ustar00brianstaff000000 000000 use strict; use Test::Builder::Tester; use Test::More 0.95; use Test::File; my $can_symlink = eval { symlink("",""); 1 }; plan skip_all => "This system does't do symlinks" unless $can_symlink; require "./t/setup_common"; subtest dont_work_with_symlinks => sub { no warnings 'redefine'; local *Test::File::_no_symlinks_here = sub { 1 }; my @subs = qw( file_is_symlink_ok symlink_target_exists_ok symlink_target_dangles_ok symlink_target_is ); foreach my $sub ( @subs ) { no strict 'refs'; ok( defined &{$sub}, "$sub is defined" ); } foreach my $sub ( @subs ) { no strict 'refs'; test_out("ok 1 # skip $sub doesn't work on systems without symlinks!"); &{$sub}(); test_test(); } }; my $test_name = "This is my test name"; my $readable = 'readable'; my $readable_sym = 'readable_sym'; my $not_there = 'not_there'; my $dangle_sym = 'dangle_sym'; my $s = ! $can_symlink ? "# skip file_is_symlink_ok doesn't work on systems without symlinks!" : "- $readable_sym is a symlink"; subtest should_work => sub { file_exists_ok( $readable ); file_not_exists_ok( $readable_sym ); if( $can_symlink ) { symlink( $readable, $readable_sym ); open my($fh), ">", $not_there; close $fh; file_exists_ok( $not_there ); symlink( $not_there, $dangle_sym ); file_exists_ok( $readable_sym ); file_exists_ok( $dangle_sym ); unlink $not_there; ok( ! -e $not_there ); file_is_symlink_ok( $dangle_sym ); } else { pass(); } test_out( "ok 1 $s" ); file_is_symlink_ok( $readable_sym ); test_test(); test_out( "ok 1 - $test_name" ); file_is_symlink_ok( $readable_sym, $test_name ); test_test(); test_out( "ok 1 - $test_name" ); symlink_target_dangles_ok( $dangle_sym, $test_name ); test_test(); test_out( "ok 1 - $test_name" ); symlink_target_exists_ok( $readable_sym, $readable, $test_name ); test_test(); test_out( "ok 1 $s\n ok 2 - $test_name" ); symlink_target_exists_ok( $readable_sym, $readable ); symlink_target_is( $readable_sym, $readable, $test_name ); test_test(); }; subtest should_work => sub { ok( ! -l $readable, "$readable is not a symlink" ); ok( ! -l $not_there, "$not_there is not a symlink" ); test_out( "not ok 1 - $test_name" ); test_diag( "File [$readable] is not a symlink!\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); file_is_symlink_ok( $readable, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "File [$not_there] is not a symlink!\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); file_is_symlink_ok( $not_there, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "File [$not_there] is not a symlink!\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); symlink_target_dangles_ok( $not_there, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "File [$readable] is not a symlink!\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); symlink_target_is( $readable, $readable_sym, $test_name ); test_test(); test_out( "not ok 1 - $readable is a symlink" ); test_diag( "File [$readable] is not a symlink!\n" . " # Failed test '$readable is a symlink'\n" . " # at $0 line " . line_num(+5) . "." ); symlink_target_exists_ok( $readable ); test_test(); }; subtest bad_target_does_not_exist => sub { test_out( "not ok 1 $s" ); test_diag( "Symlink [$readable_sym] points to non-existent target [$not_there]!\n" . " # Failed test '$readable_sym is a symlink'\n" . " # at $0 line " . line_num(+5) . "." ); symlink_target_exists_ok( $readable_sym, $not_there ); test_test(); test_out( "not ok 1 - symlink $readable_sym points to $not_there" ); test_diag( " Failed test 'symlink $readable_sym points to $not_there'\n" . " # at $0 line " . line_num(+6) . ".\n" . " # got: $readable\n" . " # expected: $not_there" ); symlink_target_is( $readable_sym, $not_there ); test_test(); }; subtest bad_target_does_exists => sub { test_out( "not ok 1 $s" ); test_diag( "Symlink [readable_sym] points to\n" . " # got: readable\n" . " # expected: writeable\n" . " # Failed test 'readable_sym is a symlink'\n" . " # at $0 line " . line_num(+7) . "." ); symlink_target_exists_ok( $readable_sym, "writeable" ); test_test(); }; subtest dangling_exists => sub { test_out( "not ok 1 - $test_name" ); test_diag( "Symlink [$readable_sym] points to existing file [$readable] but shouldn't!\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); symlink_target_dangles_ok( $readable_sym, $test_name ); test_test(); }; done_testing(); Test-File-1.442/t/load.t000644 000765 000024 00000000241 12770775302 015134 0ustar00brianstaff000000 000000 use Test::More 0.95; my @classes = qw(Test::File); foreach my $class ( @classes ) { use_ok( $class ) or BAILOUT( "$class did not load" ); } done_testing(); Test-File-1.442/t/normalize.t000644 000765 000024 00000003473 12770775302 016227 0ustar00brianstaff000000 000000 use Test::More; use File::Spec; use_ok( 'Test::File' ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Try it when it should work subtest file_spec_unix => sub { my $module = 'File::Spec::Unix'; use_ok( $module ); local @File::Spec::ISA = ( $module ); my $file = '/foo/bar/baz'; my $normalized = Test::File::_normalize( $file ); is( $normalized, $file, "Normalize gives same path for unix" ); }; subtest file_spec_win32 => sub { my $module = 'File::Spec::Win32'; use_ok( $module ); local @File::Spec::ISA = ( $module ); my $file = '/foo/bar/baz'; my $normalized = Test::File::_normalize( $file ); isnt( $normalized, $file, "Normalize gives different path for Win32" ); is( $normalized, '\foo\bar\baz', "Normalize gives right path for Win32" ); }; subtest file_spec_mac => sub { my $module = 'File::Spec::Mac'; use_ok( $module ); local @File::Spec::ISA = ( $module ); my $file = '/foo/bar/baz'; my $normalized = Test::File::_normalize( $file ); isnt( $normalized, $file, "Normalize gives different path for Mac" ); is( $normalized, 'foo:bar:baz', "Normalize gives right path for Mac" ); }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Try it when it shouldn't work subtest normalize_undef => sub { my $normalized = Test::File::_normalize( undef ); ok( ! defined $normalized, "Passing undef fails" ); }; subtest normalize_empty => sub { my $normalized = Test::File::_normalize( '' ); ok( defined $normalized, "Passing empty string returns defined value" ); is( $normalized, '', "Passing empty string returns empty string" ); ok( ! $normalized, "Passing empty string fails" ); }; subtest normalize_empty => sub { my $normalized = Test::File::_normalize(); ok( ! defined $normalized, "Passing nothing fails" ); }; done_testing(); Test-File-1.442/t/obviously_non_multi_user.t000644 000765 000024 00000003036 12770775302 021377 0ustar00brianstaff000000 000000 use Test::More 0.95; BEGIN { our $getpwuid_should_die = 0; our $getgrgid_should_die = 0; }; BEGIN{ no warnings; *CORE::GLOBAL::getpwuid = sub ($) { die "Fred" if $getpwuid_should_die }; *CORE::GLOBAL::getgrgid = sub ($) { die "Barney" if $getgrgid_should_die }; } use_ok( 'Test::File' ); ok( defined &{ "Test::File::_obviously_non_multi_user" }, "_win32 defined" ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # The ones that we know aren't multi-user subtest macos_single_user => sub { local $^O = 'MacOS'; ok( Test::File::_obviously_non_multi_user(), "Returns false for MacOS" ); }; subtest dos_single_user => sub { local $^O = 'dos'; ok( Test::File::_obviously_non_multi_user(), "Returns true for Win32" ); }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # The ones that use get*, but die subtest getpwuid_should_die => sub { local $^O = 'Fooey'; $getpwuid_should_die = 1; $getgrgid_should_die = 0; ok( Test::File::_obviously_non_multi_user(), 'getpwuid dying returns true' ); }; subtest getgrgid_should_die => sub { local $^O = 'Fooey'; $getpwuid_should_die = 0; $getgrgid_should_die = 1; ok( Test::File::_obviously_non_multi_user(), 'getgrgid dying returns true' ); }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # The ones that use get*, but don't die subtest nothing_dies => sub { local $^O = 'Fooey'; $getpwuid_should_die = 0; $getgrgid_should_die = 0; ok( ! Test::File::_obviously_non_multi_user(), 'getpwuid dying returns true' ); }; done_testing(); Test-File-1.442/t/owner.t000644 000765 000024 00000013252 12770775302 015355 0ustar00brianstaff000000 000000 use strict; use Test::Builder::Tester; use Test::More; use Test::File; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #let's test with the first file we find in the current dir my( $filename, $file_gid, $owner_uid, $owner_name, $file_group_name ); eval { $filename = glob( "*" ); die "Could not find a file" unless defined $filename; $owner_uid = ( stat $filename )[4]; die "failed to find $filename's owner\n" unless defined $owner_uid; $file_gid = ( stat $filename )[5]; die "failed to find $filename's owner\n" unless defined $file_gid; $owner_name = ( getpwuid $owner_uid )[0]; die "failed to find $filename's owner as name\n" unless defined $owner_name; $file_group_name = ( getgrgid $file_gid )[0]; die "failed to find $filename's group as name\n" unless defined $file_group_name; }; plan skip_all => "I can't find a file to test with: $@" if $@; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # find some name that isn't the one we found before my( $other_name, $other_uid, $other_group_name, $other_gid ); eval { for( my $i = 0; $i < 65535; $i++ ) { next if $i == $owner_uid; my @stats = getpwuid $i; next unless @stats; ( $other_uid, $other_name ) = ( $i, $stats[0] ); last; } # XXX: why the for loop? for( my $i = 0; $i < 65535; $i++ ) { next if $i == $file_gid; my @stats = getgrgid $i; next unless @stats; ( $other_gid, $other_group_name ) = ( $i, $stats[0] ); last; } die "Failed to find another uid" unless defined $other_uid; die "Failed to find name for other uid ($other_uid)" unless defined $other_name; die "Failed to find another gid" unless defined $other_gid; die "Failed to find name for other gid ($other_gid)" unless defined $other_group_name; }; plan skip_all => "I can't find a second user id to test with: $@" if $@; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # find some names that don't exist, to test bad input my( $invalid_user_name, $invalid_group_name ); eval { foreach my $user ( 'aaaa' .. 'zzzz' ) { my @stats = getpwnam $user; next if @stats; $invalid_user_name = $user; #diag "Using invalid user [$user] for tests"; last; } foreach my $group ( 'aaaa' .. 'zzzz' ) { my @stats = getpwnam $group; next if @stats; $invalid_group_name = $group; #diag "Using invalid group [$group] for tests"; last; } diag "Failed to find an invalid username" unless defined $other_uid; diag "Failed to find another gid" unless defined $other_gid; }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test owner stuff owner_is( $filename, $owner_name, 'owner_is with text username' ); owner_is( $filename, $owner_uid, 'owner_is with numeric UID' ); owner_isnt( $filename, $other_name, 'owner_isnt with text username' ); owner_isnt( $filename, $other_uid, 'owner_isnt with numeric UID' ); my $name = 'Intentional owner_is failure with wrong user'; my $testname = "$filename belongs to $other_name"; test_out( "not ok 1 - $testname"); test_diag( "File [$filename] belongs to $owner_name ($owner_uid), not $other_name " . "($other_uid)!\n" . "# Failed test '$testname'\n". "# at t/owner.t line " . line_num(+6) . "." ); owner_is( $filename, $other_name ); test_test( $name ); $name = "Intentional owner_is failure with invalid user [$invalid_user_name]"; $testname = "$filename belongs to $invalid_user_name"; test_out( "not ok 1 - $testname"); test_diag( "User [$invalid_user_name] does not exist on this system!\n" . "# Failed test '$testname'\n". "# at t/owner.t line " . line_num(+5) . "." ); owner_is( $filename, $invalid_user_name ); test_test( $name ); $name = 'owner_isnt for non-existent name'; $testname = "$filename doesn't belong to $invalid_user_name"; test_out( "ok 1 - $testname"); owner_isnt( $filename, $invalid_user_name ); test_test( $name ); $name = 'Intentional owner_isnt failure'; $testname = "$filename doesn't belong to $owner_name"; test_out( "not ok 1 - $testname"); test_diag( "File [$filename] belongs to $owner_name ($owner_uid)!\n" . "# Failed test '$testname'\n" . "# at t/owner.t line " . line_num(+5) . "." ); owner_isnt( $filename, $owner_name ); test_test( $name ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test group stuff group_is( $filename, $file_group_name, 'group_is with text groupname' ); group_is( $filename, $file_gid, 'group_is with numeric GID' ); group_isnt( $filename, $other_group_name, 'group_isnt with text groupname' ); group_isnt( $filename, $other_gid, 'group_isnt with numeric GID' ); $name = 'Intentional group_is failure'; test_out( "not ok 1 - $name"); test_diag( "File [$filename] belongs to $file_group_name ($file_gid), not ". "$other_group_name " . "($other_gid)!\n" . "# Failed test '$name'\n". "# at t/owner.t line " . line_num(+7) . "." ); group_is( $filename, $other_group_name, $name ); test_test( $name ); $name = "Intentional group_is failure with invalid group [$invalid_group_name]"; test_out( "not ok 1 - $name"); test_diag( "Group [$invalid_group_name] does not exist on this system!\n" . "# Failed test '$name'\n". "# at t/owner.t line " . line_num(+5) . "." ); group_is( $filename, $invalid_group_name, $name ); test_test( $name ); $name = 'Intentional group_isnt failure'; test_out( "not ok 1 - $name"); test_diag( "File [$filename] belongs to $file_group_name ($file_gid)!\n" . "# Failed test '$name'\n" . "# at t/owner.t line " . line_num(+5) . "." ); group_isnt( $filename, $file_group_name, $name ); test_test( $name ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # done_testing(); Test-File-1.442/t/pod.t000644 000765 000024 00000000201 12770775302 014773 0ustar00brianstaff000000 000000 use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Test-File-1.442/t/pod_coverage.t000644 000765 000024 00000000302 12770775302 016650 0ustar00brianstaff000000 000000 use Test::More; eval "use Test::Pod::Coverage"; if( $@ ) { plan skip_all => "Test::Pod::Coverage required for testing POD"; } else { plan tests => 1; pod_coverage_ok( "Test::File" ); } Test-File-1.442/t/rt/000755 000765 000024 00000000000 12770775303 014461 5ustar00brianstaff000000 000000 Test-File-1.442/t/setup_common000644 000765 000024 00000002576 12770775302 016500 0ustar00brianstaff000000 000000 use strict; use File::Temp qw(tempdir); use Test::More 0.95; my $dir = tempdir( CLEANUP => 1 ) or BAILOUT( "Could not setup temp directory" ); unless( -d $dir ) { mkdir 'test_files', 0700 or BAILOUT( "Could not make directory! $!" ); } chdir $dir or BAILOUT( "Could not change directory! $!" ); my @files = qw( max_file non_zero_file not_readable readable zero_file executable min_file not_executable not_writeable writeable mtime_file ); foreach my $file ( @files ) { open FH, "> $file"; close FH; } { my $count = chmod 0644, @files; is( $count, scalar @files ) or BAILOUT( "Could not make files readable" ); } { my $count = chmod 0400, 'readable', 'not_writeable', 'not_executable'; is( $count, 3 ) or BAILOUT( "Could not make files readable" ); } { my $count = chmod 0200, 'writeable', 'not_readable', 'zero_file', 'max_file', 'non_zero_file'; is( $count, 5 ) or BAILOUT( "Could not make files writeable" ); } { my $count = chmod 0100, 'executable'; is( $count, 1 ) or BAILOUT( "Could not make files executable" ); } truncate 'zero_file', 0; truncate 'max_file', 10; truncate 'min_file', 0; { open FH, '> min_file' or BAILOUT( "Could not write to min_file: $!" ); binmode FH; #, Windows, yo! print FH 'x' x 40, $/, 'x' x 11, $/; close FH; } is( -s 'min_file', 51 + 2 * length( $/ ) ); mkdir 'sub_dir', 0755 or BAILOUT( "Could not cerate subdir: $!" ); Test-File-1.442/t/test_dirs.t000644 000765 000024 00000002230 12770775302 016215 0ustar00brianstaff000000 000000 use strict; use warnings; use Test::Builder::Tester; use Test::More 0.95; use Test::File; use File::Spec::Functions qw(catfile); require "./t/setup_common"; open FH, '>', catfile( qw(sub_dir subdir_file) ); close FH; test_out( 'ok 1 - sub_dir is a directory' ); dir_exists_ok( 'sub_dir' ); test_test(); test_out( 'not ok 1 - bmoogle is a directory' ); test_diag( 'File [bmoogle] does not exist!' ); test_fail(+1); dir_exists_ok( 'bmoogle' ); test_test(); test_out( 'not ok 1 - readable is a directory' ); test_diag( 'File [readable] exists but is not a directory!' ); test_fail(+1); dir_exists_ok( 'readable' ); test_test(); test_out( 'ok 1 - directory sub_dir contains file subdir_file' ); dir_contains_ok( 'sub_dir', 'subdir_file' ); test_test(); test_out( 'not ok 1 - directory bmoogle contains file subdir_file' ); test_diag( 'Directory [bmoogle] does not exist!' ); test_fail(+1); dir_contains_ok( 'bmoogle', 'subdir_file' ); test_test(); test_out( 'not ok 1 - directory sub_dir contains file bmoogle' ); test_diag( 'File [bmoogle] does not exist in directory sub_dir!' ); test_fail(+1); dir_contains_ok( 'sub_dir', 'bmoogle' ); test_test(); done_testing(); Test-File-1.442/t/test_files.t000644 000765 000024 00000007647 12770775302 016377 0ustar00brianstaff000000 000000 use strict; use Test::Builder::Tester; use Test::More 0.95; use Test::File; =pod max_file non_zero_file not_readable readable zero_file executable min_file not_executable not_writeable writeable =cut require "./t/setup_common"; test_out( 'ok 1 - readable exists' ); file_exists_ok( 'readable' ); test_test(); test_out( 'ok 1 - fooey does not exist' ); file_not_exists_ok( 'fooey' ); test_test(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test_out( 'ok 1 - readable is readable' ); file_readable_ok( 'readable' ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( 'ok 1 - writeable is not readable' ); file_not_readable_ok( 'writeable' ); test_test(); }; test_out( 'ok 1 - writeable is writeable' ); file_writeable_ok( 'writeable' ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( 'ok 1 - readable is not writeable' ); file_not_writeable_ok( 'readable' ); test_test(); }; { my $s = Test::File::_win32() ? "# skip file_executable_ok doesn't work on Windows!" : "- executable is executable"; test_out( "ok 1 $s" ); file_executable_ok( 'executable' ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_not_executable_ok doesn't work on Windows!" : "- not_executable is not executable"; test_out( "ok 1 $s" ); file_not_executable_ok( 'not_executable' ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_is doesn't work on Windows!" : "- executable mode is 0100"; test_out( "ok 1 $s" ); file_mode_is( 'executable', 0100 ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_has doesn't work on Windows!" : "- executable mode has all bits of 0100"; test_out( "ok 1 $s" ); file_mode_has( 'executable', 0100 ); test_test(); } { if (Test::File::_win32) { test_out( "ok 1 # skip file_mode_has doesn't work on Windows!" ); file_mode_has( 'executable', 0111 ); } else { test_out( "not ok 1 - executable mode has all bits of 0111" ); test_diag("File [executable] mode is missing component 0011!"); test_diag(" Failed test 'executable mode has all bits of 0111'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+1) . "."); file_mode_has( 'executable', 0111 ); } test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_isnt doesn't work on Windows!" : "- executable mode is not 0200"; test_out( "ok 1 $s" ); file_mode_isnt( 'executable', 0200 ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_hasnt doesn't work on Windows!" : "- executable mode has no bits of 0200"; test_out( "ok 1 $s" ); file_mode_hasnt( 'executable', 0200 ); test_test(); } { if (Test::File::_win32()) { test_out( "ok 1 # skip file_mode_hasnt doesn't work on Windows!" ); file_mode_hasnt( 'executable', 0111 ); } else { test_out( "not ok 1 - executable mode has no bits of 0111" ); test_diag("File [executable] mode has forbidden component 0100!"); test_diag(" Failed test 'executable mode has no bits of 0111'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+1) . "."); file_mode_hasnt( 'executable', 0111 ); } test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_is doesn't work on Windows!" : "- readable mode is 0400"; test_out( "ok 1 $s" ); file_mode_is( 'readable', 0400 ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_isnt doesn't work on Windows!" : "- readable mode is not 0200"; test_out( "ok 1 $s" ); file_mode_isnt( 'readable', 0200 ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_is doesn't work on Windows!" : "- writeable mode is 0200"; test_out( "ok 1 $s" ); file_mode_is( 'writeable', 0200 ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_isnt doesn't work on Windows!" : "- writeable mode is not 0100"; test_out( "ok 1 $s" ); file_mode_isnt( 'writeable', 0100 ); test_test(); } done_testing(); Test-File-1.442/t/test_manifest000644 000765 000024 00000000355 12770775302 016626 0ustar00brianstaff000000 000000 load.t pod.t pod_coverage.t normalize.t dm_skeleton.t win32.t obviously_non_multi_user.t test_files.t test_dirs.t links.t link_counts.t line_counters.t file_sizes.t file_contains.t file_mtime.t owner.t rt/30346.t file_contains_encoded.t Test-File-1.442/t/win32.t000644 000765 000024 00000001307 12770775302 015163 0ustar00brianstaff000000 000000 use strict; use warnings; use Test::Builder::Tester; use Test::More 0.95; subtest load => sub { use_ok( 'Test::File' ); ok( defined &{ "Test::File::_win32" }, "_win32 defined" ); }; subtest darwin => sub { local $^O = 'darwin'; ok( ! Test::File::_win32(), "Returns false for darwin" ); }; subtest win32 => sub { local $^O = 'Win32'; ok( Test::File::_win32(), "Returns true for Win32" ); }; subtest file_modes => sub { local $^O = 'Win32'; my @subs = qw( file_mode_is file_mode_isnt file_executable_ok file_not_executable_ok ); foreach my $sub ( @subs ) { no strict 'refs'; test_out("ok 1 # skip $sub doesn't work on Windows!"); &{$sub}(); test_test(); } }; done_testing(); Test-File-1.442/t/rt/30346.t000644 000765 000024 00000002242 12770775302 015324 0ustar00brianstaff000000 000000 use strict; use Test::Builder::Tester; use Test::More 0.95; use_ok( 'Test::File' ); use Cwd; require 't/setup_common'; subtest file_does_not_exist => sub { my $file = "no_such_file-" . "$$" . time() . "b$<$>m"; unlink $file; my $name = "$file is not empty"; test_out( "not ok 1 - $name"); test_diag( "File [$file] does not exist!\n" . " # Failed test '$name'\n". " # at $0 line " . line_num(+5) . "." ); file_not_empty_ok( $file ); test_test( $name ); }; subtest file_exists_non_zero => sub { my $file = 'min_file'; diag( "File is $file with size " . (-s $file) . " bytes" ); my $name = "$file is not empty"; test_out( "ok 1 - $name"); file_not_empty_ok( $file ); test_test( $name ); }; subtest file_exists_zero_size => sub { require File::Spec; my $file = 'file_not_empty_ok_test'; open my $fh, ">", $file; truncate $fh, 0; close $fh; my $name = "$file is not empty"; test_out( "not ok 1 - $name"); test_diag( "File [$file] exists with zero size!\n" . " # Failed test '$name'\n". " # at $0 line " . line_num(+5) . "." ); file_not_empty_ok( $file ); test_test( $name ); unlink $file; }; done_testing(); Test-File-1.442/lib/Test/000755 000765 000024 00000000000 12770775303 015256 5ustar00brianstaff000000 000000 Test-File-1.442/lib/Test/File.pm000644 000765 000024 00000116321 12770775302 016476 0ustar00brianstaff000000 000000 package Test::File; use strict; use base qw(Exporter); use vars qw(@EXPORT $VERSION); use File::Spec; use Test::Builder; @EXPORT = qw( file_exists_ok file_not_exists_ok file_empty_ok file_not_empty_ok file_size_ok file_max_size_ok file_min_size_ok file_readable_ok file_not_readable_ok file_writeable_ok file_not_writeable_ok file_executable_ok file_not_executable_ok file_mode_is file_mode_isnt file_mode_has file_mode_hasnt file_is_symlink_ok symlink_target_exists_ok symlink_target_is symlink_target_dangles_ok dir_exists_ok dir_contains_ok link_count_is_ok link_count_gt_ok link_count_lt_ok owner_is owner_isnt group_is group_isnt file_line_count_is file_line_count_isnt file_line_count_between file_contains_like file_contains_unlike file_contains_utf8_like file_contains_utf8_unlike file_contains_encoded_like file_contains_encoded_unlike file_mtime_gt_ok file_mtime_lt_ok file_mtime_age_ok ); $VERSION = '1.442'; { use warnings; } my $Test = Test::Builder->new(); =encoding utf8 =head1 NAME Test::File -- test file attributes =head1 SYNOPSIS use Test::File; =head1 DESCRIPTION This modules provides a collection of test utilities for file attributes. Some file attributes depend on the owner of the process testing the file in the same way the file test operators do. For instance, root (or super-user or Administrator) may always be able to read files no matter the permissions. Some attributes don't make sense outside of Unix, either, so some tests automatically skip if they think they won't work on the platform. If you have a way to make these functions work on Windows, for instance, please send me a patch. :) IF you want to pretend to be Windows on a non-Windows machine (for instance, to test C), you can set the C environment variable. The optional NAME parameter for every function allows you to specify a name for the test. If not supplied, a reasonable default will be generated. =head2 Functions =cut sub _normalize { my $file = shift; return unless defined $file; return $file =~ m|/| ? File::Spec->catfile( split m|/|, $file ) : $file; } sub _win32 { return 0 if $^O eq 'darwin'; return $ENV{PRETEND_TO_BE_WIN32} if defined $ENV{PRETEND_TO_BE_WIN32}; return $^O =~ m/Win/; } # returns true if symlinks can't exist sub _no_symlinks_here { ! eval { symlink("",""); 1 } } # owner_is and owner_isn't should skip on OS where the question makes no # sense. I really don't know a good way to test for that, so I'm going # to skip on the two OS's that I KNOW aren't multi-user. I'd love to add # more if anyone knows of any # Note: I don't have a dos or mac os < 10 machine to test this on sub _obviously_non_multi_user { foreach my $os ( qw(dos MacOS) ) { return 1 if $^O eq $os } return 0 if $^O eq 'MSWin32'; eval { my $holder = getpwuid(0) }; return 1 if $@; eval { my $holder = getgrgid(0) }; return 1 if $@; return 0; } =over 4 =item file_exists_ok( FILENAME [, NAME ] ) Ok if the file exists, and not ok otherwise. =cut sub file_exists_ok { my $filename = _normalize( shift ); my $name = shift || "$filename exists"; my $ok = -e $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("File [$filename] does not exist"); $Test->ok(0, $name); } } =item file_not_exists_ok( FILENAME [, NAME ] ) Ok if the file does not exist, and not okay if it does exist. =cut sub file_not_exists_ok { my $filename = _normalize( shift ); my $name = shift || "$filename does not exist"; my $ok = not -e $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("File [$filename] exists"); $Test->ok(0, $name); } } =item file_empty_ok( FILENAME [, NAME ] ) Ok if the file exists and has empty size, not ok if the file does not exist or exists with non-zero size. =cut sub file_empty_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is empty"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = -z $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] exists with non-zero size!" ); $Test->ok(0, $name); } } =item file_not_empty_ok( FILENAME [, NAME ] ) Ok if the file exists and has non-zero size, not ok if the file does not exist or exists with zero size. =cut sub file_not_empty_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is not empty"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = not -z _; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] exists with zero size!" ); $Test->ok(0, $name); } } =item file_size_ok( FILENAME, SIZE [, NAME ] ) Ok if the file exists and has SIZE size in bytes (exactly), not ok if the file does not exist or exists with size other than SIZE. =cut sub file_size_ok { my $filename = _normalize( shift ); my $expected = int shift; my $name = shift || "$filename has right size"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = ( -s $filename ) == $expected; if( $ok ) { $Test->ok(1, $name); } else { my $actual = -s $filename; $Test->diag( "File [$filename] has actual size [$actual] not [$expected]!" ); $Test->ok(0, $name); } } =item file_max_size_ok( FILENAME, MAX [, NAME ] ) Ok if the file exists and has size less than or equal to MAX bytes, not ok if the file does not exist or exists with size greater than MAX bytes. =cut sub file_max_size_ok { my $filename = _normalize( shift ); my $max = int shift; my $name = shift || "$filename is under $max bytes"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = ( -s $filename ) <= $max; if( $ok ) { $Test->ok(1, $name); } else { my $actual = -s $filename; $Test->diag( "File [$filename] has actual size [$actual] " . "greater than [$max]!" ); $Test->ok(0, $name); } } =item file_min_size_ok( FILENAME, MIN [, NAME ] ) Ok if the file exists and has size greater than or equal to MIN bytes, not ok if the file does not exist or exists with size less than MIN bytes. =cut sub file_min_size_ok { my $filename = _normalize( shift ); my $min = int shift; my $name = shift || "$filename is over $min bytes"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = ( -s $filename ) >= $min; if( $ok ) { $Test->ok(1, $name); } else { my $actual = -s $filename; $Test->diag( "File [$filename] has actual size ". "[$actual] less than [$min]!" ); $Test->ok(0, $name); } } =item file_line_count_is( FILENAME, COUNT [, NAME ] ) Ok if the file exists and has COUNT lines (exactly), not ok if the file does not exist or exists with a line count other than COUNT. This function uses the current value of C<$/> as the line ending and counts the lines by reading them and counting how many it read. =cut sub _ENOFILE () { -1 } sub _ECANTOPEN () { -2 } sub _file_line_counter { my $filename = shift; return _ENOFILE unless -e $filename; # does not exist return _ECANTOPEN unless open my( $fh ), "<", $filename; my $count = 0; while( <$fh> ) { $count++ } return $count; } # XXX: lots of cut and pasting here, needs refactoring # looks like the refactoring might be worse than this though sub file_line_count_is { my $filename = _normalize( shift ); my $expected = shift; my $name = do { no warnings 'uninitialized'; shift || "$filename line count is $expected lines"; }; unless( defined $expected && int( $expected ) == $expected ) { no warnings 'uninitialized'; $Test->diag( "file_line_count_is expects a positive whole number for " . "the second argument. Got [$expected]!" ); return $Test->ok( 0, $name ); } my $got = _file_line_counter( $filename ); if( $got eq _ENOFILE ) { $Test->diag( "File [$filename] does not exist!" ); $Test->ok( 0, $name ); } elsif( $got == _ECANTOPEN ) { $Test->diag( "Could not open [$filename]: \$! is [$!]!" ); $Test->ok( 0, $name ); } elsif( $got == $expected ) { $Test->ok( 1, $name ); } else { $Test->diag( "Expected [$expected] lines in [$filename], " . "got [$got] lines!" ); $Test->ok( 0, $name ); } } =item file_line_count_isnt( FILENAME, COUNT [, NAME ] ) Ok if the file exists and doesn't have exactly COUNT lines, not ok if the file does not exist or exists with a line count of COUNT. Read that carefully: the file must exist for this test to pass! This function uses the current value of C<$/> as the line ending and counts the lines by reading them and counting how many it read. =cut sub file_line_count_isnt { my $filename = _normalize( shift ); my $expected = shift; my $name = do { no warnings 'uninitialized'; shift || "$filename line count is not $expected lines"; }; unless( defined $expected && int( $expected ) == $expected ) { no warnings 'uninitialized'; $Test->diag( "file_line_count_is expects a positive whole number for " . "the second argument. Got [$expected]!" ); return $Test->ok( 0, $name ); } my $got = _file_line_counter( $filename ); if( $got eq _ENOFILE ) { $Test->diag( "File [$filename] does not exist!" ); $Test->ok( 0, $name ); } elsif( $got == _ECANTOPEN ) { $Test->diag( "Could not open [$filename]: \$! is [$!]!" ); $Test->ok( 0, $name ); } elsif( $got != $expected ) { $Test->ok( 1, $name ); } else { $Test->diag( "Expected something other than [$expected] lines in [$filename], " . "but got [$got] lines!" ); $Test->ok( 0, $name ); } } =item file_line_count_between( FILENAME, MIN, MAX, [, NAME ] ) Ok if the file exists and has a line count between MIN and MAX, inclusively. This function uses the current value of C<$/> as the line ending and counts the lines by reading them and counting how many it read. =cut sub file_line_count_between { my $filename = _normalize( shift ); my $min = shift; my $max = shift; my $name = do { no warnings 'uninitialized'; shift || "$filename line count is between [$min] and [$max] lines"; }; foreach my $ref ( \$min, \$max ) { unless( defined $$ref && int( $$ref ) == $$ref ) { no warnings 'uninitialized'; $Test->diag( "file_line_count_between expects positive whole numbers for " . "the second and third arguments. Got [$min] and [$max]!" ); return $Test->ok( 0, $name ); } } my $got = _file_line_counter( $filename ); if( $got eq _ENOFILE ) { $Test->diag( "File [$filename] does not exist!" ); $Test->ok( 0, $name ); } elsif( $got == _ECANTOPEN ) { $Test->diag( "Could not open [$filename]: \$! is [$!]!" ); $Test->ok( 0, $name ); } elsif( $min <= $got and $got <= $max ) { $Test->ok( 1, $name ); } else { $Test->diag( "Expected a line count between [$min] and [$max] " . "in [$filename], but got [$got] lines!" ); $Test->ok( 0, $name ); } } =item file_contains_like ( FILENAME, PATTERN [, NAME ] ) Ok if the file exists and its contents (as one big string) match PATTERN, not ok if the file does not exist, is not readable, or exists but doesn't match PATTERN. Since the file contents are read into memory, you should not use this for large files. Besides memory consumption, test diagnostics for failing tests might be difficult to decipher. However, for short files this works very well. Because the entire contents are treated as one large string, you can make a pattern that tests multiple lines. Don't forget that you may need to use the /s modifier for such patterns: # make sure file has one or more paragraphs with CSS class X file_contains_like($html_file, qr{

.*?

}s); Contrariwise, if you need to match at the beginning or end of a line inside the file, use the /m modifier: # make sure file has a setting for foo file_contains_like($config_file, qr/^ foo \s* = \s* \w+ $/mx); If you want to test your file contents against multiple patterns, but don't want to have the file read in repeatedly, you can pass an arrayref of patterns instead of a single pattern, like so: # make sure our template has rendered correctly file_contains_like($template_out, [ qr/^ $title_line $/mx, map { qr/^ $_ $/mx } @chapter_headings, qr/^ $footer_line $/mx, ]); Please note that if you do this, and your file does not exist or is not readable, you'll only get one test failure instead of a failure for each pattern. This could cause your test plan to be off, although you may not care at that point because your test failed anyway. If you do care, either skip the test plan altogether by employing L's C function, or use L in conjunction with a C block. Contributed by Buddy Burden C<< >>. =item file_contains_unlike ( FILENAME, PATTERN [, NAME ] ) Ok if the file exists and its contents (as one big string) do B match PATTERN, not ok if the file does not exist, is not readable, or exists but matches PATTERN. All notes and caveats for L apply to this function as well. Contributed by Buddy Burden C<< >>. =item file_contains_utf8_like ( FILENAME, PATTERN [, NAME ] ) The same as C, except the file is opened as UTF-8. =item file_contains_utf8_unlike ( FILENAME, PATTERN [, NAME ] ) The same as C, except the file is opened as UTF-8. =item file_contains_encoded_like ( FILENAME, ENCODING, PATTERN [, NAME ] ) The same as C, except the file is opened with ENCODING =item file_contains_encoded_unlike ( FILENAME, ENCODING, PATTERN [, NAME ] ) The same as C, except the file is opened with ENCODING. =cut sub file_contains_like { local $Test::Builder::Level = $Test::Builder::Level + 1; _file_contains(like => "contains", undef, @_); } sub file_contains_unlike { local $Test::Builder::Level = $Test::Builder::Level + 1; _file_contains(unlike => "doesn't contain", undef, @_); } sub file_contains_utf8_like { local $Test::Builder::Level = $Test::Builder::Level + 1; _file_contains(like => "contains", 'UTF-8', @_); } sub file_contains_utf8_unlike { local $Test::Builder::Level = $Test::Builder::Level + 1; _file_contains(unlike => "doesn't contain", 'UTF-8', @_); } sub file_contains_encoded_like { local $Test::Builder::Level = $Test::Builder::Level + 1; my $filename = shift; my $encoding = shift; _file_contains(like => "contains", $encoding, $filename, @_); } sub file_contains_encoded_unlike { local $Test::Builder::Level = $Test::Builder::Level + 1; my $filename = shift; my $encoding = shift; _file_contains(unlike => "doesn't contain", $encoding, $filename, @_); } sub _file_contains { my $method = shift; my $verb = shift; my $encoding = shift; my $filename = _normalize( shift ); my $patterns = shift; my $name = shift; my (@patterns, %patterns); if (ref $patterns eq 'ARRAY') { @patterns = @$patterns; %patterns = map { $_ => $name || "$filename $verb $_" } @patterns; } else { @patterns = ($patterns); %patterns = ( $patterns => $name || "$filename $verb $patterns" ); } # for purpose of checking the file's existence, just use the first # test name as the name $name = $patterns{$patterns[0]}; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } unless( -r $filename ) { $Test->diag( "File [$filename] is not readable!" ); return $Test->ok(0, $name); } # do the slurp my $file_contents; { unless (open(FH, $filename)) { $Test->diag( "Could not open [$filename]: \$! is [$!]!" ); return $Test->ok( 0, $name ); } if (defined $encoding) { binmode FH, ":encoding($encoding)"; } local $/ = undef; $file_contents = ; close FH; } foreach my $p (@patterns) { $Test->$method($file_contents, $p, $patterns{$p}); } } =item file_readable_ok( FILENAME [, NAME ] ) Ok if the file exists and is readable, not ok if the file does not exist or is not readable. =cut sub file_readable_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is readable"; my $ok = -r $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] is not readable!" ); $Test->ok(0, $name); } } =item file_not_readable_ok( FILENAME [, NAME ] ) Ok if the file exists and is not readable, not ok if the file does not exist or is readable. =cut sub file_not_readable_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is not readable"; my $ok = not -r $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] is readable!" ); $Test->ok(0, $name); } } =item file_writeable_ok( FILENAME [, NAME ] ) Ok if the file exists and is writeable, not ok if the file does not exist or is not writeable. =cut sub file_writeable_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is writeable"; my $ok = -w $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] is not writeable!" ); $Test->ok(0, $name); } } =item file_not_writeable_ok( FILENAME [, NAME ] ) Ok if the file exists and is not writeable, not ok if the file does not exist or is writeable. =cut sub file_not_writeable_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is not writeable"; my $ok = not -w $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("File [$filename] is writeable!"); $Test->ok(0, $name); } } =item file_executable_ok( FILENAME [, NAME ] ) Ok if the file exists and is executable, not ok if the file does not exist or is not executable. This test automatically skips if it thinks it is on a Windows platform. =cut sub file_executable_ok { if( _win32() ) { $Test->skip( "file_executable_ok doesn't work on Windows!" ); return; } my $filename = _normalize( shift ); my $name = shift || "$filename is executable"; my $ok = -x $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("File [$filename] is not executable!"); $Test->ok(0, $name); } } =item file_not_executable_ok( FILENAME [, NAME ] ) Ok if the file exists and is not executable, not ok if the file does not exist or is executable. This test automatically skips if it thinks it is on a Windows platform. =cut sub file_not_executable_ok { if( _win32() ) { $Test->skip( "file_not_executable_ok doesn't work on Windows!" ); return; } my $filename = _normalize( shift ); my $name = shift || "$filename is not executable"; my $ok = not -x $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("File [$filename] is executable!"); $Test->ok(0, $name); } } =item file_mode_is( FILENAME, MODE [, NAME ] ) Ok if the file exists and the mode matches, not ok if the file does not exist or the mode does not match. This test automatically skips if it thinks it is on a Windows platform. Contributed by Shawn Sorichetti C<< >> =cut sub file_mode_is { if( _win32() ) { $Test->skip( "file_mode_is doesn't work on Windows!" ); return; } my $filename = _normalize( shift ); my $mode = shift; my $name = shift || sprintf("%s mode is %04o", $filename, $mode); my $ok = -e $filename && ((stat($filename))[2] & 07777) == $mode; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag(sprintf("File [%s] mode is not %04o!", $filename, $mode) ); $Test->ok(0, $name); } } =item file_mode_isnt( FILENAME, MODE [, NAME ] ) Ok if the file exists and mode does not match, not ok if the file does not exist or mode does match. This test automatically skips if it thinks it is on a Windows platform. Contributed by Shawn Sorichetti C<< >> =cut sub file_mode_isnt { if( _win32() ) { $Test->skip( "file_mode_isnt doesn't work on Windows!" ); return; } my $filename = _normalize( shift ); my $mode = shift; my $name = shift || sprintf("%s mode is not %04o",$filename,$mode); my $ok = not (-e $filename && ((stat($filename))[2] & 07777) == $mode); if( $ok ) { $Test->ok(1, $name); } else { $Test->diag(sprintf("File [%s] mode is %04o!",$filename,$mode)); $Test->ok(0, $name); } } =item file_mode_has( FILENAME, MODE [, NAME ] ) Ok if the file exists and has all the bits in mode turned on, not ok if the file does not exist or the mode does not match. That is, C<< FILEMODE & MODE == MODE >> must be true. This test automatically skips if it thinks it is on a Windows platform. Contributed by Ricardo Signes C<< >> =cut sub file_mode_has { if( _win32() ) { $Test->skip( "file_mode_has doesn't work on Windows!" ); return; } my $filename = _normalize( shift ); my $mode = shift; my $name = shift || sprintf("%s mode has all bits of %04o", $filename, $mode); my $present = -e $filename; my $gotmode = $present ? (stat($filename))[2] : undef; my $ok = $present && ($gotmode & $mode) == $mode; if( $ok ) { $Test->ok(1, $name); } else { my $missing = ($gotmode ^ $mode) & $mode; $Test->diag(sprintf("File [%s] mode is missing component %04o!", $filename, $missing) ); $Test->ok(0, $name); } } =item file_mode_hasnt( FILENAME, MODE [, NAME ] ) Ok if the file exists and has all the bits in mode turned off, not ok if the file does not exist or the mode does not match. That is, C<< FILEMODE & MODE == 0 >> must be true. This test automatically skips if it thinks it is on a Windows platform. Contributed by Ricardo Signes C<< >> =cut sub file_mode_hasnt { if( _win32() ) { $Test->skip( "file_mode_hasnt doesn't work on Windows!" ); return; } my $filename = _normalize( shift ); my $mode = shift; my $name = shift || sprintf("%s mode has no bits of %04o", $filename, $mode); my $present = -e $filename; my $gotmode = $present ? (stat($filename))[2] : undef; my $ok = $present && ($gotmode & $mode) == 0; if( $ok ) { $Test->ok(1, $name); } else { my $bad = $gotmode & $mode; $Test->diag(sprintf("File [%s] mode has forbidden component %04o!", $filename, $bad) ); $Test->ok(0, $name); } } =item file_is_symlink_ok( FILENAME [, NAME ] ) Ok if FILENAME is a symlink, even if it points to a non-existent file. This test automatically skips if the operating system does not support symlinks. If the file does not exist, the test fails. =cut sub file_is_symlink_ok { if( _no_symlinks_here() ) { $Test->skip( "file_is_symlink_ok doesn't work on systems without symlinks!" ); return; } my $file = shift; my $name = shift || "$file is a symlink"; if( -l $file ) { $Test->ok(1, $name) } else { $Test->diag( "File [$file] is not a symlink!" ); $Test->ok(0, $name); } } =item symlink_target_exists_ok( SYMLINK [, TARGET] [, NAME ] ) Ok if FILENAME is a symlink and it points to a existing file. With the optional TARGET argument, the test fails if SYMLINK's target is not TARGET. This test automatically skips if the operating system does not support symlinks. If the file does not exist, the test fails. =cut sub symlink_target_exists_ok { if( _no_symlinks_here() ) { $Test->skip( "symlink_target_exists_ok doesn't work on systems without symlinks!" ); return; } my $file = shift; my $dest = shift || readlink( $file ); my $name = shift || "$file is a symlink"; unless( -l $file ) { $Test->diag( "File [$file] is not a symlink!" ); return $Test->ok( 0, $name ); } unless( -e $dest ) { $Test->diag( "Symlink [$file] points to non-existent target [$dest]!" ); return $Test->ok( 0, $name ); } my $actual = readlink( $file ); unless( $dest eq $actual ) { $Test->diag( "Symlink [$file] points to\n" . " got: $actual\n" . " expected: $dest\n" ); return $Test->ok( 0, $name ); } $Test->ok( 1, $name ); } =item symlink_target_dangles_ok( SYMLINK [, NAME ] ) Ok if FILENAME is a symlink and if it doesn't point to a existing file. This test automatically skips if the operating system does not support symlinks. If the file does not exist, the test fails. =cut sub symlink_target_dangles_ok { if( _no_symlinks_here() ) { $Test->skip( "symlink_target_dangles_ok doesn't work on systems without symlinks!" ); return; } my $file = shift; my $dest = readlink( $file ); my $name = shift || "$file is a symlink"; unless( -l $file ) { $Test->diag( "File [$file] is not a symlink!" ); return $Test->ok( 0, $name ); } if( -e $dest ) { $Test->diag( "Symlink [$file] points to existing file [$dest] but shouldn't!" ); return $Test->ok( 0, $name ); } $Test->ok( 1, $name ); } =item symlink_target_is( SYMLINK, TARGET [, NAME ] ) Ok if FILENAME is a symlink and if points to TARGET. This test automatically skips if the operating system does not support symlinks. If the file does not exist, the test fails. =cut sub symlink_target_is { if( _no_symlinks_here() ) { $Test->skip( "symlink_target_is doesn't work on systems without symlinks!" ); return; } my $file = shift; my $dest = shift; my $name = shift || "symlink $file points to $dest"; unless( -l $file ) { $Test->diag( "File [$file] is not a symlink!" ); return $Test->ok( 0, $name ); } my $actual_dest = readlink( $file ); my $link_error = $!; unless( defined $actual_dest ) { $Test->diag( "Symlink [$file] does not have a defined target!" ); $Test->diag( "readlink error: $link_error" ) if defined $link_error; return $Test->ok( 0, $name ); } if( $dest eq $actual_dest ) { $Test->ok( 1, $name ); } else { $Test->ok( 0, $name ); $Test->diag(" got: $actual_dest" ); $Test->diag(" expected: $dest" ); } } =item symlink_target_is_absolute_ok( SYMLINK [, NAME ] ) Ok if FILENAME is a symlink and if its target is an absolute path. This test automatically skips if the operating system does not support symlinks. If the file does not exist, the test fails. =cut sub symlink_target_is_absolute_ok { if( _no_symlinks_here() ) { $Test->skip( "symlink_target_exists_ok doesn't work on systems without symlinks" ); return; } my( $from, $from_base, $to, $to_base, $name ) = @_; my $link = readlink( $from ); my $link_err = defined( $link ) ? '' : $!; # $! doesn't always get reset my $link_abs = abs_path( rel2abs($link, $from_base) ); my $to_abs = abs_path( rel2abs($to, $to_base) ); if (defined( $link_abs ) && defined( $to_abs ) && $link_abs eq $to_abs) { $Test->ok( 1, $name ); } else { $Test->ok( 0, $name ); $link ||= 'undefined'; $link_abs ||= 'undefined'; $to_abs ||= 'undefined'; $Test->diag(" link: $from"); $Test->diag(" got: $link"); $Test->diag(" (abs): $link_abs"); $Test->diag(" expected: $to"); $Test->diag(" (abs): $to_abs"); $Test->diag(" readlink() error: $link_err") if ($link_err); } } =item dir_exists_ok( DIRECTORYNAME [, NAME ] ) Ok if the file exists and is a directory, not ok if the file doesn't exist, or exists but isn't a directory. Contributed by Buddy Burden C<< >>. =cut sub dir_exists_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is a directory"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = -d $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] exists but is not a directory!" ); $Test->ok(0, $name); } } =item dir_contains_ok( DIRECTORYNAME, FILENAME [, NAME ] ) Ok if the directory exists and contains the file, not ok if the directory doesn't exist, or exists but doesn't contain the file. Contributed by Buddy Burden C<< >>. =cut sub dir_contains_ok { my $dirname = _normalize( shift ); my $filename = _normalize( shift ); my $name = shift || "directory $dirname contains file $filename"; unless( -d $dirname ) { $Test->diag( "Directory [$dirname] does not exist!" ); return $Test->ok(0, $name); } my $ok = -e File::Spec->catfile($dirname, $filename); if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] does not exist in directory $dirname!" ); $Test->ok(0, $name); } } =item link_count_is_ok( FILE, LINK_COUNT [, NAME ] ) Ok if the link count to FILE is LINK_COUNT. LINK_COUNT is interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok if the file does not exist. =cut sub link_count_is_ok { my $file = shift; my $count = int( 0 + shift ); my $name = shift || "$file has a link count of [$count]"; my $actual = ( stat $file )[3]; unless( $actual == $count ) { $Test->diag( "File [$file] points has [$actual] links: expected [$count]!" ); return $Test->ok( 0, $name ); } $Test->ok( 1, $name ); } =item link_count_gt_ok( FILE, LINK_COUNT [, NAME ] ) Ok if the link count to FILE is greater than LINK_COUNT. LINK_COUNT is interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok if the file has at least one link. =cut sub link_count_gt_ok { my $file = shift; my $count = int( 0 + shift ); my $name = shift || "$file has a link count of [$count]"; my $actual = (stat $file )[3]; unless( $actual > $count ) { $Test->diag( "File [$file] points has [$actual] links: ". "expected more than [$count]!" ); return $Test->ok( 0, $name ); } $Test->ok( 1, $name ); } =item link_count_lt_ok( FILE, LINK_COUNT [, NAME ] ) Ok if the link count to FILE is less than LINK_COUNT. LINK_COUNT is interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok if the file has at least one link. =cut sub link_count_lt_ok { my $file = shift; my $count = int( 0 + shift ); my $name = shift || "$file has a link count of [$count]"; my $actual = (stat $file )[3]; unless( $actual < $count ) { $Test->diag( "File [$file] points has [$actual] links: ". "expected less than [$count]!" ); return $Test->ok( 0, $name ); } $Test->ok( 1, $name ); } # owner_is, owner_isnt, group_is and group_isnt are almost # identical in the beginning, so I'm writing a skeleton they can all use. # I can't think of a better name... sub _dm_skeleton { no warnings 'uninitialized'; if( _obviously_non_multi_user() ) { my $calling_sub = (caller(1))[3]; $Test->skip( $calling_sub . " only works on a multi-user OS!" ); return 'skip'; } my $filename = _normalize( shift ); my $testing_for = shift; my $name = shift; unless( defined $filename ) { $Test->diag( "File name not specified!" ); return $Test->ok( 0, $name ); } unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok( 0, $name ); } return; } =item owner_is( FILE , OWNER [, NAME ] ) Ok if FILE's owner is the same as OWNER. OWNER may be a text user name or a numeric userid. Test skips on Dos, and Mac OS <= 9. If the file does not exist, the test fails. Contributed by Dylan Martin =cut sub owner_is { my $filename = shift; my $owner = shift; my $name = shift || "$filename belongs to $owner"; my $err = _dm_skeleton( $filename, $owner, $name ); return if( defined( $err ) && $err eq 'skip' ); return $err if defined($err); my $owner_uid = _get_uid( $owner ); unless( defined $owner_uid ) { $Test->diag("User [$owner] does not exist on this system!"); return $Test->ok( 0, $name ); } my $file_uid = ( stat $filename )[4]; unless( defined $file_uid ) { $Test->skip("stat failed to return owner uid for $filename!"); return; } return $Test->ok( 1, $name ) if $file_uid == $owner_uid; my $real_owner = ( getpwuid $file_uid )[0]; unless( defined $real_owner ) { $Test->diag("File does not belong to $owner!"); return $Test->ok( 0, $name ); } $Test->diag( "File [$filename] belongs to $real_owner ($file_uid), ". "not $owner ($owner_uid)!" ); return $Test->ok( 0, $name ); } =item owner_isnt( FILE, OWNER [, NAME ] ) Ok if FILE's owner is not the same as OWNER. OWNER may be a text user name or a numeric userid. Test skips on Dos and Mac OS <= 9. If the file does not exist, the test fails. Contributed by Dylan Martin =cut sub owner_isnt { my $filename = shift; my $owner = shift; my $name = shift || "$filename doesn't belong to $owner"; my $err = _dm_skeleton( $filename, $owner, $name ); return if( defined( $err ) && $err eq 'skip' ); return $err if defined($err); my $owner_uid = _get_uid( $owner ); unless( defined $owner_uid ) { return $Test->ok( 1, $name ); } my $file_uid = ( stat $filename )[4]; #$Test->diag( "owner_isnt: $owner_uid $file_uid" ); return $Test->ok( 1, $name ) if $file_uid != $owner_uid; $Test->diag( "File [$filename] belongs to $owner ($owner_uid)!" ); return $Test->ok( 0, $name ); } =item group_is( FILE , GROUP [, NAME ] ) Ok if FILE's group is the same as GROUP. GROUP may be a text group name or a numeric group id. Test skips on Dos, Mac OS <= 9 and any other operating systems that do not support getpwuid() and friends. If the file does not exist, the test fails. Contributed by Dylan Martin =cut sub group_is { my $filename = shift; my $group = shift; my $name = ( shift || "$filename belongs to group $group" ); my $err = _dm_skeleton( $filename, $group, $name ); return if( defined( $err ) && $err eq 'skip' ); return $err if defined($err); my $group_gid = _get_gid( $group ); unless( defined $group_gid ) { $Test->diag("Group [$group] does not exist on this system!"); return $Test->ok( 0, $name ); } my $file_gid = ( stat $filename )[5]; unless( defined $file_gid ) { $Test->skip("stat failed to return group gid for $filename!"); return; } return $Test->ok( 1, $name ) if $file_gid == $group_gid; my $real_group = ( getgrgid $file_gid )[0]; unless( defined $real_group ) { $Test->diag("File does not belong to $group!"); return $Test->ok( 0, $name ); } $Test->diag( "File [$filename] belongs to $real_group ($file_gid), ". "not $group ($group_gid)!" ); return $Test->ok( 0, $name ); } =item group_isnt( FILE , GROUP [, NAME ] ) Ok if FILE's group is not the same as GROUP. GROUP may be a text group name or a numeric group id. Test skips on Dos, Mac OS <= 9 and any other operating systems that do not support getpwuid() and friends. If the file does not exist, the test fails. Contributed by Dylan Martin =cut sub group_isnt { my $filename = shift; my $group = shift; my $name = shift || "$filename does not belong to group $group"; my $err = _dm_skeleton( $filename, $group, $name ); return if( defined( $err ) && $err eq 'skip' ); return $err if defined($err); my $group_gid = _get_gid( $group ); my $file_gid = ( stat $filename )[5]; unless( defined $file_gid ) { $Test->skip("stat failed to return group gid for $filename!"); return; } return $Test->ok( 1, $name ) if $file_gid != $group_gid; $Test->diag( "File [$filename] belongs to $group ($group_gid)!" ); return $Test->ok( 0, $name ); } sub _get_uid { my $owner = shift; my $owner_uid; if ($owner =~ /^\d+/) { $owner_uid = $owner; $owner = ( getpwuid $owner )[0]; } else { $owner_uid = (getpwnam($owner))[2]; } $owner_uid; } sub _get_gid { my $group = shift; my $group_uid; if ($group =~ /^\d+/) { $group_uid = $group; $group = ( getgrgid $group )[0]; } else { $group_uid = (getgrnam($group))[2]; } $group_uid; } =item file_mtime_age_ok( FILE [, WITHIN_SECONDS ] [, NAME ] ) Ok if FILE's modified time is WITHIN_SECONDS inclusive of the system's current time. This test uses stat() to obtain the mtime. If the file does not exist the test returns failure. If stat() fails, the test is skipped. =cut sub file_mtime_age_ok { my $filename = shift; my $within_secs = int shift || 0; my $name = shift || "$filename mtime within $within_secs seconds of current time"; my $time = time(); my $filetime = _stat_file($filename, 9); return if ( $filetime == -1 ); #skip return $Test->ok(1, $name) if ( $filetime + $within_secs > $time-1 ); $Test->diag( "Filename [$filename] mtime [$filetime] is not $within_secs seconds within current system time [$time]."); return $Test->ok(0, $name); } =item file_mtime_gt_ok( FILE, UNIXTIME [, NAME ] ) Ok if FILE's mtime is > UNIXTIME. This test uses stat() to get the mtime. If stat() fails this test is skipped. If FILE does not exist, this test fails. =cut sub file_mtime_gt_ok { my $filename = shift; my $time = int shift; my $name = shift || "$filename mtime is less than unix timestamp $time"; my $filetime = _stat_file($filename, 9); return if ( $filetime == -1 ); #skip return $Test->ok(1, $name) if ( $filetime > $time ); $Test->diag( "Filename [$filename] mtime [$filetime] not greater than $time" ); $Test->ok(0, $name); } =item file_mtime_lt_ok( FILE, UNIXTIME, [, NAME ] ) Ok if FILE's modified time is < UNIXTIME. This test uses stat() to get the mtime. If stat() fails this test is skipped. If FILE does not exist, this test fails. =cut sub file_mtime_lt_ok { my $filename = shift; my $time = int shift; my $name = shift || "$filename mtime less than unix timestamp $time"; # gets mtime my $filetime = _stat_file($filename, 9); return if ( $filetime == -1 ); #skip return $Test->ok(1, $name) if ( $filetime < $time ); $Test->diag( "Filename [$filename] mtime [$filetime] not less than $time" ); $Test->ok(0, $name); } # private function to safely stat a file # # Arugments: # filename file to perform on # attr_pos pos of the array returned from stat we want to compare. perldoc -f stat # # Returns: # -1 - stat failed # 0 - failure (file doesn't exist etc) # filetime - on success, time requested provided by stat # sub _stat_file { my $filename = _normalize( shift ); my $attr_pos = shift; unless( defined $filename ) { $Test->diag( "Filename not specified!" ); return 0; } unless( -e $filename ) { $Test->diag( "Filename [$filename] does not exist!" ); return 0; } my $filetime = ( stat($filename) )[$attr_pos]; unless( $filetime ) { $Test->diag( "stat of $filename failed" ); return -1; #skip on stat failure } return $filetime; } =back =head1 TO DO * check properties for other users (readable_by_root, for instance) * check times * check number of links to file * check path parts (directory, filename, extension) =head1 SEE ALSO L, L =head1 SOURCE AVAILABILITY This module is in Github: git://github.com/briandfoy/test-file.git =head1 AUTHOR brian d foy, C<< >> =head1 CREDITS Shawn Sorichetti C<< >> provided some functions. Tom Metro helped me figure out some Windows capabilities. Dylan Martin added C and C. David Wheeler added C. Buddy Burden C<< >> provided C, C, C, and C. xmikew C<< >> provided the C stuff. =head1 COPYRIGHT AND LICENSE Copyright © 2002-2016, brian d foy . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut "The quick brown fox jumped over the lazy dog"; Test-File-1.442/examples/README000644 000765 000024 00000000105 12770775302 016262 0ustar00brianstaff000000 000000 See the tests in the t/ directory for examples until I add some more.