testrun.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

# been copied and the old dir could be still there, but that's not
# the one that we work in
sub detect_relocation {
    my($self, $cur_top_dir) = @_;

    my $config_file = catfile qw(t conf apache_test_config.pm);
    return unless -e $config_file;

    my %inc = %INC;
    eval { require "$config_file" };
    %INC = %inc; # be stealth
    warn($@), return if $@;

    my $cfg = 'apache_test_config'->new;

    # if the top_dir from saved config doesn't match the current
    # top_dir, that means that the whole project was relocated to a
    # different directory, w/o running t/TEST -clean first (in each
    # directory with a test suite)
    my $cfg_top_dir = $cfg->{vars}->{top_dir};
    return unless $cfg_top_dir;
    return if $cfg_top_dir eq $cur_top_dir;

    # if that's the case silently fixup the saved config to use the
    # new paths, and force a complete cleanup. if we don't fixup the
    # config files, the cleanup process won't be able to locate files
    # to delete and re-configuration will fail
    {
        # in place editing
        local @ARGV = $config_file;
        local $^I = ".bak";  # Win32 needs a backup
        while (<>) {
            s{$cfg_top_dir}{$cur_top_dir}g;
            print;
        }
        unlink $config_file . $^I;
    }

    my $cleanup_cmd = "$^X $0 -clean";
    warning "cleaning up the old config";
    # XXX: do we care to check success?
    system $cleanup_cmd;

    # XXX: I tried hard to accomplish that w/o starting a new process,
    # but too many things get on the way, so for now just keep it as an
    # external process, as it's absolutely transparent to the normal
    # app-run
}

my @oh = qw(jeez golly gosh darn shucks dangit rats nuts dangnabit crap);
sub oh {
    $oh[ rand scalar @oh ];
}

#e.g. t/core or t/core.12499
my $core_pat = '^core(\.\d+)?' . "\$";

# $self->scan_core_incremental([$only_top_dir])
# normally would be called after each test
# and since it updates the list of seen core files
# scan_core() won't report these again
# currently used in Apache::TestSmoke
#
# if $only_t_dir arg is true only the t_dir dir (t/) will be scanned
sub scan_core_incremental {
    my($self, $only_t_dir) = @_;
    my $vars = $self->{test_config}->{vars};

    # no core files dropped on win32
    return () if Apache::TestConfig::WIN32;

    if ($only_t_dir) {
        require IO::Dir;
        my @cores = ();
        for (IO::Dir->new($vars->{t_dir})->read) {
            my $file = catfile $vars->{t_dir}, $_;
            next unless -f $file;
            next unless /$core_pat/o;
            next if exists $core_files{$file} &&
                $core_files{$file} == -M $file;
            $core_files{$file} = -M $file;
            push @cores, $file;
        }
        return @cores 
            ? join "\n", "server dumped core, for stacktrace, run:",
                map { "gdb $vars->{httpd} -core $_" } @cores
            : ();
    }

    my @msg = ();
    finddepth({ no_chdir => 1,
                wanted   => sub {
        return unless -f $_;
        my $file = basename $File::Find::name;
        return unless $file =~ /$core_pat/o;
        my $core = $File::Find::name;
        unless (exists $core_files{$core} && $core_files{$core} == -M $core) {
            # new core file!

            # XXX: could rename the file if it doesn't include the pid
            # in its name (i.e., just called 'core', instead of 'core.365')

            # XXX: could pass the test name and rename the core file
            # to use that name as a suffix, plus pid, time or some
            # other unique identifier, in case the same test is run
            # more than once and each time it caused a segfault
            $core_files{$core} = -M $core;
            push @msg, "server dumped core, for stacktrace, run:\n" .
                "gdb $vars->{httpd} -core $core";
        }
    }}, $vars->{top_dir});

    return @msg;

}

