"Fossies" - the Fresh Open Source Software Archive

Member "mod_perl-2.0.11/t/lib/TestAPRlib/bucket.pm" (5 Oct 2019, 6152 Bytes) of package /linux/www/apache_httpd_modules/mod_perl-2.0.11.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the last Fossies "Diffs" side-by-side code changes report for "bucket.pm": 2.0.8_vs_2.0.9.

    1 # please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
    2 package TestAPRlib::bucket;
    3 
    4 # a mix of APR::Bucket and APR::BucketType tests
    5 
    6 use strict;
    7 use warnings FATAL => 'all';
    8 
    9 use Apache::Test;
   10 use Apache::TestUtil;
   11 use TestCommon::Utils;
   12 
   13 use APR::Pool ();
   14 use APR::Bucket ();
   15 use APR::BucketAlloc ();
   16 use APR::BucketType ();
   17 use APR::Table ();
   18 
   19 use APR::Const -compile => 'SUCCESS';
   20 
   21 sub num_of_tests {
   22     return 21;
   23 }
   24 
   25 sub test {
   26 
   27     my $pool = APR::Pool->new();
   28     my $ba   = APR::BucketAlloc->new($pool);
   29 
   30     # new: basic
   31     {
   32         my $data = "foobar";
   33         my $b = APR::Bucket->new($ba, $data);
   34 
   35         t_debug('$b is defined');
   36         ok defined $b;
   37 
   38         t_debug('$b ISA APR::Bucket object');
   39         ok $b->isa('APR::Bucket');
   40 
   41         my $type = $b->type;
   42         ok t_cmp $type->name, 'mod_perl SV bucket', "type";
   43 
   44         ok t_cmp $b->length, length($data), "modperl b->length";
   45     }
   46 
   47     # new: offset
   48     {
   49         my $data   = "foobartar";
   50         my $offset = 3;
   51         my $real = substr $data, $offset;
   52         my $b = APR::Bucket->new($ba, $data, $offset);
   53         my $rlen = $b->read(my $read);
   54         ok t_cmp $read, $real, 'new($data, $offset)/buffer';
   55         ok t_cmp $rlen, length($read), 'new($data, $offset)/len';
   56         ok t_cmp $b->start, $offset, 'offset';
   57 
   58     }
   59 
   60     # new: offset+len
   61     {
   62         my $data   = "foobartar";
   63         my $offset = 3;
   64         my $len    = 3;
   65         my $real = substr $data, $offset, $len;
   66         my $b = APR::Bucket->new($ba, $data, $offset, $len);
   67         my $rlen = $b->read(my $read);
   68         ok t_cmp $read, $real, 'new($data, $offset, $len)/buffer';
   69         ok t_cmp $rlen, length($read), 'new($data, $offse, $lent)/len';
   70     }
   71 
   72     # new: offset+ too big len
   73     {
   74         my $data   = "foobartar";
   75         my $offset = 3;
   76         my $len    = 10;
   77         my $real = substr $data, $offset, $len;
   78         my $b = eval { APR::Bucket->new($ba, $data, $offset, $len) };
   79         ok t_cmp $@,
   80             qr/the length argument can't be bigger than the total/,
   81             'new($data, $offset, $len_too_big)';
   82     }
   83 
   84     # modification of the source variable, affects the data
   85     # inside the bucket
   86     {
   87         my $data = "A" x 10;
   88         my $orig = $data;
   89         my $b = APR::Bucket->new($ba, $data);
   90         $data =~ s/^..../BBBB/;
   91         $b->read(my $read);
   92         ok t_cmp $read, $data,
   93             "data inside the bucket should get affected by " .
   94             "the changes to the Perl variable it's created from";
   95     }
   96 
   97 
   98     # APR::Bucket->new() with the argument PADTMP (which happens when
   99     # some function is re-entered) and the same SV is passed to
  100     # different buckets, which must be detected and copied away.
  101     {
  102         my @buckets  = ();
  103         my @data     = qw(ABCD EF);
  104         my @received = ();
  105         for my $str (@data) {
  106             my $b = func($ba, $str);
  107             push @buckets, $b;
  108         }
  109 
  110         # the creating of buckets and reading from them is done
  111         # separately on purpose
  112         for my $b (@buckets) {
  113             $b->read(my $out);
  114             push @received, $out;
  115         }
  116 
  117         # here we used to get: two pv: "ef\0d"\0, "ef"\0, as you can see
  118         # the first bucket had corrupted data.
  119         my @expected = map { lc } @data;
  120         ok t_cmp \@received, \@expected, "new(PADTMP SV)";
  121 
  122         # this function will pass the same SV to new(), causing two
  123         # buckets point to the same SV, and having the latest bucket's
  124         # data override the previous one
  125         sub func {
  126             my $ba = shift;
  127             my $data = shift;
  128             return APR::Bucket->new($ba, lc $data);
  129         }
  130 
  131     }
  132 
  133     # read data is tainted
  134     {
  135         my $data = "xxx";
  136         my $b = APR::Bucket->new($ba, $data);
  137         $b->read(my $read);
  138         ok t_cmp $read, $data, 'new($data)';
  139         ok TestCommon::Utils::is_tainted($read);
  140     }
  141 
  142     # remove/destroy
  143     {
  144         my $b = APR::Bucket->new($ba, "aaa");
  145         # remove $b when it's not attached to anything (not sure if
  146         # that should be an error)
  147         $b->remove;
  148         ok 1;
  149 
  150         # a dangling bucket needs to be destroyed
  151         $b->destroy;
  152         ok 1;
  153 
  154         # real remove from bb is tested in many other filter tests
  155     }
  156 
  157     # setaside
  158     {
  159         my $data = "A" x 10;
  160         my $expected = $data;
  161         my $b = APR::Bucket->new($ba, $data);
  162         my $status = $b->setaside($pool);
  163         ok t_cmp $status, APR::Const::SUCCESS, "setaside status";
  164         $data =~ s/^..../BBBB/;
  165         $b->read(my $read);
  166         ok t_cmp $read, $expected,
  167             "data inside the setaside bucket is unaffected by " .
  168             "changes to the Perl variable it's created from";
  169         $b->destroy;
  170     }
  171 
  172     # alloc_create on out-of-scope pools
  173     {
  174         # later may move that into a dedicated bucket_alloc test
  175         my $ba = APR::BucketAlloc->new(APR::Pool->new);
  176         # here if the pool is gone of scope destroy() will segfault
  177         $ba->destroy;
  178         ok 1;
  179     }
  180 
  181     # setaside on out-of-scope pools
  182     {
  183         # note that at the moment APR internally handles the situation
  184         # when the pool goes out of scope, so modperl doesn't need to do
  185         # any special handling of the pool object passed to setaside()
  186         # to insure that it survives as long as $b is alive
  187         #
  188         # to make sure that this doesn't change internally in APR, the
  189         # sub-test remains here
  190         my $data = "A" x 10;
  191         my $orig = $data;
  192         my $b = APR::Bucket->new($ba, $data);
  193         my $status = $b->setaside(APR::Pool->new);
  194         ok t_cmp $status, APR::Const::SUCCESS, "setaside status";
  195 
  196         # try to overwrite the temp pool data
  197         my $table = APR::Table::make(APR::Pool->new, 50);
  198         $table->set($_ => $_) for 'aa'..'za';
  199 
  200         # now test that we are still OK
  201         $b->read(my $read);
  202         ok t_cmp $read, $data,
  203             "data inside the setaside bucket is not corrupted";
  204         $b->destroy;
  205     }
  206 
  207     $ba->destroy;
  208 }
  209 
  210 1;
  211