Test-File-1.995/0000755000076500000240000000000014777047514012333 5ustar brianstaffTest-File-1.995/LICENSE0000644000076500000240000002166414777047513013350 0ustar brianstaffThe Test::File module is licensed under the Artistic License 2.0. Artistic License 2.0 Copyright (c) 2000-2006, The Perl Foundation. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. 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 (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Test-File-1.995/CITATION.cff0000644000076500000240000000112214777047513014220 0ustar brianstaff# This CITATION.cff file was generated with /Users/brian/bin/bmt # Tue Feb 15 12:46:17 2022 abstract: Test::File -- test file attributes authors: - family-names: foy given-names: brian d orcid: 0000-0002-0283-8283 email: briandfoy@pobox.com cff-version: 1.2.0 date-released: refs/tags/v1.36 doi: 10.5281/zenodo.6093297 license: artistic_2 license-url: https://github.com/briandfoy/test-file/LICENSE message: The GitHub page for this module provides formatted citations repository-code: https://github.com/briandfoy/test-file title: The Test::File Perl module type: software version: '' Test-File-1.995/Changes0000644000076500000240000002236514777047513013635 0ustar brianstaffRevision history for Perl module Test::File 1.995 2025-04-13T23:56:59Z * require a newer version.pm for v5.10.1 tests 1.994 2025-01-03T06:58:48Z * refresh distro and move to BRIANDFOY 1.993 2022-12-31T20:33:55Z * Try harder to check for symlinks on Windows by stealing some code from Win32:: (Jean-Damien Durand) GitHub #36 1.992_01 2022-11-10T21:59:59Z * Try harder to test Windows symlinks, #36 from Jean-Damien Durand 1.992 2022-02-15T19:40:16Z * GitHub #29 - race condition in tests for mtime, from Slaven Rezić. Most people never experienced this timing issue, so if you have this already you don't need to update. 1.991 2022-01-21T01:37:36Z * Enforce text files in some functions, as warned in #18. * Change up some diag messages: 1) lowercase first letter 2) not ! at end, and 3) use "file" instead of "filename". If you were matching on those, you may need to update your patterns. 1.448 2021-03-05T15:01:18Z * Promote to a user release 1.447_01 2021-03-02T16:11:23Z * Try handling all-numeric user and group names (but, also, wtf?) Github #26. 1.447 2021-02-24T21:32:41Z * Trying harder to get the tests to pass on Cygwin 1.446 2021-02-20T21:18:48Z * Better cygwin detection, from Achim Gratz 1.445 2021-02-16T08:57:34Z * Get the tests to pass under Cygwin (Github #17, from Slaven Rezić) 1.444 2021-01-06T03:40:19Z * Remove Travis, add GitHub actions * Add file_is_symlink_not_ok 1.443_03 2020-06-15T13:13:42Z * Merge some test additions from Desmond Daignault (GitHub #20) 1.443_02 2020-06-15T12:10:34Z * Deprecated directories in tests appropriate for only plain files. It's a diag() message now but will be a test failure later. 1.443_01 2020-06-12T11:54:41Z * change the file_writeable_ok tests to file_writable_ok, which is the correct spelling. The old names work but now warn to use the new name. * Some updates to refresh the tests. * Start mirroring Test2::Tools::File so we support the same names. Thanks to Torbjørn Lindahl for spotting rough edges. 1.443 2017-04-17T08:41:35Z * Found another relative path require issue thanks to Ryan Voots http://blogs.perl.org/users/ryan_voots/2017/04/trials-and-troubles-with-changing-inc.html * This is another attempt at avoiding failures from the v5.26 removal of . from @INC. 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.995/MANIFEST0000644000076500000240000000125514777047514013467 0ustar brianstaffChanges CITATION.cff examples/README File.xs INSTALL.SKIP lib/Test/File.pm LICENSE Makefile.PL MANIFEST This list of files MANIFEST.SKIP README.pod SECURITY.md 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 xt/citations.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Test-File-1.995/t/0000755000076500000240000000000014777047514012576 5ustar brianstaffTest-File-1.995/t/pod.t0000644000076500000240000000020114777047513013535 0ustar brianstaffuse 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.995/t/file_sizes.t0000644000076500000240000001132614777047513015121 0ustar brianstaffuse strict; use Test::Builder::Tester; use Test::More 1; use Test::File; require "./t/setup_common"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test_out( 'ok 1 - zero_file is empty' ); file_empty_ok( 'zero_file' ); test_out( 'ok 2 - zero_file really is empty' ); file_empty_ok( 'zero_file', 'zero_file really is empty' ); test_test(); test_out( 'ok 1 - min_file is not empty' ); file_not_empty_ok( 'min_file' ); test_out( 'ok 2 - min_file really is not empty' ); file_not_empty_ok( 'min_file', 'min_file really is not empty' ); 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_out( "ok 2 - $file really has right size" ); file_size_ok( $file, $actual_size, "$file really has right size" ); test_test(); test_out( "ok 1 - $file is under $over_size bytes" ); file_max_size_ok( $file, $over_size ); test_out( "ok 2 - $file really is under $over_size bytes" ); file_max_size_ok( $file, $over_size, "$file really is under $over_size bytes" ); test_test(); test_out( "ok 1 - $file is over $under_size bytes" ); file_min_size_ok( $file, $under_size ); test_out( "ok 2 - $file really is over $under_size bytes" ); file_min_size_ok( $file, $under_size, "$file really is over $under_size bytes" ); test_test(); done_testing(); }; 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(); done_testing(); }; 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(); }; done_testing(); Test-File-1.995/t/line_counters.t0000644000076500000240000001232214777047513015633 0ustar brianstaffuse strict; use Test::Builder::Tester; use Test::More 1; 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" ); } done_testing(); }; 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(); done_testing(); }; 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(); done_testing(); }; 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(); done_testing(); }; 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(); }; done_testing(); Test-File-1.995/t/obviously_non_multi_user.t0000644000076500000240000000303314777047513020136 0ustar brianstaffuse Test::More 1; 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.995/t/test_dirs.t0000644000076500000240000000266314777047513014771 0ustar brianstaffuse strict; use warnings; use Test::Builder::Tester; use Test::More 1; 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' ); test_out( 'ok 2 - sub_dir really is a directory' ); dir_exists_ok( 'sub_dir' ); dir_exists_ok( 'sub_dir', 'sub_dir really is a directory' ); test_test(); test_out( 'not ok 1 - bmoogle is a directory' ); test_diag( 'directory [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' ); test_out( 'ok 2 - directory sub_dir really contains file subdir_file' ); dir_contains_ok( 'sub_dir', 'subdir_file' ); dir_contains_ok( 'sub_dir', 'subdir_file', 'directory sub_dir really contains file 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.995/t/dm_skeleton.t0000644000076500000240000000301614777047513015266 0ustar brianstaffuse strict; use Test::Builder::Tester; use Test::More 1; 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(); done_testing(); }; 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(); }; done_testing(); Test-File-1.995/t/links.t0000644000076500000240000001235514777047513014110 0ustar brianstaffuse strict; use Test::Builder::Tester; use Test::More 1; use Test::File; my $can_symlink = Test::File::has_symlinks(); plan skip_all => "This system doesn'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(); } done_testing(); }; 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 ); file_is_symlink_ok( $dangle_sym ); unlink $not_there or fail( $! ); ok( ! -e $not_there, "$not_there has been removed" ); 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(); done_testing(); }; 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(); done_testing(); }; 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(); done_testing(); }; subtest bad_target_does_exists => sub { test_out( "not ok 1 $s" ); test_diag( "symlink [readable_sym] points to\n" . " # got: readable\n" . " # expected: writable\n" . " # Failed test 'readable_sym is a symlink'\n" . " # at $0 line " . line_num(+7) . "." ); symlink_target_exists_ok( $readable_sym, "writable" ); test_test(); done_testing(); }; subtest dangling_exists => sub { test_out( "not ok 1 - $test_name" ); test_out( "not ok 2 - readable_sym is a symlink" ); test_diag( "symlink [$readable_sym] points to existing file [$readable] but shouldn't\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+10) . "." ); test_diag( "symlink [$readable_sym] points to existing file [$readable] but shouldn't\n" . " # Failed test 'readable_sym is a symlink'\n" . " # at $0 line " . line_num(+6) . "." ); symlink_target_dangles_ok( $readable_sym, $test_name ); symlink_target_dangles_ok( $readable_sym ); test_test(); done_testing(); }; done_testing(); Test-File-1.995/t/load.t0000644000076500000240000000023614777047513013702 0ustar brianstaffuse Test::More 1; my @classes = qw(Test::File); foreach my $class ( @classes ) { use_ok( $class ) or BAILOUT( "$class did not load" ); } done_testing(); Test-File-1.995/t/normalize.t0000644000076500000240000000347314777047513014771 0ustar brianstaffuse 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.995/t/file_mtime.t0000644000076500000240000000603114777047513015074 0ustar brianstaffuse warnings; use strict; use Test::Builder::Tester; use Test::More 1; 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(); subtest utime => sub { 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"; }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # subtest file_mtime_age_ok => sub { test_out( 'ok 1 - file_mtime_age_ok success' ); test_out( 'ok 2 - mtime_file mtime within 660 seconds of current time' ); file_mtime_age_ok( $mtime_file, 60*11, 'file_mtime_age_ok success' ); file_mtime_age_ok( $mtime_file, 60*11 ); test_test( 'file_mtime_age_ok success works' ); test_out( 'not ok 1 - mtime_file mtime within 0 seconds of current time' ); file_mtime_age_ok( $mtime_file ); test_test( name => 'file_mtime_age_ok success works', skip_err => 1 ); test_out( 'not ok 1 - file_mtime_age_ok failure' ); test_err( qr/\s*#\s*file \[$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' ); done_testing(); }; subtest file_mtime_lt_ok => sub { my $time = time() + 10; test_out( 'ok 1 - file_mtime_lt_ok success' ); test_out( 'ok 2 - mtime_file mtime less than unix timestamp ' . $time ); file_mtime_lt_ok( $mtime_file, $time, 'file_mtime_lt_ok success' ); file_mtime_lt_ok( $mtime_file, $time ); test_test( 'file_mtime_lt_ok success works' ); test_out( 'not ok 1 - file_mtime_lt_ok failure' ); test_err( qr/\s*#\s*file \[$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' ); done_testing(); }; subtest file_mtime_gt_ok => sub { test_out( 'ok 1 - file_mtime_gt_ok success' ); test_out( 'ok 2 - mtime_file mtime is greater than unix timestamp ' . ($curtime-60*11) ); file_mtime_gt_ok( $mtime_file, $curtime-60*11, 'file_mtime_gt_ok success' ); file_mtime_gt_ok( $mtime_file, $curtime-60*11 ); test_test( 'file_mtime_gt_ok success works' ); test_out( 'not ok 1 - file_mtime_gt_ok failure' ); test_err( qr/\s*#\s*file \[$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' ); done_testing(); }; subtest _stat_file => sub { # Test internal _stat_file function test_err( qr/\s*#\s*file \[.*?\] 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*file name not specified\n/ ); Test::File::_stat_file( undef ); test_test( '_stat_file no file provided works' ); done_testing(); }; done_testing(); Test-File-1.995/t/file_contains_encoded.t0000644000076500000240000000572714777047513017273 0ustar brianstaffuse strict; use warnings; use utf8; use Test::Builder::Tester; use Test::More 1; use Test::File; # 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.995/t/win32.t0000644000076500000240000000164114777047513013726 0ustar brianstaffuse strict; use warnings; use Test::Builder::Tester; use Test::More 1; 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 linux_pretend_win32 => sub { local %ENV; $ENV{PRETEND_TO_BE_WIN32} = 1; local $^O = 'linux'; ok( Test::File::_win32(), "Returns true for linux when ENV{PRETEND_TO_BE_WIN32} is defined" ); }; 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(); }; done_testing(); Test-File-1.995/t/rt/0000755000076500000240000000000014777047514013223 5ustar brianstaffTest-File-1.995/t/rt/30346.t0000644000076500000240000000231314777047513014065 0ustar brianstaffuse strict; use Test::Builder::Tester; use Test::More 1; 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 ); done_testing(); }; 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 ); done_testing(); }; 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(); }; done_testing(); Test-File-1.995/t/setup_common0000644000076500000240000000362214777047513015233 0ustar brianstaffuse strict; use Test::More 1; END{ done_testing() unless caller } use Config; use File::Temp qw(tempdir); sub is_cygwin () { scalar grep { lc($^O) eq $_ or lc($Config{osname}) eq $_ } qw( cygwin ) } sub is_msys () { scalar grep { lc($^O) eq $_ or lc($Config{osname}) eq $_ } qw( msys msys2 ) } sub is_win32 () { $^O eq 'MSWin32' } sub is_unix_superuser () { ( not is_win32() and ( $> == 0 or $< == 0 ) ) or ( is_cygwin() and grep { $_ == 544 } split /\s+/, `/usr/bin/id -G` ) } my $dir = tempdir( CLEANUP => 0 ) or BAIL_OUT( "Could not setup temp directory" ); print "Temp dir in <$dir>\n"; unless( -d $dir ) { mkdir 'test_files', 0700 or BAIL_OUT( "Could not make directory! $!" ); } chdir $dir or BAIL_OUT( "Could not change directory! $!" ); my @files = qw( max_file non_zero_file not_readable readable zero_file executable min_file not_executable not_writable writable mtime_file ); foreach my $file ( @files ) { open FH, "> $file"; close FH; } { my $count = chmod 0644, @files; is( $count, scalar @files ) or BAIL_OUT( "Could not make files readable" ); } { my $count = chmod 0400, 'readable', 'not_writable', 'not_executable'; is( $count, 3 ) or BAIL_OUT( "Could not make files readable" ); } { my $count = chmod 0200, 'writable', 'not_readable', 'zero_file', 'max_file', 'non_zero_file'; is( $count, 5 ) or BAIL_OUT( "Could not make files writable" ); if( is_win32() ) { system 'attrib', '+', 'not_readable'; } } { my $count = chmod 0100, 'executable'; is( $count, 1 ) or BAIL_OUT( "Could not make files executable" ); } truncate 'zero_file', 0; truncate 'max_file', 10; truncate 'min_file', 0; { open FH, '> min_file' or BAIL_OUT( "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 BAIL_OUT( "Could not cerate subdir: $!" ); Test-File-1.995/t/file_contains_utf8.t0000644000076500000240000000574314777047513016556 0ustar brianstaffuse strict; use warnings; use utf8; use Test::Builder::Tester; use Test::More 1; 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.995/t/file_contains.t0000644000076500000240000001206214777047513015600 0ustar brianstaffuse strict; use warnings; use Test::Builder::Tester; use Test::More 1; 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 is_unix_superuser(); skip "Windows has a different idea of readable", 1 if is_win32(); skip "Not possible to make file unreadable on MSYS", 1 if is_msys(); 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 is_unix_superuser(); skip "Windows has a different idea of readable", 1 if is_win32(); skip "Not possible to make file unreadable on MSYS", 1 if is_msys(); 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 is_unix_superuser(); skip "Windows has a different idea of readable", 1 if is_win32(); skip "Not possible to make file unreadable on MSYS", 1 if is_msys(); 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 is_unix_superuser(); skip "Windows has a different idea of readable", 1 if is_win32(); skip "Not possible to make file unreadable on MSYS", 1 if is_msys(); 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.995/t/link_counts.t0000644000076500000240000000474614777047513015325 0ustar brianstaffuse strict; use Test::Builder::Tester; use Test::More 1; 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" ); test_out( "ok 2 - readable has a link count of [100]" ); test_out( "ok 3 - $test_name" ); test_out( "ok 4 - readable has a link count of [0]" ); test_out( "ok 5 - $test_name" ); link_count_lt_ok( $readable, 100, $test_name ); link_count_lt_ok( $readable, 100 ); link_count_gt_ok( $readable, 0, $test_name ); link_count_gt_ok( $readable, 0 ); 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(); done_testing(); }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 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(); }; done_testing(); Test-File-1.995/t/test_manifest0000644000076500000240000000043214777047513015364 0ustar brianstaffload.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_contains_encoded.t file_contains_utf8.t file_mtime.t owner.t rt/30346.t file_contains_encoded.t Test-File-1.995/t/pod_coverage.t0000644000076500000240000000024114777047513015414 0ustar brianstaffuse Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok(); Test-File-1.995/t/test_files.t0000644000076500000240000002376514777047513015140 0ustar brianstaffuse strict; use Test::Builder::Tester; use Test::More 1; use Test::File; =pod max_file non_zero_file not_readable readable zero_file executable min_file not_executable not_writable writable =cut require "./t/setup_common"; diag "Warnings about file_writeable_ok are fine. It's a deprecated name that still works."; subtest readable => sub { my $label = 'file exists'; test_out( 'ok 1 - readable exists' ); file_exists_ok( 'readable' ); test_out( "ok 2 - $label" ); file_exists_ok( 'readable', $label ); test_test(); done_testing(); }; subtest exists_fails => sub { test_out( 'not ok 1 - fooey exists' ); test_diag( 'file [fooey] does not exist'); test_diag( " Failed test 'fooey exists'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+1) . "."); file_exists_ok( 'fooey' ); test_test(); done_testing(); }; subtest not_exists => sub { my $label = 'file exists'; test_out( 'ok 1 - fooey does not exist' ); file_not_exists_ok( 'fooey' ); test_out( "ok 2 - $label" ); file_not_exists_ok( 'fooey', $label ); test_test(); done_testing(); }; subtest not_exists_fails => sub { test_out( 'not ok 1 - readable does not exist' ); test_diag( 'file [readable] exists'); test_diag( " Failed test 'readable does not exist'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+1) . "."); file_not_exists_ok( 'readable' ); test_test(); done_testing(); }; subtest readable => sub { test_out( 'ok 1 - readable is readable' ); file_readable_ok( 'readable' ); test_out( 'ok 2 - readable really is readable' ); file_readable_ok( 'readable', 'readable really is readable' ); test_test(); done_testing(); }; subtest readable_fails => sub { SKIP: { skip "Superuser has special privileges", 2, is_unix_superuser(); test_out( 'not ok 1 - non_readable is readable' ); test_diag("file [non_readable] is not readable"); test_diag(" Failed test 'non_readable is readable'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+1) . "."); file_readable_ok( 'non_readable' ); test_test(); done_testing(); }}; subtest not_readable_fails => sub { SKIP: { skip "Superuser has special privileges", 3, if is_unix_superuser(); skip "Not possible to make file unreadable on MSYS" if is_msys(); test_out( 'ok 1 - writeable is not readable' ); file_not_readable_ok( 'writeable' ); test_out( 'ok 2 - writeable really is not readable' ); file_not_readable_ok( 'writeable', 'writeable really is not readable' ); test_out( 'not ok 3 - readable is not readable' ); test_diag('file [readable] is readable'); test_diag(" Failed test 'readable is not readable'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+1) . "."); file_not_readable_ok( 'readable' ); test_test(); done_testing(); }}; subtest writable_fails => sub { my $label = 'writable has custom label'; test_out( 'ok 1 - writable is writable' ); file_writable_ok( 'writable' ); test_out( "ok 2 - $label" ); file_writable_ok( 'writable', $label ); if( is_msys() or is_unix_superuser() ) { test_out( 'ok 3 - readable is writable' ); } else { test_out( 'not ok 3 - readable is writable' ); test_diag('file [readable] is not writable'); test_diag(" Failed test 'readable is writable'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+2) . "."); } file_writable_ok( 'readable' ); test_test(); done_testing(); }; subtest not_writable => sub { SKIP: { skip "Superuser has special privileges", 1, if is_unix_superuser(); skip "Not possible to make file unreadable on MSYS" if is_msys(); test_out( 'ok 1 - readable is not writable' ); test_out( 'not ok 2 - writable is not writable' ); test_diag('file [writable] is writable'); test_diag(" Failed test 'writable is not writable'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+2) . "."); file_not_writable_ok( 'readable' ); file_not_writable_ok( 'writable' ); test_test(); done_testing(); }}; subtest executable => sub { if (Test::File::_win32()) { test_out("ok 1 # skip file_executable_ok doesn't work on Windows"); test_out("ok 2 # skip file_executable_ok doesn't work on Windows"); test_out("ok 3 # skip file_executable_ok doesn't work on Windows"); } else { test_out("ok 1 - executable is executable"); test_out("ok 2 - executable really is executable"); test_out("not ok 3 - not_executable is executable"); test_diag("file [not_executable] is not executable"); test_diag(" Failed test 'not_executable is executable'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+4) . "."); } file_executable_ok( 'executable' ); file_executable_ok( 'executable', 'executable really is executable' ); file_executable_ok( 'not_executable' ); test_test(); done_testing(); }; subtest not_executable => sub { if (Test::File::_win32()) { test_out("ok 1 # skip file_not_executable_ok doesn't work on Windows"); test_out("ok 2 # skip file_not_executable_ok doesn't work on Windows"); test_out("ok 3 # skip file_not_executable_ok doesn't work on Windows"); } else { test_out("ok 1 - not_executable is not executable"); test_out("ok 2 - not_executable really is not executable"); test_out("not ok 3 - executable is not executable"); test_diag("file [executable] is executable"); test_diag(" Failed test 'executable is not executable'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+4) . "."); } file_not_executable_ok( 'not_executable' ); file_not_executable_ok( 'not_executable', 'not_executable really is not executable' ); file_not_executable_ok( 'executable' ); test_test(); done_testing(); }; subtest mode_is => sub { if (Test::File::_win32()) { test_out("ok 1 # skip file_mode_is doesn't work on Windows"); test_out("ok 2 # skip file_mode_is doesn't work on Windows"); test_out("ok 3 # skip file_mode_is doesn't work on Windows"); } else { test_out("ok 1 - executable mode is 0100"); test_out("ok 2 - executable mode really is 0100"); test_out("not ok 3 - executable mode is 0200"); test_diag("file [executable] mode is not 0200"); test_diag(" Failed test 'executable mode is 0200'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+4) . "."); } file_mode_is( 'executable', 0100 ); file_mode_is( 'executable', 0100, 'executable mode really is 0100' ); file_mode_is( 'executable', 0200 ); test_test(); done_testing(); }; subtest mode_has => sub { if (Test::File::_win32()) { test_out("ok 1 # skip file_mode_has doesn't work on Windows"); test_out("ok 2 # skip file_mode_has doesn't work on Windows"); test_out("ok 3 # skip file_mode_has doesn't work on Windows"); test_out("ok 4 # skip file_mode_has doesn't work on Windows" ); } else { test_out("ok 1 - executable mode has all bits of 0100"); test_out("ok 2 - executable mode really has all bits of 0100"); test_out("not ok 3 - executable mode has all bits of 0200"); test_diag("file [executable] mode is missing component 0200"); test_diag(" Failed test 'executable mode has all bits of 0200'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+8) . "."); test_out( "not ok 4 - 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__+5) . "."); } file_mode_has( 'executable', 0100 ); file_mode_has( 'executable', 0100, 'executable mode really has all bits of 0100'); file_mode_has( 'executable', 0200 ); file_mode_has( 'executable', 0111 ); test_test(); done_testing(); }; subtest mode_isnt => sub { if (Test::File::_win32) { test_out( "ok 1 # skip file_mode_isnt doesn't work on Windows" ); test_out( "ok 2 # skip file_mode_isnt doesn't work on Windows" ); test_out( "ok 3 # skip file_mode_isnt doesn't work on Windows" ); } else { test_out( "ok 1 - executable mode is not 0200" ); test_out( "ok 2 - executable mode really is not 0200" ); test_out( "not ok 3 - executable mode is not 0100" ); test_diag("file [executable] mode is 0100"); test_diag(" Failed test 'executable mode is not 0100'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+4) . "."); } file_mode_isnt( 'executable', 0200 ); file_mode_isnt( 'executable', 0200, 'executable mode really is not 0200' ); file_mode_isnt( 'executable', 0100 ); test_test(); done_testing(); }; subtest mode_hasnt => sub { if (Test::File::_win32()) { test_out( "ok 1 # skip file_mode_hasnt doesn't work on Windows" ); test_out( "ok 2 # skip file_mode_hasnt doesn't work on Windows" ); test_out( "ok 3 # skip file_mode_hasnt doesn't work on Windows" ); } else { test_out( "ok 1 - executable mode has no bits of 0200" ); test_out( "ok 2 - executable mode really has no bits of 0200" ); test_out( "not ok 3 - 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__+5) . "."); } file_mode_hasnt( 'executable', 0200 ); file_mode_hasnt( 'executable', 0200, 'executable mode really has no bits of 0200' ); file_mode_hasnt( 'executable', 0111 ); test_test(); done_testing(); }; subtest mode => sub { 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(); done_testing(); }; subtest mode_isnt => sub { 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(); done_testing(); }; subtest mode_writable => sub { my $s = Test::File::_win32() ? "# skip file_mode_is doesn't work on Windows" : "- writable mode is 0200"; test_out( "ok 1 $s" ); file_mode_is( 'writable', 0200 ); test_test(); done_testing(); }; subtest mode => sub { my $s = Test::File::_win32() ? "# skip file_mode_isnt doesn't work on Windows" : "- writable mode is not 0100"; test_out( "ok 1 $s" ); file_mode_isnt( 'writable', 0100 ); test_test(); done_testing(); }; done_testing(); Test-File-1.995/t/owner.t0000644000076500000240000001337414777047513014124 0ustar brianstaffuse 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_group_name ); 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' ); group_isnt( $filename, $other_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.995/xt/0000755000076500000240000000000014777047514012766 5ustar brianstaffTest-File-1.995/xt/citations.t0000644000076500000240000000063114777047513015147 0ustar brianstaffuse strict; use Test::More; my $file = 'CITATION.cff'; SKIP: { my $rc = eval { require YAML; YAML->VERSION('1.26'); 1 }; skip "Need YAML to test $file", 1 unless $rc; subtest citations => sub { ok( -e $file, "$file exists" ); my $data = eval { YAML::LoadFile( $file ) }; my $error = $@; ok( defined $data, "Loaded data from $file" ) or diag( "Error loading $file: $@" ); }; } done_testing; Test-File-1.995/xt/changes.t0000644000076500000240000000020314777047513014555 0ustar brianstaffuse Test::More; eval 'use Test::CPAN::Changes'; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; changes_ok(); Test-File-1.995/README.pod0000644000076500000240000001141614777047513013776 0ustar brianstaff=pod =encoding utf8 =for HTML =for HTML =for HTML =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 at L. 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: L If you find a problem, file a ticket in the L. There are also backup repositories hosted on other services. These reflect the state of the main repo and exist only for redundancy: =over 4 =item * L =item * L =item * L =back =head2 GitHub Attestations This distribution now uses L, which allow you to verify that the archive file you have was made from the official repo. You need a GitHub account and the L. # download the distro file from GitHub, MetaCPAN, or a CPAN mirror $ gh auth login ...follow instructions... $ gh attestation verify Test-File-1.23.tar.gz --owner briandfoy =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, briandfoy@pobox.com =cut Test-File-1.995/MANIFEST.SKIP0000644000076500000240000000214714777047513014234 0ustar brianstaff #!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$ \.icloud$ # 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 \.?appveyor.yml \.?releaserc \.lwpcookies \.github\b Test-.* \bMANIFEST\s\d \bChanges\s\d \.icloud$ \A\.github\b \.gitattributes\b Test-File-1.995/examples/0000755000076500000240000000000014777047514014151 5ustar brianstaffTest-File-1.995/examples/README0000644000076500000240000000010514777047513015024 0ustar brianstaffSee the tests in the t/ directory for examples until I add some more.Test-File-1.995/META.yml0000664000076500000240000000171214777047514013607 0ustar brianstaff--- abstract: 'test file attributes' author: - 'brian d foy ' build_requires: Test::Builder: '1.001006' Test::Builder::Tester: '1.04' Test::More: '1' version: '0.86' configure_requires: ExtUtils::MakeMaker: '6.64' File::Spec::Functions: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' keywords: - testing - file license: artistic_2 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 version: '1.995' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Test-File-1.995/lib/0000755000076500000240000000000014777047514013101 5ustar brianstaffTest-File-1.995/lib/Test/0000755000076500000240000000000014777047514014020 5ustar brianstaffTest-File-1.995/lib/Test/File.pm0000644000076500000240000013521514777047513015243 0ustar brianstaffpackage Test::File; use strict; use Carp qw(carp); use Exporter qw(import); use File::Spec; use Test::Builder; use XSLoader; our @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_writable_ok file_not_writeable_ok file_not_writable_ok file_executable_ok file_not_executable_ok file_mode_is file_mode_isnt file_mode_has file_mode_hasnt file_is_symlink_ok file_is_not_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 ); our $VERSION = '1.995'; XSLoader::load(__PACKAGE__, $VERSION) if $^O eq 'MSWin32'; 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 =over 4 =cut sub _is_plain_file { my $filename = _normalize( shift ); my $message = do { if( ! -e $filename ) { "does not exist" } elsif( ! -f _ ) { "is not a plain file" } elsif( -d _ ) { "is a directory" } else { () } }; if( $message ) { $Test->diag( "file [$filename] $message"); return 0; } return 1; } 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/ || $^O eq 'msys'; } # returns true if symlinks can't exist BEGIN { my $cannot_symlink; sub _no_symlinks_here { return $cannot_symlink if defined $cannot_symlink; $cannot_symlink = ! do { eval { symlink("",""); # symlink exist in perl _IsSymlinkCreationAllowed() # symlink is ok in current session } }; } sub _IsSymlinkCreationAllowed { if ($^O eq 'MSWin32') { # # Bare copy of Perl's Win32::IsSymlinkCreationAllowed but with Test::File::Win32 namespace instead of Win32 # my(undef, $major, $minor, $build) = Test::File::Win32::GetOSVersion(); # Vista was the first Windows version with symlink support return !!0 if $major < 6; # Since Windows 10 1703, enabling the developer mode allows to create # symlinks regardless of process privileges if ($major > 10 || ($major == 10 && ($minor > 0 || $build > 15063))) { return !!1 if Test::File::Win32::IsDeveloperModeEnabled(); } my $privs = Test::File::Win32::GetProcessPrivileges(); return !!0 unless $privs; # It doesn't matter if the permission is enabled or not, it just has to # exist. CreateSymbolicLink() will automatically enable it when needed. return exists $privs->{SeCreateSymbolicLinkPrivilege}; } 1; } =item has_symlinks Returns true is this module thinks that the current system supports symlinks. This is not a test function. It's something that tests can use to determine what it should expect or skip. =cut sub has_symlinks { ! _no_symlinks_here() } } # 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; } =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. Previously this tried to test any sort of file. Sometime in the future this will fail if the argument is not a plain file or is a directory. =cut sub file_empty_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is empty"; return $Test->ok( 0, $name ) unless _is_plain_file( $filename ); 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. Previously this tried to test any sort of file. Sometime in the future this will fail if the argument is not a plain file or is a directory. =cut sub file_not_empty_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is not empty"; return $Test->ok( 0, $name ) unless _is_plain_file( $filename ); 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. Previously this tried to test any sort of file. Sometime in the future this will fail if the argument is not a plain file or is a directory. =cut sub file_size_ok { my $filename = _normalize( shift ); my $expected = int shift; my $name = shift || "$filename has right size"; return $Test->ok( 0, $name ) unless _is_plain_file( $filename ); 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. Previously this tried to test any sort of file. Sometime in the future this will fail if the argument is not a plain file or is a directory. =cut sub file_max_size_ok { my $filename = _normalize( shift ); my $max = int shift; my $name = shift || "$filename is under $max bytes"; return $Test->ok( 0, $name ) unless _is_plain_file( $filename ); 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. Previously this tried to test any sort of file. Sometime in the future this will fail if the argument is not a plain file or is a directory. =cut sub file_min_size_ok { my $filename = _normalize( shift ); my $min = int shift; my $name = shift || "$filename is over $min bytes"; return $Test->ok( 0, $name ) unless _is_plain_file( $filename ); 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. Previously this tried to test any sort of file. Sometime in the future this will fail if the argument is not a plain file or is a directory. =cut sub _ENOFILE () { -1 } sub _ECANTOPEN () { -2 } sub _ENOTPLAIN () { -3 } sub _file_line_counter { my $filename = shift; return _ENOFILE unless -e $filename; return _ENOTPLAIN unless -f $filename; 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"; }; return $Test->ok( 0, $name ) unless _is_plain_file( $filename ); 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 eq _ENOTPLAIN ) { $Test->diag( "file [$filename] is not a plain file" ); $Test->ok( 0, $name ); } elsif( $got == _ECANTOPEN ) { $Test->diag( "file [$filename] could not be opened: \$! 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. Previously this tried to test any sort of file. Sometime in the future this will fail if the argument is not a plain file or is a directory. =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"; }; return $Test->ok( 0, $name ) unless _is_plain_file( $filename ); 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 eq _ENOTPLAIN ) { $Test->diag( "file [$filename] is not a plain file" ); $Test->ok( 0, $name ); } elsif( $got == _ECANTOPEN ) { $Test->diag( "file [$filename] could not be opened: \$! 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. Previously this tried to test any sort of file. Sometime in the future this will fail if the argument is not a plain file or is a directory. =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"; }; return $Test->ok( 0, $name ) unless _is_plain_file( $filename ); 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 eq _ENOTPLAIN ) { $Test->diag( "file [$filename] is not a plain file" ); $Test->ok( 0, $name ); } elsif( $got == _ECANTOPEN ) { $Test->diag( "file [$filename] could not be opened: \$! 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]}; return $Test->ok( 0, $name ) unless _is_plain_file( $filename ); 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( "file [$filename] could not be opened: \$! 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_writable_ok( FILENAME [, NAME ] ) =item file_writeable_ok( FILENAME [, NAME ] ) Ok if the file exists and is writable, not ok if the file does not exist or is not writable. The original name is C with that extra I. That still works but there's a function with the correct spelling too. =cut sub file_writeable_ok { carp "file_writeable_ok is now file_writable_ok"; &file_writable_ok; } sub file_writable_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is writable"; my $ok = -w $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "file [$filename] is not writable" ); $Test->ok(0, $name); } } =item file_not_writeable_ok( FILENAME [, NAME ] ) =item file_not_writable_ok( FILENAME [, NAME ] ) Ok if the file exists and is not writable, not ok if the file does not exist or is writable. The original name is C with that extra I. That still works but there's a function with the correct spelling too. =cut sub file_not_writeable_ok { carp "file_not_writeable_ok is now file_not_writable_ok"; &file_not_writable_ok; } sub file_not_writable_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is not writable"; my $ok = not -w $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("file [$filename] is writable"); $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. =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 file_is_not_symlink_ok( FILENAME [, NAME ] ) Ok if FILENAME is a not symlink. 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_not_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 not a symlink"; unless( -e $file ) { $Test->diag( "file [$file] does not exist" ); return $Test->ok(0, $name); } if( ! -l $file ) { $Test->ok(1, $name) } else { $Test->diag( "file [$file] is 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( "directory [$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 $arg = shift; # the name might be numeric (why would you do that?), so we need # to figure out which of several possibilities we have. And, 0 means # root, so we have to be very careful with the values. # maybe the argument is a UID. First, it has to be numeric. If it's # a UID, we'll get the same UID back. But, if we get back a value # that doesn't mean that we are done. There might be a name with # the same value. # # Don't use this value in comparisons! An undef could be turned # into zero! my $from_uid = (getpwuid($arg))[2] if $arg =~ /\A[0-9]+\z/; # Now try the argument as a name. If it's a name, then we'll get # back a UID. Maybe we get back nothing. my $from_nam = (getpwnam($arg))[2]; return do { # first case, we got back nothing from getpwnam but did get # something from getpwuid. The arg is not a name and is a # UID. if( defined $from_uid and not defined $from_nam ) { $arg } # second case, we got back nothing from getpwuid but did get # something from getpwnam. The arg is a name and is not a # UID. elsif( not defined $from_uid and defined $from_nam ) { $from_nam } # Now, what happens if neither are defined? The argument does # not correspond to a name or GID on the system. Since no such # user exists, we return undef. elsif( not defined $from_uid and not defined $from_nam ) { undef } # But what if they are both defined? The argument could represent # a UID and a name, and those could be different users! In this # case, we'll choose the original argument. That might be wrong, # so the best we can do is a warning. else { carp( "Found both a UID or name for <$arg>. Guessing the UID is <$arg>." ); $arg } }; } sub _get_gid { my $arg = shift; # the name might be numeric (why would you do that?), so we need # to figure out which of several possibilities we have. And, 0 means # root, so we have to be very careful with the values. # maybe the argument is a GID. First, it has to be numeric. If it's # a GID, we'll get the same GID back. But, if we get back a value # that doesn't mean that we are done. There might be a name with # the same value. # # Don't use this value in comparisons! An undef could be turned # into zero! my $from_gid = (getgrgid($arg))[2] if $arg =~ /\A[0-9]+\z/; # Now try the argument as a name. If it's a name, then we'll get # back a GID. Maybe we get back nothing. my $from_nam = (getgrnam($arg))[2]; return do { # first case, we got back nothing from getgrnam but did get # something from getpwuid. The arg is not a name and is a # GID. if( defined $from_gid and not defined $from_nam ) { $arg } # second case, we got back nothing from getgrgid but did get # something from getgrnam. The arg is a name and is not a # GID. elsif( not defined $from_gid and defined $from_nam ) { $from_nam } # Now, what happens if neither are defined? The argument does # not correspond to a name or GID on the system. Since no such # user exists, we return undef. elsif( not defined $from_gid and not defined $from_nam ) { undef } # But what if they are both defined? The argument could represent # a GID and a name, and those could be different users! In this # case, we'll choose the original argument. That might be wrong, # so the best we can do is a warning. else { carp( "Found both a GID or name for <$arg>. Guessing the GID is <$arg>." ); $arg; } }; } =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 = 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( "file [$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 greater 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( "file [$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( "file [$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( "file name not specified" ); return 0; } unless( -e $filename ) { $Test->diag( "file [$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 If you are using the new C stuff, see Test2::Tools::File (https://github.com/torbjorn/Test2-Tools-File). =head1 SOURCE AVAILABILITY This module is in Github: https://github.com/briandfoy/test-file =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. Torbjørn Lindahl is working on L and we're working together to align our interfaces. Jean-Damien Durand added bits to use Win32::IsSymlinkCreationAllowed, new since Win32 0.55. =head1 COPYRIGHT AND LICENSE Copyright © 2002-2025, brian d foy . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the Artistic License 2.0 =cut "The quick brown fox jumped over the lazy dog"; Test-File-1.995/Makefile.PL0000644000076500000240000000603114777047513014304 0ustar brianstaffpackage 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' => 'artistic_2', 'AUTHOR' => 'brian d foy ', 'CONFIGURE_REQUIRES' => { 'ExtUtils::MakeMaker' => '6.64', 'File::Spec::Functions' => '0', }, 'BUILD_REQUIRES' => { }, 'TEST_REQUIRES' => { 'Test::More' => '1', 'Test::Builder::Tester' => '1.04', 'Test::Builder' => '1.001006', 'version' => '0.86', }, 'PREREQ_PM' => { }, 'META_MERGE' => { 'meta-spec' => { version => 2 }, keywords => ['testing','file'], resources => { repository => { type => 'git', url => $github, 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-*| }, test => { TESTS => 't/*.t t/*/*.t' }, ); sub MY::dynamic { # # No dynamic library unless on MSWin32 # package MY; my ($self) = @_; $^O eq 'MSWin32' ? $self->SUPER::dynamic : ''; } 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 ); } no warnings; __PACKAGE__; Test-File-1.995/INSTALL.SKIP0000644000076500000240000000015614777047513014132 0ustar brianstaffREADME\.pod README.* # things that might be in local directories after fooling # around with them \.DS_Store Test-File-1.995/File.xs0000644000076500000240000001255014777047513013570 0ustar brianstaff/* Bare copy of a part of Win32.xs */ #define WIN32_LEAN_AND_MEAN #define _WIN32_WINNT 0x0500 #include #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define GETPROC(fn) pfn##fn = (PFN##fn)GetProcAddress(module, #fn) typedef LONG (WINAPI *PFNRegGetValueA)(HKEY, LPCSTR, LPCSTR, DWORD, LPDWORD, PVOID, LPDWORD); /* Use explicit struct definition because wSuiteMask and * wProductType are not defined in the VC++ 6.0 headers. * WORD type has been replaced by unsigned short because * WORD is already used by Perl itself. */ struct g_osver_t { DWORD dwOSVersionInfoSize; DWORD dwMajorVersion; DWORD dwMinorVersion; DWORD dwBuildNumber; DWORD dwPlatformId; CHAR szCSDVersion[128]; unsigned short wServicePackMajor; unsigned short wServicePackMinor; unsigned short wSuiteMask; BYTE wProductType; BYTE wReserved; } g_osver = {0, 0, 0, 0, 0, "", 0, 0, 0, 0, 0}; BOOL g_osver_ex = TRUE; XS(w32_GetOSVersion) { dXSARGS; if (items) Perl_croak(aTHX_ "usage: Win32::GetOSVersion()"); if (GIMME_V == G_SCALAR) { XSRETURN_IV(g_osver.dwPlatformId); } XPUSHs(sv_2mortal(newSVpvn(g_osver.szCSDVersion, strlen(g_osver.szCSDVersion)))); XPUSHs(sv_2mortal(newSViv(g_osver.dwMajorVersion))); XPUSHs(sv_2mortal(newSViv(g_osver.dwMinorVersion))); XPUSHs(sv_2mortal(newSViv(g_osver.dwBuildNumber))); XPUSHs(sv_2mortal(newSViv(g_osver.dwPlatformId))); if (g_osver_ex) { XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMajor))); XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMinor))); XPUSHs(sv_2mortal(newSViv(g_osver.wSuiteMask))); XPUSHs(sv_2mortal(newSViv(g_osver.wProductType))); } PUTBACK; } XS(w32_GetProcessPrivileges) { dXSARGS; BOOL ret; HV *priv_hv; HANDLE proc_handle, token; char *priv_name = NULL; TOKEN_PRIVILEGES *privs = NULL; DWORD i, pid, priv_name_len = 100, privs_len = 300; if (items > 1) Perl_croak(aTHX_ "usage: Win32::GetProcessPrivileges([$pid])"); if (items == 0) { EXTEND(SP, 1); pid = GetCurrentProcessId(); } else { pid = (DWORD)SvUV(ST(0)); } proc_handle = OpenProcess(PROCESS_QUERY_INFORMATION, FALSE, pid); if (!proc_handle) XSRETURN_NO; ret = OpenProcessToken(proc_handle, TOKEN_QUERY, &token); CloseHandle(proc_handle); if (!ret) XSRETURN_NO; do { Renewc(privs, privs_len, char, TOKEN_PRIVILEGES); ret = GetTokenInformation( token, TokenPrivileges, privs, privs_len, &privs_len ); } while (!ret && GetLastError() == ERROR_INSUFFICIENT_BUFFER); CloseHandle(token); if (!ret) { Safefree(privs); XSRETURN_NO; } priv_hv = newHV(); New(0, priv_name, priv_name_len, char); for (i = 0; i < privs->PrivilegeCount; ++i) { DWORD ret_len = 0; LUID_AND_ATTRIBUTES *priv = &privs->Privileges[i]; BOOL is_enabled = !!(priv->Attributes & SE_PRIVILEGE_ENABLED); if (priv->Attributes & SE_PRIVILEGE_REMOVED) continue; do { ret_len = priv_name_len; ret = LookupPrivilegeNameA( NULL, &priv->Luid, priv_name, &ret_len ); if (ret_len > priv_name_len) { priv_name_len = ret_len + 1; Renew(priv_name, priv_name_len, char); } } while (!ret && GetLastError() == ERROR_INSUFFICIENT_BUFFER); if (!ret) { SvREFCNT_dec((SV*)priv_hv); Safefree(privs); Safefree(priv_name); XSRETURN_NO; } hv_store(priv_hv, priv_name, ret_len, newSViv(is_enabled), 0); } Safefree(privs); Safefree(priv_name); ST(0) = sv_2mortal(newRV_noinc((SV*)priv_hv)); XSRETURN(1); } XS(w32_IsDeveloperModeEnabled) { dXSARGS; LONG status; DWORD val, val_size = sizeof(val); PFNRegGetValueA pfnRegGetValueA; HMODULE module; if (items) Perl_croak(aTHX_ "usage: Win32::IsDeveloperModeEnabled()"); EXTEND(SP, 1); /* developer mode was introduced in Windows 10 */ if (g_osver.dwMajorVersion < 10) XSRETURN_NO; module = GetModuleHandleA("advapi32.dll"); GETPROC(RegGetValueA); if (!pfnRegGetValueA) XSRETURN_NO; status = pfnRegGetValueA( HKEY_LOCAL_MACHINE, "SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\AppModelUnlock", "AllowDevelopmentWithoutDevLicense", RRF_RT_REG_DWORD | KEY_WOW64_64KEY, NULL, &val, &val_size ); if (status == ERROR_SUCCESS && val == 1) XSRETURN_YES; XSRETURN_NO; } MODULE = Test::File PACKAGE = Test::File::Win32 PROTOTYPES: DISABLE BOOT: { const char *file = __FILE__; if (g_osver.dwOSVersionInfoSize == 0) { g_osver.dwOSVersionInfoSize = sizeof(g_osver); if (!GetVersionExA((OSVERSIONINFOA*)&g_osver)) { g_osver_ex = FALSE; g_osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); GetVersionExA((OSVERSIONINFOA*)&g_osver); } } newXS("Test::File::Win32::GetOSVersion", w32_GetOSVersion, file); newXS("Test::File::Win32::GetProcessPrivileges", w32_GetProcessPrivileges, file); newXS("Test::File::Win32::IsDeveloperModeEnabled", w32_IsDeveloperModeEnabled, file); XSRETURN_YES; } Test-File-1.995/SECURITY.md0000644000076500000240000000230314777047513014121 0ustar brianstaff# Security Policy for Test::File ## Reporting security issues **Do not report security problems on public forums or in repository issues.** Privately report vulnerabilities to the maintainers listed at the end of this document. Include as many details as possible to reproduce the issue, including code samples or test cases. Check that your report does not expose any of your sensitive data, such as passwords, tokens, or other secrets. You do not need to have a solution or fix. Depending on the issue, CPANSec may be notified. Depending on the issue, CPANSec may be notified. You can also privately report issues to the CPAN Security Group (CPANSec) . This is especially important if you think a vulnerability is being actively exploited. CPANSec may report the issue to the relevant authorities. See [Report a Security Issue](https://security.metacpan.org/docs/report.html). ## Response to reports The maintainers aim to respond to all reports within one day, but this may be affected by life and other things that happen to people who maintain open source code. A new release will be provided as soon as possible. ## Maintainers * brian d foy, Test-File-1.995/META.json0000664000076500000240000000331414777047514013757 0ustar brianstaff{ "abstract" : "test file attributes", "author" : [ "brian d foy " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "keywords" : [ "testing", "file" ], "license" : [ "artistic_2" ], "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" : "1", "version" : "0.86" } } }, "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", "web" : "https://github.com/briandfoy/test-file" } }, "version" : "1.995", "x_serialization_backend" : "JSON::PP version 4.16" }