sub scan_core {
    my $self = shift;
    my $vars = $self->{test_config}->{vars};
    my $times = 0;

    # no core files dropped on win32
    return if Apache::TestConfig::WIN32;

    finddepth({ no_chdir => 1,
                wanted   => sub {
        return unless -f $_;
        my $file = basename $File::Find::name;
        return unless $file =~ /$core_pat/o;
        my $core = $File::Find::name;
        if (exists $core_files{$core} && $core_files{$core} == -M $core) {
            # we have seen this core file before the start of the test
            info "an old core file has been found: $core";
        }
        else {
            my $oh = oh();
            my $again = $times++ ? "again" : "";
            error "oh $oh, server dumped core $again";
            error "for stacktrace, run: gdb $vars->{httpd} -core $core";
        }
    }}, $vars->{top_dir});
}

# warn the user that there is a core file before the tests
# start. suggest to delete it before proceeding or a false alarm can
# be generated at the end of the test routine run.
sub warn_core {
    my $self = shift;
    my $vars = $self->{test_config}->{vars};
    %core_files = (); # reset global

    # no core files dropped on win32
    return if Apache::TestConfig::WIN32;

    finddepth(sub {
        return unless -f $_;
        return unless /$core_pat/o;
        my $core = "$File::Find::dir/$_";
        info "consider removing an old $core file before running tests";
        # remember the timestamp of $core so we can check if it's the
        # old core file at the end of the run and not complain then
        $core_files{$core} = -M $core;
    }, $vars->{top_dir});
}

# this function handles the cases when the test suite is run under
# 'root':
#
# 1. When user 'bar' is chosen to run Apache with, files and dirs
#    created by 'root' might be not writable/readable by 'bar'
#
# 2. when the source is extracted as user 'foo', and the chosen user
#    to run Apache under is 'bar', in which case normally 'bar' won't
#    have the right permissions to write into the fs created by 'foo'.
#
# We solve that by 'chown -R bar.bar t/' in a portable way.
#
# 3. If the parent directory is not rwx for the chosen user, that user
#    won't be able to read/write the DocumentRoot. In which case we
#    have nothing else to do, but to tell the user to fix the situation.
#
sub adjust_t_perms {
    my $self = shift;

    return if Apache::TestConfig::WINFU;

    %original_t_perms = (); # reset global

    my $user = getpwuid($>) || '';
    if ($user eq 'root') {
        my $vars = $self->{test_config}->{vars};
        my $user = $vars->{user};
        my($uid, $gid) = (getpwnam($user))[2..3]
            or die "Can't find out uid/gid of '$user'";

        warning "root mode: ". 
            "changing the files ownership to '$user' ($uid:$gid)";
        finddepth(sub {
            $original_t_perms{$File::Find::name} = [(stat $_)[4..5]];
            chown $uid, $gid, $_;
        }, $vars->{t_dir});

        $self->check_perms($user, $uid, $gid);

        $self->become_nonroot($user, $uid, $gid);
    }
}

sub restore_t_perms {
    my $self = shift;

    return if Apache::TestConfig::WINFU;

    if (%original_t_perms) {
        warning "root mode: restoring the original files ownership";
        my $vars = $self->{test_config}->{vars};
        while (my($file, $ids) = each %original_t_perms) {
            next unless -e $file; # files could be deleted
            chown @$ids, $file;
        }
    }
}

# this sub is executed from an external process only, since it
# "sudo"'s into a uid/gid of choice
sub run_root_fs_test {
    my($uid, $gid, $dir) = @_;

    # first must change gid and egid ("$gid $gid" for an empty
    # setgroups() call as explained in perlvar.pod)
    my $groups = "$gid $gid";
    $( = $) = $groups;
    die "failed to change gid to $gid"
        unless $( eq $groups && $) eq $groups;

    # only now can change uid and euid
    $< = $> = $uid+0;
    die "failed to change uid to $uid" unless $< == $uid && $> == $uid;

    my $file = catfile $dir, ".apache-test-file-$$-".time.int(rand);
    eval "END { unlink q[$file] }";

    # unfortunately we can't run the what seems to be an obvious test:
    # -r $dir && -w _ && -x _
    # since not all perl implementations do it right (e.g. sometimes
    # acls are ignored, at other times setid/gid change is ignored)
    # therefore we test by trying to attempt to read/write/execute

    # -w
    open TEST, ">$file" or die "failed to open $file: $!";

    # -x
    -f $file or die "$file cannot be looked up";
    close TEST;

    # -r
    opendir DIR, $dir or die "failed to open dir $dir: $!";
    defined readdir DIR or die "failed to read dir $dir: $!";
    close DIR;

    # all tests passed
    print "OK";
}

