core.pm

subversion-1.4.3-1.tar.gz 配置svn的源码

use strict;
use warnings;

package SVN::Core;
use SVN::Base qw(Core svn_ VERSION);
# Some build tool hates VERSION assign across two lines.
$SVN::Core::VERSION = "$SVN::Core::VER_MAJOR.$SVN::Core::VER_MINOR.$SVN::Core::VER_MICRO";

=head1 NAME

SVN::Core - Core module of the subversion perl bindings

=head1 SYNOPSIS

    use SVN::Core; # does apr_initialize and cleanup for you

    # create a root pool and set it as default pool for later use
    my $pool = SVN::Pool->new_default;

    sub something {
        # create a subpool of the current default pool
        my $pool = SVN::Pool->new_default_sub;
	# some svn operations...

	# $pool gets destroyed and the previous default pool
	# is restored when $pool's lexical scope ends
    }

    # svn_stream_t as native perl io handle
    my $stream = $txn->root->apply_text('trunk/filea', undef);
    print $stream $text;
    close $stream;

    # native perl io handle as svn_stream_t
    SVN::Repos::dump_fs($repos, \*STDOUT, \*STDERR,
                        0, $repos->fs->youngest_rev, 0);

=head1 DESCRIPTION

SVN::Core implements higher level functions of fundamental subversion
functions.

=head1 FUNCTIONS

=over 4

=cut

BEGIN {
    SVN::_Core::apr_initialize();
}

our $gpool = SVN::Pool->new_default;
SVN::Core::utf_initialize($gpool);

END {
    SVN::_Core::apr_terminate();
}

=item SVN::Core::auth_open([auth provider array]);

Takes a reference to an array of authentication providers
and returns an auth_baton.  If you use prompt providers
you can not use this function, but need to use the 
auth_open_helper.

