view release on metacpan or  search on metacpan

CachingProxy.pm  view on Meta::CPAN

    }

    else {
        die "as of version 1.6, url_locking_dir is a required option.";
    }

    my $cache = $this->{cache_object};
    if( $cache->exists($CK) and $cache->exists("$CK.hdr") ) { our $VAR1;
        my $res = eval $cache->get( "$CK.hdr" ); die "problem finding cache entry\n" if $@;

        unless( $this->{ignore_last_modified} ) {
            if( my $lm = $res->header('last_modified') ) {
                my $_lm = eval { $this->{ua}->head($URL)->header('last_modified') };

                # $lm = "hehe, random failure time" if (int rand(7)) == 0;

                if( $_lm and $lm ne $_lm ) {
                    warn "[DEBUG] last_modified differs ($lm vs $_lm), forcing cache miss\n" if $this->{debug};
                    goto FORCE_CACHE_MISS;
                }
            }
        }

        my $start = $this->my_copy_hdr($res, "cache hit");

        # XXX: is it the right thing to do to close the lockfile here?
        # Probably.  At this point, we should have the whole file, and we sure
        # don't mind serving similtaneous requests, right?

        close $lockfile_fh;

        ###

        my $fh = $cache->handle( $CK, "<" ) or die "problem finding cache entry\n";
        my $buf;
        BUF: while( read $fh, $buf, 4096 ) {
            if( $start > 0 ) {
                if( $start > length $buf ) {
                    $start -= length $buf;
                    next BUF;

                } else {
                    substr $buf, 0, $start, "";
                    $start = 0;
                }
            }
            print $buf;
        }
        close $fh;

    } else {
        FORCE_CACHE_MISS:
        my $expire = $this->{default_expire};
           $expire = $this->{index_expire} if $pinfo =~ $this->{index_regexp};

        $cache->set($CK, 1, $expire ); # doesn't seem like we should have to do this, but apparently we do

        warn "[DEBUG] getting $URL\n" if $this->{debug};

        my $fh       = $cache->handle( $CK, ">", $expire );
        my $request  = HTTP::Request->new(GET => $URL);

        my $announced_header;
        my $response = $this->{ua}->request($request, sub {
            my $chunk = shift;

            unless( $announced_header ) {
                my $res = shift;
                $announced_header = 1;
                $this->my_copy_hdr($res, "cache miss");
            }

            print $fh $chunk;
            print     $chunk;
        });
        close $fh;

        unless( $response->is_success ) {
            my $my_fail = "FAIL: " . $response->status_line . "\n";
            $cache->set($CK => $my_fail, $expire);
            $response->header(content_length=>length $my_fail); # fix content length so we don't lie to clients

            $this->my_copy_hdr($response, "cache miss [fail]");
            print $my_fail;
        }

        warn "[DEBUG] setting $CK\n" if $this->{debug};
        $cache->set("$CK.hdr", Dumper($response), $expire);

        # if there was an error (which we don't know until ex post facto), go back and fix the expiry
        if( defined $this->{error_expire} and not $response->is_success ) {
            $cache->set_expiry( $CK       => $this->{error_expire} );
            $cache->set_expiry( "$CK.hdr" => $this->{error_expire} );
        }
    }
}
# }}}

# {{{ sub my_copy_hdr
sub my_copy_hdr {
    my ($this, $res, $hit) = @_;
    my $cgi = $this->{cgi};

    my $status = $res->status_line;
    warn "[DEBUG] cache status: $hit; status: $status\n" if $this->{debug};

    my %more_headers = (qw(accept_ranges bytes));

    for(qw(content_length), $this->{ignore_last_modified} ? ():(qw(last_modified))) {
        my $v = $res->header($_);

        if( $v ) {
            my $k = lc $_;
               $k =~ s/-/_/g;

            $more_headers{$k} = $v;
        }
    }

    my $start = 0;