view release on metacpan or  search on metacpan

lib/SVN/S4/Snapshot.pm  view on Meta::CPAN

sub parent_of_dir {
    my ($dir) = @_;
    my $parent_path = $dir->{dirpath};
    return if $parent_path eq '.';
    if (! ($parent_path =~ s/\/[^\/]+$//)) {
        $parent_path = '.';
    }
    my $parent = $Dir_by_dirpath{$parent_path};
    #die "s4: %Error: could not find parent for directory $dir->{dirpath}" if !defined $parent;
    # Oops, actually this can happen on an external to dir1/dir2 where dir1 is
    # not a versioned directory.
    return $parent;
}

sub text_or_binary {
    my ($self, $path) = @_;
    my $hashref = $self->client->propget('svn:mime-type', $path, "WORKING", 0);
    DEBUG "propget returns ", Dumper($hashref), "\n" if $self->debug;
    my $type = $hashref->{$path};
    return 'binary' if (defined $type && $type eq 'application/octet-stream');
    return 'text';
}

sub _inline_binaries {
    my $self = shift;
    if (!defined $_[0]) { die "s4: Internal-%Error: inline_binaries called with empty list"; }
    my $tarcmd = "tar czf - " . join (' ', @_);
    DEBUG "Exec: $tarcmd |\n" if $self->debug;
    open (PIPE, "$tarcmd |") || die "s4: %Error: open pipe from tar";
    my $status;
    my $buf;
    while ($status = read(PIPE, $buf, 60*57)) {
	print MIME::Base64::encode_base64($buf);
    }
    close PIPE;
    if ($status!=0) {
        die "s4: %Error: while reading gzipped tar file: $!";
    }
}

sub _gen_section_divider {
    my ($section) = @_;
    my $rands = rand() . rand() . rand() . rand();
    return "# BEGIN SECTION $section # $rands";
}

sub _restore_proplist {
    my ($self, $relpath, $fullpath) = @_;
    my $proplist = $self->client->proplist($fullpath, "WORKING", 0);
    my $out = _emit_propclear ($relpath);  # emit code to clear properties
    return $out if !defined $proplist->[0];  # there are no properties. done!
    my $prophash = $proplist->[0]->prop_hash;
    if ($self->debug) {
	DEBUG "path=", $proplist->[0]->node_name, "\n";
	DEBUG Dumper($prophash) if $self->debug;
    }
    foreach my $name (keys %$prophash) {
        my $value = $prophash->{$name};
        DEBUG "name=$name, value=$value\n" if $self->debug;
	$out .= _emit_propset($relpath, $name, $value);
    }
    return $out;
}

sub _emit_propclear {
    my ($path) = @_;
    my $out = $Propclear_bash_func;
    $Propclear_bash_func = "";  # so that it's only printed once into the patch
    return $out . "propclear $path\n";
}

sub _emit_propset {
    my ($path, $name, $value) = @_;
    # name or esp. value could conceivably be things that are impossible to quote.
    if (single_quotable($name) && single_quotable($value)) {
	return "svn propset ".single_quote($name)." ".single_quote($value)." $path\n";
    } else {
        warn "%Error: property name($name) or value($value) has strange characters in $path\n";
    }
}

sub single_quotable {
    my ($v) = @_;
    return 0 if $v =~ /\'/;
    # all chars ascii 0x20 through 0x7e (space through tilde)
    return 1 if $v =~ /^[ -~\t\n\r]*$/;
    return 0;   # some wierd chars in there
}

sub single_quote {
    my ($v) = @_;
    return "'".$v."'";
}

sub nonzero {
    my ($num) = @_;
    return 0 if !defined $num;
    return 0 if $num==0;
    return 1;
}

1;
__END__

=pod

=head1 NAME

SVN::S4::Snapshot - create complete snapshot of working copy

=head1 SYNOPSIS

Scripts:
  use SVN::S4::Snapshot;
  $svns4_object->snapshot (path=>I<path>);

=head1 DESCRIPTION

SVN::S4::Snapshot

=head1 METHODS

=over 4

=item $s4->snapshot(path=>I<path>);

=back

=head1 DISTRIBUTION

The latest version is available from CPAN and from L<http://www.veripool.org/>.

Copyright 2005-2013 by Bryce Denney.  This package is free software; you
can redistribute it and/or modify it under the terms of either the GNU
Lesser General Public License Version 3 or the Perl Artistic License Version 2.0.