=item SVN::Core::auth_open_helper([auth provider array);

Prompt providers return two values instead of one.  The
2nd parameter is a reference to whatever was passed into
them as the callback.  auth_open_helper splits up these
arguments, passing the provider objects into auth_open
which gives it an auth_baton and putting the other
ones in an array.  The first return value of this
function is the auth_baton, the second is a reference
to an array containing the references to the callbacks.

These callback arrays should be stored in the object
the auth_baton is attached to.

=back

=cut

sub auth_open_helper {
    my $args = shift;
    my (@auth_providers,@auth_callbacks);

    foreach my $arg (@{$args}) {
        if (ref($arg) eq '_p_svn_auth_provider_object_t') {
            push @auth_providers, $arg;
        } else {
            push @auth_callbacks, $arg;
        }
    }
    my $auth_baton = SVN::Core::auth_open(\@auth_providers);
    return ($auth_baton,\@auth_callbacks);
}

# import the INVALID and IGNORED constants
our $INVALID_REVNUM = $SVN::_Core::SWIG_SVN_INVALID_REVNUM;
our $IGNORED_REVNUM = $SVN::_Core::SWIG_SVN_IGNORED_REVNUM;

package _p_svn_stream_t;
use SVN::Base qw(Core svn_stream_);

package SVN::Stream;
use IO::Handle;
our @ISA = qw(IO::Handle);

=head1 OTHER OBJECTS

=head2 svn_stream_t - SVN::Stream

You can use native perl io handles (including io globs) as
svn_stream_t in subversion functions. Returned svn_stream_t are also
translated into perl io handles, so you could access them with regular
print, read, etc.

Note that some functions take a stream to read or write, while it
does not close it but still hold the reference to the handle. In this case
the handle won't be destroyed properly. You should always use correct
default pool before calling such functions.

=cut

use Symbol ();

sub new
{
    my $class = shift;
    my $self = bless Symbol::gensym(), ref($class) || $class;
    tie *$self, $self;
    *$self->{svn_stream} = shift;
    $self;
}

sub svn_stream {
    my $self = shift;
    *$self->{svn_stream};
}

sub TIEHANDLE
{
    return $_[0] if ref($_[0]);
    my $class = shift;
    my $self = bless Symbol::gensym(), $class;
    *$self->{svn_stream} = shift;
    $self;
}

sub CLOSE
{
    my $self = shift;
    *$self->{svn_stream}->close
	if *$self->{svn_stream};
    undef *$self->{svn_stream};
}

sub GETC
{
    my $self = shift;
    my $buf;
    return $buf if $self->read($buf, 1);
    return undef;
}

sub print
{
    my $self = shift;
    $self->WRITE ($_[0], length ($_[0]));
}

sub PRINT
{
    my $self = shift;
    if (defined $\) {
        if (defined $,) {
	    $self->print(join($,, @_).$\);
        } else {
            $self->print(join("",@_).$\);
        }
    } else {
        if (defined $,) {
            $self->print(join($,, @_));
        } else {
            $self->print(join("",@_));
        }
    }
}

sub PRINTF
{
    my $self = shift;
    my $fmt = shift;
    $self->print(sprintf($fmt, @_));
}

sub getline
{
    my $self = shift;
    *$self->{pool} ||= SVN::Core::pool_create (undef);
    my ($buf, $eof) = *$self->{svn_stream}->readline ($/, *$self->{pool});
    return undef if $eof && !length($buf);
    return $eof ? $buf : $buf.$/;
}

sub getlines
{
    die "getlines() called in scalar context\n" unless wantarray;
    my $self = shift;
    my($line, @lines);
    push @lines, $line while defined($line = $self->getline);
    return @lines;
}

sub READLINE
{
    my $self = shift;
    unless (defined $/) {
	my $buf = '';
	while (length( my $chunk = *$self->{svn_stream}->read
	       ($SVN::Core::STREAM_CHUNK_SIZE)) ) {
	    $buf .= $chunk;
	}
	return $buf;
    }
    elsif (ref $/) {
        my $buf = *$self->{svn_stream}->read (${$/});
	return length($buf) ? $buf : undef;
    }
    return wantarray ? $self->getlines : $self->getline;
}

sub READ {
    my $self = shift;
    my $len = $_[1];
    if (@_ > 2) { # read offset
        substr($_[0],$_[2]) = *$self->{svn_stream}->read ($len);
    } else {
        $_[0] = *$self->{svn_stream}->read ($len);
    }
    return $len;
}

sub WRITE {
    my $self = shift;
    my $slen = length($_[0]);
    my $len = $slen;
    my $off = 0;

    if (@_ > 1) {
        $len = $_[1] if $_[1] < $len;
        if (@_ > 2) {
            $off = $_[2] || 0;
            die "Offset outside string" if $off > $slen;
            if ($off < 0) {
                $off += $slen;
                die "Offset outside string" if $off < 0;
            }
            my $rem = $slen - $off;
            $len = $rem if $rem < $len;
        }
	*$self->{svn_stream}->write (substr ($_[0], $off, $len));
    }
    return $len;
}

*close = \&CLOSE;

sub FILENO {
    return undef;   # XXX perlfunc says this means the file is closed
}

sub DESTROY {
    my $self = shift;
    $self->close;
}

package _p_apr_pool_t;

my %WRAPPED;

sub default {
    my ($pool) = @_;
    my $pobj = SVN::Pool->_wrap ($$pool);
    $WRAPPED{$pool} = $pobj;
    $pobj->default;
}

sub DESTROY {
    my ($pool) = @_;
    delete $WRAPPED{$pool};
}

package SVN::Pool;
use SVN::Base qw/Core svn_pool_/;

=head2 svn_pool_t - SVN::Pool

The perl bindings significantly simplify the usage of pools, while 
still being manually adjustable.

Functions requiring pool as the last argument (which are, almost all
of the subversion functions), the pool is optionally. The default pool
is used if it is omitted. If default pool is not set, a new root pool
will be created and set as default automatically when the first
function requiring a default pool is called.

For callback functions providing pool to your subroutine, you could
also use $pool-E<gt>default to make it the default pool in the scope.

=head3 Methods

=over 4

=item new ([$parent])

Create a new pool. The pool is a root pool if $parent is not supplied.

=item new_default ([$parent])

Create a new pool. The pool is a root pool if $parent is not supplied.
Set the new pool as default pool.

=item new_default_sub

Create a new subpool of the current default pool, and set the
resulting pool as new default pool.

=item clear

Clear the pool.

=item destroy

Destroy the pool. If the pool is the default pool, restore the
previous default pool as default. This is normally called
automatically when the SVN::Pool object is no longer used and
destroyed by the perl garbage collector.

=back

=cut

{
    # block is here to restrict no strict refs to this block
    no strict 'refs';
    *{"apr_pool_$_"} = *{"SVN::_Core::apr_pool_$_"}
        for qw/clear destroy/;
}

my @POOLSTACK;

sub new {
    my ($class, $parent) = @_;
    $parent = $$parent if ref ($parent) eq 'SVN::Pool';
    my $self = bless \create ($parent), $class;
    return $self;
}

sub new_default_sub {
    my $parent = ref ($_[0]) ? ${+shift} : $SVN::_Core::current_pool;
    my $self = SVN::Pool->new_default ($parent);
    return $self;
}

sub new_default {
    my $self = new(@_);
    $self->default;
    return $self;
}

sub default {
    my $self = shift;
    push @POOLSTACK, $SVN::_Core::current_pool
	unless $$SVN::_Core::current_pool == 0;
    $SVN::_Core::current_pool = $$self;
}

sub clear {
    my $self = shift;
    apr_pool_clear ($$self);
}

my $globaldestroy;

END {
    $globaldestroy = 1;
}

my %WRAPPOOL;

# Create a cloned _p_apr_pool_t pointing to the same apr_pool_t
# but on different address. this allows pools that are from C
# to have proper lifetime.
sub _wrap {
    my ($class, $rawpool) = @_;
    my $pool = \$rawpool;
    bless $pool, '_p_apr_pool_t';
    my $npool = \$pool;
    bless $npool, $class;
    $WRAPPOOL{$npool} = 1;
    $npool;
}

sub DESTROY {
    return if $globaldestroy;
    my $self = shift;
    if ($$self eq $SVN::_Core::current_pool) {
	$SVN::_Core::current_pool = pop @POOLSTACK;
    }
    if (exists $WRAPPOOL{$self}) {
        delete $WRAPPOOL{$self};
    }
    else {
        apr_pool_destroy ($$self)
    }
}

package _p_svn_error_t;
use SVN::Base qw(Core svn_error_t_);

sub strerror {
	return SVN::Error::strerror($_[$[]->apr_err());
}

sub handle_error {
	return SVN::Error::handle_error(@_);
}

sub expanded_message {
	return SVN::Error::expanded_message(@_);
}

sub handle_warning {
	# need to swap parameter order.
	return SVN::Error::handle_warning($_[$[+1],$_[$[]);
}

foreach my $function (qw(compose clear quick_wrap)) {
    no strict 'refs';
    my $real_function = \&{"SVN::_Core::svn_error_$function"};
    *{"_p_svn_error_t::$function"} = sub {
			  return $real_function->(@_);
		}
}

package SVN::Error;
use SVN::Base qw(Core svn_error_);
use SVN::Base qw(Core SVN_ERR_);
use Carp;
our @CARP_NOT = qw(SVN::Base SVN::Client SVN::Core SVN::Delta
                   SVN::Delta::Editor SVN::Error SVN::Fs SVN::Node
									 SVN::Pool SVN::Ra SVN::Ra::Callbacks SVN::Ra::Reporter
									 SVN::Repos SVN::Stream SVN::TxDelta SVN::Wc);

=head2 svn_error_t - SVN::Error

By default the perl bindings handle exceptions for you.  The default handler
automatically croaks with an appropriate error message.  This is likely
sufficient for simple scripts, but more complex usage may demand handling of
errors.  

You can override the default exception handler by changing the
$SVN::Error::handler variable.  This variable holds a reference to a perl sub
that should be called whenever an error is returned by a svn function.  This
sub will be passed a svn_error_t object.   Its return value is ignored.

If you set the $SVN::Error::handler to undef then each call will return an
svn_error_t object as its first return in the case of an error, followed by the
normal return values.  If there is no error then a svn_error_t will not be
returned and only the normal return values will be returned.  When using this
mode you should be careful only to call functions in array context.  For
example: my ($ci) = $ctx-E<gt>mkdir('http://svn/foo');  In this case $ci will
be an svn_error_t object if an error occurs and a svn_client_commit_info object
otherwise.  If you leave the parenthesis off around $ci (scalar context) it
will be the commit_info object, which in the case of an error will be undef.

If you plan on using this exception handling, understanding the exception
handling system the C API uses is helpful.  You can find information on it in