plvltest

harvest是一个下载html网页得机器人

#! /usr/bin/perl -w

#=================================================================================================
# Test cases of Villa for Perl
#                                                       Copyright (C) 2000-2003 Mikio Hirabayashi
# This file is part of QDBM, Quick Database Manager.
# QDBM is free software; you can redistribute it and/or modify it under the terms of the GNU
# Lesser General Public License as published by the Free Software Foundation; either version
# 2.1 of the License or any later version.  QDBM is distributed in the hope that it will be
# useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more
# details.
# You should have received a copy of the GNU Lesser General Public License along with QDBM; if
# not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307 USA.
#=================================================================================================


use strict;
use warnings;
use ExtUtils::testlib;
use Villa;


# main routine
sub main {
    my($rv);
    (scalar(@ARGV) >= 1) || usage();
    if($ARGV[0] eq "write"){
        $rv = runwrite();
    } elsif($ARGV[0] eq "read"){
        $rv = runread();
    } elsif($ARGV[0] eq "tie"){
        $rv = runtie();
    } else {
        usage();
    }
    return $rv;
}


# print the usage and exit
sub usage {
    printf(STDERR "$0: test cases for Villa for Perl\n");
    printf(STDERR "\n");
    printf(STDERR "usage:\n");
    printf(STDERR "  $0 write name rnum bnum\n");
    printf(STDERR "  $0 read name\n");
    printf(STDERR "  $0 tie name\n");
    exit(1);
}


# parse arguments of write command
sub runwrite {
    my($name, $rnum, $i, $rv);
    for($i = 1; $i < scalar(@ARGV); $i++){
        if(!defined($name) && $ARGV[$i] =~ m/^-/){
            usage();
        } elsif(!defined($name)){
            $name = $ARGV[$i];
        } elsif(!defined($rnum)){
            $rnum = $ARGV[$i];
        } else {
            usage();
        }
    }
    (defined($name) && defined($rnum)) || usage();
    ($name && $rnum > 0) || usage();
    $rv = dowrite($name, $rnum);
    return $rv;
}


# parse arguments of read command
sub runread {
    my($name, $i, $rv);
    for($i = 1; $i < scalar(@ARGV); $i++){
        if(!defined($name) && $ARGV[$i] =~ m/^-/){
            usage();
        } elsif(!defined($name)){
            $name = $ARGV[$i];
        } else {
            usage();
        }
    }
    (defined($name)) || usage();
    ($name) || usage();
    $rv = doread($name);
    return $rv;
}


# parse arguments of tie command
sub runtie {
    my($name, $i, $rv);
    for($i = 1; $i < scalar(@ARGV); $i++){
        if(!defined($name) && $ARGV[$i] =~ m/^-/){
            usage();
        } elsif(!defined($name)){
            $name = $ARGV[$i];
        } else {
            usage();
        }
    }
    (defined($name)) || usage();
    ($name) || usage();
    $rv = dotie($name);
    return $rv;
}


# perform write command
sub dowrite {
    my($name, $rnum) = @_;
    my($i, $villa, $buf, $err);
    printf("<Writing Test>\n  name=$name  rnum=$rnum\n\n");
    # open a database
    if(!($villa = new Villa($name, Villa::OWRITER | Villa::OCREAT | Villa::OTRUNC))){
        printf(STDERR "$0: $name: open error: $Villa::errmsg\n");
        return 1;
    }
    # loop for each record
    $err = 0;
    $| = 1;
    for($i = 1; $i <= $rnum; $i++){
        $buf = sprintf("%08d", $i);
        # store a record
        if(!$villa->put($buf, $buf, Villa::DKEEP)){
            printf(STDERR "$0: $name: put error: $Villa::errmsg\n");
            $err = 1;
            last;
        }
        # print progression
        if($rnum > 250 && $i % ($rnum / 250) == 0){
            print('.');
            if($i == $rnum || $i % ($rnum / 10) == 0){
                printf(" (%08d)\n", $i);
            }
        }
    }
    # close the database
    if(!$villa->close()){
        printf(STDERR "$0: $name: close error: $Villa::errmsg\n");
        return 1;
    }
    ($err) || printf("ok\n\n");
    return $err ? 1 : 0;
}


