The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

JDEGUEST / Apache2-SSI-v0.2.12 / t / 70.file.t 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110

              
#!/usr/local/bin/perl
BEGIN
{
    use strict;
    use warnings;
    use Test::More qw( no_plan );
    use lib './lib';
    use vars qw( $DEBUG );
    use_ok( 'Apache2::SSI::File' ) || BAIL_OUT( "Unable to load Apache2::SSI::File" );
    use_ok( 'URI::file' ) || BAIL_OUT( 'Unable to load URI::file' );
    use File::Spec ();
    use constant HAS_APACHE_TEST => $ENV{HAS_APACHE_TEST};
    if( HAS_APACHE_TEST )
    {
        require_ok( 'Apache::Test' ) || BAIL_OUT( "Unable to load Apache::Test" );
        use_ok( 'Apache::TestUtil' ) || BAIL_OUT( "Unable to load Apache::TestUtil" );
        use_ok( 'Apache::TestRequest' ) || BAIL_OUT( "Unable to load Apache::TestRequest" );
        use_ok( 'Apache2::Const', '-compile', qw( :common :http ) ) || BAIL_OUT( "Unable to load Apache2::Cons" );
    }
    our $DEBUG = exists( $ENV{AUTHOR_TESTING} ) ? $ENV{AUTHOR_TESTING} : 0;
};
use strict;
use warnings;
my $file = './ssi/include.cgi';
my $dir  = URI::file->new_abs( './t/htdocs' )->file( $^O );
diag( "Base directory is '$dir'" ) if( $DEBUG );
my $f = Apache2::SSI::File->new( $file, base_dir => './t/htdocs', debug => $DEBUG );
isa_ok( $f, 'Apache2::SSI::File' );
my $failed;
{
    no warnings 'Apache2::SSI::Finfo';
    $failed = Apache2::SSI::File->new( './not-existing.txt', debug => $DEBUG );
}
ok( defined( $failed ), 'Non-existing file object' );
ok( $failed->code == 404, 'Non-existing file code' );
ok( $failed->finfo->filetype == Apache2::SSI::Finfo::FILETYPE_NOFILE, 'Non-existing file type' );
isa_ok( $failed, 'Apache2::SSI::File' );
diag( "Expecting ", File::Spec->catdir( $dir, URI::file->new( '/ssi/include.cgi' )->file( $^O ) ) ) if( $DEBUG );
ok( $f->filename eq File::Spec->catdir( $dir, URI::file->new( '/ssi/include.cgi' )->file( $^O ) ), 'filename' );
ok( $f->code == 200, 'code' );
my $f2 = $f->clone;
{
    no warnings 'Apache2::SSI::File';
    $f2->filename( "${dir}/ssi/../ssi/plop.pl" );
}
diag( "Filename is: ", $f2->filename, " and I am expecting ", File::Spec->catdir( $dir, URI::file->new( '/ssi/plop.pl' )->file( $^O ) ) ) if( $DEBUG );
ok( $f2->filename eq File::Spec->catdir( $dir, URI::file->new( '/ssi/plop.pl' )->file( $^O ) ), 'filename' );
ok( $f2->code == 404, 'code failed' );
# Access to finfo
my $finfo = $f->finfo;
diag( "File ", File::Spec->catdir( $dir, URI::file->new( "/${file}" )->file( $^O ) ), " mode is: '", ( (CORE::stat( File::Spec->catpath( $dir, URI::file->new( "/${file}" )->file( $^O ) ) ))[2] & 07777 ), "' vs finfo one: '", $f->finfo->mode, "'" ) if( $DEBUG );
ok( ( (CORE::stat( File::Spec->catdir( $dir, URI::file->new( "/${file}" )->file( $^O ) ) ))[2] & 07777 ) eq $f->finfo->mode, 'finfo' );
ok( $f->finfo->is_file, 'finfo is_file' );
ok( $f->parent->filename eq File::Spec->catdir( $dir, URI::file->new( '/ssi' )->file( $^O ) ), 'parent' );
SKIP:
{
    my $tests = [
        'Apache2::SSI::File object',
        'Non-existing file object',
        'Non-existing file code',
        'Non-existing file type',
        'filename',
        'updated bad filename',
        'updated bad filename code',
        'updated bad filename filetype',
        'finfo',
        'finfo is_file',
        'parent',
    ];
    if( HAS_APACHE_TEST )
    {
        for( my $i = 0; $i < scalar( @$tests ); $i++ )
        {
            my( $ct, $resp ) = &make_request( sprintf( '/tests/test%02d', $i + 20 ) );
            ok( $ct->[0] eq 'ok', sprintf( '%s with Apache test No %d', $tests->[$i], ( $i + 1 ) ) );
            if( $ct->[0] ne 'ok' && scalar( @$ct ) > 1 )
            {
                diag( "Test No $i failed with returned code ", $resp->code, ": ", join( "\n", @$ct[1..$#$ct] ) );
            }
        }
    }
    else
    {
        skip( "Apache mod_perl is not enabled, skipping.", scalar( @$tests ) );
    }
};
sub make_request
{
    my $uri = shift( @_ );
    my $resp = GET( $uri );
    my $result = [split( /\n/, Encode::decode( 'utf8', $resp->content ) )];
    return( wantarray() ? ( $result, $resp ) : $result );
}