sub check_perms {
    my ($self, $user, $uid, $gid) = @_;

    # test that the base dir is rwx by the selected non-root user
    my $vars = $self->{test_config}->{vars};
    my $dir  = $vars->{t_dir};
    my $perl = Apache::TestConfig::shell_ready($vars->{perl});

    # find where Apache::TestRun was loaded from, so we load this
    # exact package from the external process
    my $inc = dirname dirname $INC{"Apache/TestRun.pm"};
    my $sub = "Apache::TestRun::run_root_fs_test";
    my $check = <<"EOI";
$perl -Mlib=$inc -MApache::TestRun -e 'eval { $sub($uid, $gid, q[$dir]) }';
EOI
    warning "testing whether '$user' is able to -rwx $dir\n$check\n";

    my $res = qx[$check] || '';
    warning "result: $res";
    unless ($res eq 'OK') {
        $self->user_error(1);
        #$self->restore_t_perms;
        error <<"EOI";
You are running the test suite under user 'root'.
Apache cannot spawn child processes as 'root', therefore
we attempt to run the test suite with user '$user' ($uid:$gid).
The problem is that the path (including all parent directories):
  $dir
must be 'rwx' by user '$user', so Apache can read and write under that
path.

There are several ways to resolve this issue. One is to move and
rebuild the distribution to '/tmp/' and repeat the 'make test'
phase. The other is not to run 'make test' as root (i.e. building
under your /home/user directory).

You can test whether some directory is suitable for 'make test' under
'root', by running a simple test. For example to test a directory
'$dir', run:

  % $check
Only if the test prints 'OK', the directory is suitable to be used for
testing.
EOI
        skip_test_suite();
        exit_perl 0;
    }
}

# in case the client side creates any files after the initial chown
# adjustments we want the server side to be able to read/write them, so
# they better be with the same permissions. dropping root permissions
# and becoming the same user as the server side solves this problem.
sub become_nonroot {
    my ($self, $user, $uid, $gid) = @_;

    warning "the client side drops 'root' permissions and becomes '$user'";

    # first must change gid and egid ("$gid $gid" for an empty
    # setgroups() call as explained in perlvar.pod)
    my $groups = "$gid $gid";
    $( = $) = $groups;
    die "failed to change gid to $gid" unless $( eq $groups && $) eq $groups;

    # only now can change uid and euid
    $< = $> = $uid+0;
    die "failed to change uid to $uid" unless $< == $uid && $> == $uid;
}

sub run_request {
    my($test_config, $opts) = @_;

    my @args = (%{ $opts->{header} }, %{ $opts->{req_args} });

    my($request, $url) = ("", "");

    for (@request_opts) {
        next unless exists $opts->{$_};
        $url = $opts->{$_} if $opts->{$_};
        $request = join $request ? '_' : '', $request, $_;
    }

    if ($request) {
        my $method = \&{"Apache::TestRequest::\U$request"};
        my $res = $method->($url, @args);
        print Apache::TestRequest::to_string($res);
    }
}

sub opt_clean {
    my($self, $level) = @_;
    my $test_config = $self->{test_config};
    $test_config->server->stop;
    $test_config->clean($level);
    1;
}

sub opt_ping {
    my($self) = @_;

    my $test_config = $self->{test_config};
    my $server = $test_config->server;
    my $pid = $server->ping;
    my $name = $server->{name};
    # support t/TEST -ping=block -run ...
    my $exit = not $self->{opts}->{'run-tests'};

    if ($pid) {
        if ($pid == -1) {
            error "port $test_config->{vars}->{port} is in use, ".
                  "but cannot determine server pid";
        }
        else {
            my $version = $server->{version};
            warning "server $name running (pid=$pid, version=$version)";
        }
        return $exit;
    }

    if (exists $self->{opts}->{ping} && $self->{opts}->{ping} eq 'block') {
        $server->wait_till_is_up(STARTUP_TIMEOUT);
    }
    else {
        warning "no server is running on $name";
    }

    return $exit; #means call exit() if true
}

sub test_inc {