# perform read command
sub doread {
    my($name) = @_;
    my($i, $villa, $rnum, $buf, $err);
    printf("<Reading Test>\n  name=$name\n\n");
    # open a database
    if(!($villa = new Villa($name))){
        printf(STDERR "$0: $name: open error: $Villa::errmsg\n");
        return 1;
    }
    # get the number of records
    $rnum = $villa->rnum();
    # loop for each record
    $err = 0;
    $| = 1;
    for($i = 1; $i <= $rnum; $i++){
        $buf = sprintf("%08d", $i);
        # store a record
        if(!$villa->get($buf)){
            printf(STDERR "$0: $name: get error: $Villa::errmsg\n");
            $err = 1;
            last;
        }
        # print progression
        if($rnum > 250 && $i % ($rnum / 250) == 0){
            print('.');
            if($i == $rnum || $i % ($rnum / 10) == 0){
                printf(" (%08d)\n", $i);
            }
        }
    }
    # close the database
    if(!$villa->close()){
        printf(STDERR "$0: $name: close error: $Villa::errmsg\n");
        return 1;
    }
    ($err) || printf("ok\n\n");
    return $err ? 1 : 0;
}


# perform tie command
sub dotie {
    my($name) = @_;
    my($LOOPNUM) = 100;
    my($i, $villa, $rnum, %hash, $buf, $key, $val);
    printf("<Tying Test>\n  name=$name\n\n");
    $| = 1;
    # open the database
    printf("Creating a database with tied hash ... ");
    if(!($villa = tie(%hash, "Villa", $name,
                      Villa::OWRITER | Villa::OCREAT | Villa::OTRUNC))){
        printf(STDERR "$0: $name: open error: $Villa::errmsg\n");
        return 1;
    }
    printf("ok\n");
    # store records
    printf("Storing records into tied hash ... ");
    for($i = 1; $i <= $LOOPNUM; $i++){
        $buf = sprintf("%08d", $i);
        if(!($hash{$buf} = $buf)){
            printf(STDERR "$0: $name: store error: $Villa::errmsg\n");
            return 1;
        }
    }
    printf("ok\n");
    # retrieve records
    printf("Retrieving records in tied hash ... ");
    for($i = 1; $i <= $LOOPNUM; $i++){
        $buf = sprintf("%08d", $i);
        if(!$hash{$buf}){
            printf(STDERR "$0: $name: fetch error: $Villa::errmsg\n");
            return 1;
        }
    }
    printf("ok\n");
    # traverse records
    printf("Traversing records in tied hash ... ");
    $i = 0;
    while(($key, $val) = each(%hash)){
        if($key ne $val){
            printf(STDERR "$0: $name: each error: $Villa::errmsg\n");
            return 1;
        }
        $i++;
    }
    if($i != $LOOPNUM){
        printf(STDERR "$0: $name: each error: $Villa::errmsg\n");
        return 1;
    }
    printf("ok\n");
    # delete a record
    printf("Deleting a record in tied hash ... ");
    $buf = sprintf("%08d", $LOOPNUM / 2);
    if(!(delete $hash{$buf}) || scalar(keys(%hash)) != $LOOPNUM - 1){
        printf(STDERR "$0: $name: delete error: $Villa::errmsg\n");
        return 1;
    }
    printf("ok\n");
    # clear the hash
    printf("Clear a record in tied hash ... ");
    %hash = ();
    if(scalar(keys(%hash)) != 0){
        printf(STDERR "$0: $name: clear error: $Villa::errmsg\n");
        return 1;
    }
    printf("ok\n");
    # test filters
    printf("Testing filters ... ");
    $villa->filter_store_key(sub { s/$/\0/; });
    $villa->filter_store_value(sub { s/$/\0/; });
    $villa->filter_fetch_key(sub { s/\0$//; });
    $villa->filter_fetch_value(sub { s/\0$//; });
    $hash{"tako"} = "ika";
    if(!exists($hash{"tako"}) || scalar(keys(%hash)) != 1 || scalar(values(%hash)) != 1 ||
       $hash{"tako"} ne "ika" || !delete($hash{"tako"})){
        printf(STDERR "$0: $name: filter error: $Villa::errmsg\n");
        return 1;
    }
    printf("ok\n");
    # close the database
    printf("Closing the tied hash ... ");
    $villa = undef();
    untie(%hash);
    printf("ok\n");
    printf("all ok\n\n");
    return 0;
}



$0 =~ s/.*\///;
exit(main());                            # execute main


# END OF FILE