[Bps-public-commit] UNNAMED PROJECT branch, master, updated. dd539446ccda58cac9331cc7e76c44e1a56d2464
jesse
jesse at bestpractical.com
Thu Jan 15 15:50:10 EST 2009
The branch, master has been updated
via dd539446ccda58cac9331cc7e76c44e1a56d2464 (commit)
from 221ea6f221a6f05ee7175265ff0cc68c9f079218 (commit)
Summary of changes:
Makefile.PL | 5 -
lib/Prophet/Replica/svn.pm | 494 -------------------------------
lib/Prophet/Replica/svn/ReplayEditor.pm | 231 --------------
lib/Prophet/Replica/svn/Util.pm | 198 ------------
4 files changed, 0 insertions(+), 928 deletions(-)
delete mode 100644 lib/Prophet/Replica/svn.pm
delete mode 100644 lib/Prophet/Replica/svn/ReplayEditor.pm
delete mode 100644 lib/Prophet/Replica/svn/Util.pm
- Log -----------------------------------------------------------------
commit dd539446ccda58cac9331cc7e76c44e1a56d2464
Author: Jesse Vincent <jesse at bestpractical.com>
Date: Thu Jan 15 15:49:44 2009 -0500
Removed historical svn replica support
diff --git a/Makefile.PL b/Makefile.PL
index bb05f31..0501ade 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -56,11 +56,6 @@ features(
'DBI' => 1,
'DBD::SQLite' => 1
],
- 'Subversion replica support' => [
- -default => 0,
- 'SVN::Core', # SVN::Repos SVN::Fs SVN::Ra SVN::Delta::Editor SVN::Client SVN::Delta
- 'Term::ReadKey',
- ],
'Maintainer testing tools' => [
-default => 1,
'Test::HTTP::Server::Simple',
diff --git a/lib/Prophet/Replica/svn.pm b/lib/Prophet/Replica/svn.pm
deleted file mode 100644
index de2bf56..0000000
--- a/lib/Prophet/Replica/svn.pm
+++ /dev/null
@@ -1,494 +0,0 @@
-package Prophet::Replica::svn;
-use Moose;
-extends 'Prophet::Replica';
-use Params::Validate qw(:all);
-
-# require rather than use to make them late-binding
-use Prophet::ChangeSet;
-
-has ra => (
- is => 'rw',
- isa => 'SVN::Ra',
- lazy => 1,
- default => sub {
- my $self = shift;
- require Prophet::Replica::svn::Util;
- my ( $baton, $ref ) = SVN::Core::auth_open_helper( Prophet::Replica::svn::Util->get_auth_providers );
- my $config = Prophet::Replica::svn::Util->svnconfig;
- return SVN::Ra->new(url => $self->url, config => $config, auth => $baton, pool => $self->_pool);
- },
-);
-
-has fs_root => (
- is => 'rw',
-);
-
-has repo_handle => (
- is => 'rw',
-);
-
-has current_edit => (
- is => 'rw',
-);
-
-has _pool => (
- is => 'rw',
-);
-
-use constant scheme => 'svn';
-
-
-=head2 setup
-
-Open a connection to the SVN source identified by C<$self->url>.
-
-=cut
-
-sub setup {
- my $self = shift;
- require SVN::Core; require SVN::Ra; require SVN::Delta; require SVN::Repos; require SVN::Fs;
- $self->_pool(SVN::Pool->new);
- if ( $self->url =~ /^file:\/\/(.*)$/ ) {
- $self->_setup_repo_connection( repository => $1 );
- #$self->state_handle( $self->prophet_handle ); XXX DO THIS RIGHT
- }
-
- if ( $self->is_resdb ) {
-
- # XXX: should probably just point to self
- return;
- }
-
- my $res_url = "svn:" . $self->url;
- $res_url =~ s/(\_res|)$/_res/;
- $self->resolution_db_handle( __PACKAGE__->new( { url => $res_url, is_resdb => 1 } ) );
-}
-
-sub state_handle { return shift } #XXX TODO better way to handle this?
-
-
-sub _setup_repo_connection {
- my $self = shift;
- my %args = validate( @_, { repository => 1, db_uuid => 0 } );
- $self->fs_root( $args{'repository'} );
- $self->set_db_uuid( $args{'db_uuid'} ) if ( $args{'db_uuid'} );
-
- my $repos = eval {
- local $SIG{__DIE__} = 'DEFAULT';
- SVN::Repos::open( $self->fs_root );
- };
- # If we couldn't open the repository handle, we should create it
- if ( $@ && !-d $self->fs_root ) {
- $repos = SVN::Repos::create( $self->fs_root, undef, undef, undef, undef, $self->_pool );
- }
- $self->repo_handle($repos);
- $self->_determine_db_uuid;
- $self->_create_nonexistent_dir( $self->db_uuid );
-}
-
-
-=head2 uuid
-
-Return the replica SVN repository's UUID
-
-=cut
-
-sub uuid {
- my $self = shift;
- return $self->repo_handle->fs->get_uuid;
-}
-
-sub latest_sequence_no {
- my $self = shift;
- Carp::cluck unless ($self->ra);
- $self->ra->get_latest_revnum;
-}
-
-
-sub traverse_changesets {
- my $self = shift;
- my %args = validate( @_,
- { after => 1,
- callback => 1,
- }
- );
-
- my $first_rev = ( $args{'after'} + 1 ) || 1;
- my $last_rev = $self->latest_sequence_no();
-
-
- die "You must implement latest_sequence_no in " . blessed($self) . ", or override traverse_changesets"
- unless defined $last_rev;
-
- for my $rev ( $first_rev .. $self->latest_sequence_no ) {
- my $changeset = $self->_fetch_changeset($rev);
- $args{callback}->( $changeset);
- }
-}
-
-
-sub _fetch_changeset {
- my $self = shift;
- my $rev = shift;
-
- require Prophet::Replica::svn::ReplayEditor;
- my $editor = Prophet::Replica::svn::ReplayEditor->new( _debug => 0 );
- my $pool = SVN::Pool->new_default;
-
- # This horrible hack is here because I have no idea how to pass custom variables into the editor
- $editor->{revision} = $rev;
-
- $self->ra->replay( $rev, 0, 1, $editor );
- return $self->_recode_changeset( $editor->dump_deltas, $self->ra->rev_proplist($rev) );
-
-}
-
-sub _recode_changeset {
- my $self = shift;
- my $entry = shift;
- my $revprops = shift;
- my $changeset = Prophet::ChangeSet->new({
- creator => $self->changeset_creator,
- sequence_no => $entry->{'revision'},
- source_uuid => $self->uuid,
- original_source_uuid => $revprops->{'prophet:original-source'} || $self->uuid,
- original_sequence_no => $revprops->{'prophet:original-sequence-no'} || $entry->{'revision'},
- is_nullification => ( ( $revprops->{'prophet:special-type'} || '' ) eq 'nullification' ) ? 1 : undef,
- is_resolution => ( ( $revprops->{'prophet:special-type'} || '' ) eq 'resolution' ) ? 1 : undef,
- });
-
- # add each record's changes to the changeset
- for my $path ( keys %{ $entry->{'paths'} } ) {
- if ( $path =~ qr|^(.+)/(.*?)/(.*?)$| ) {
- my ( $prefix, $type, $record ) = ( $1, $2, $3 );
- my $change = Prophet::Change->new(
- { record_type => $type,
- record_uuid => $record,
- change_type => $entry->{'paths'}->{$path}->{fs_operation}
- }
- );
- for my $name ( keys %{ $entry->{'paths'}->{$path}->{prop_deltas} } ) {
- $change->add_prop_change(
- name => $name,
- old => $entry->{paths}->{$path}->{prop_deltas}->{$name}->{'old'},
- new => $entry->{paths}->{$path}->{prop_deltas}->{$name}->{'new'},
- );
- }
-
- $changeset->add_change( change => $change );
-
- } else {
- warn "Discarding change to a non-record: $path" if 0;
- }
-
- }
- return $changeset;
-}
-
-
-
-
-
-=head1 CODE BELOW THIS LINE
-
-=cut
-
-our $DEBUG = '0';
-use Params::Validate qw(:all);
-
-
-
-use constant can_read_records => 1;
-use constant can_write_records => 1;
-use constant can_read_changesets => 1;
-use constant can_write_changesets => 1;
-
-
-=head2 _current_root
-
-Returns a handle to the svn filesystem's HEAD
-
-=cut
-
-sub _current_root {
- my $self = shift;
- $self->repo_handle->fs->revision_root( $self->repo_handle->fs->youngest_rev );
-}
-
-use constant USER_PROVIDED_DB_UUID => 1;
-use constant DETECTED_DB_UUID => 2;
-use constant CREATED_DB_UUID => 3;
-
-sub _determine_db_uuid {
- my $self = shift;
- return USER_PROVIDED_DB_UUID if $self->db_uuid;
- my @known_replicas = keys %{ $self->_current_root->dir_entries("/") };
-
- for my $key ( keys %{ $self->_current_root->dir_entries("/") } ) {
- if ( $key =~ /^_prophet-/ ) {
- $self->set_db_uuid($key);
- return DETECTED_DB_UUID;
- }
- }
-
- # no luck. create one
-
- $self->set_db_uuid( "_prophet-" . Data::UUID->new->create_str() );
- return CREATED_DB_UUID;
-}
-
-sub _after_record_changes {
- my $self = shift;
- my ($changeset) = validate_pos( @_, { isa => 'Prophet::ChangeSet' } );
-
- $self->current_edit->change_prop( 'prophet:special-type' => 'nullification' ) if ( $changeset->is_nullification );
- $self->current_edit->change_prop( 'prophet:special-type' => 'resolution' ) if ( $changeset->is_resolution );
-}
-
-
-sub _set_original_source_metadata_for_current_edit {
- my $self = shift;
- my ($changeset) = validate_pos( @_, { isa => 'Prophet::ChangeSet' } );
-
- $self->current_edit->change_prop( 'prophet:original-source' => $changeset->original_source_uuid );
- $self->current_edit->change_prop( 'prophet:original-sequence-no' => $changeset->original_sequence_no );
-}
-
-sub _create_nonexistent_dir {
- my $self = shift;
- my $dir = shift;
- my $pool = SVN::Pool->new_default;
- my $root = $self->current_edit ? $self->current_edit->root : $self->_current_root;
-
- unless ( $root->is_dir($dir) ) {
- my $inside_edit = $self->current_edit ? 1 : 0;
- $self->begin_edit() unless ($inside_edit);
- $self->current_edit->root->make_dir($dir);
- $self->commit_edit() unless ($inside_edit);
- }
-}
-
-
-
-
-=head2 begin_edit
-
-Starts a new transaction within the replica's backend database. Sets L</current_edit> to that edit object.
-
-Returns $self->current_edit.
-
-=cut
-
-sub begin_edit {
- my $self = shift;
- my $fs = $self->repo_handle->fs;
- $self->current_edit( $fs->begin_txn( $fs->youngest_rev ) );
- return $self->current_edit;
-}
-
-=head2 commit_edit
-
-Finalizes L</current_edit> and sets the 'svn:author' change-prop to the current user.
-
-=cut
-
-sub commit_edit {
- my $self = shift;
- my $txn = shift;
- $self->current_edit->change_prop( 'svn:author', ( $ENV{'PROPHET_USER'} || $ENV{'USER'} ) );
- $self->current_edit->commit;
- $self->current_edit(undef);
-
-}
-
-=head2 create_record { type => $TYPE, uuid => $uuid, props => { key-value pairs }}
-
-Create a new record of type C<$type> with uuid C<$uuid> within the current replica.
-
-Sets the record's properties to the key-value hash passed in as the C<props> argument.
-
-If called from within an edit, it uses the current edit. Otherwise it manufactures and finalizes one of its own.
-
-=cut
-
-sub create_record {
- my $self = shift;
- my %args = validate( @_, { uuid => 1, props => 1, type => 1 } );
-
- $self->_create_nonexistent_dir( join( '/', $self->db_uuid, $args{'type'} ) );
-
- my $inside_edit = $self->current_edit ? 1 : 0;
- $self->begin_edit() unless ($inside_edit);
-
- my $file = $self->_file_for( uuid => $args{uuid}, type => $args{'type'} );
- $self->current_edit->root->make_file($file);
- {
- my $stream = $self->current_edit->root->apply_text( $file, undef );
-
- # print $stream Dumper( $args{'props'} );
- close $stream;
- }
- $self->_set_record_props(
- uuid => $args{uuid},
- props => $args{props},
- type => $args{'type'}
- );
- $self->commit_edit() unless ($inside_edit);
- return 1;
-}
-
-sub _set_record_props {
- my $self = shift;
- my %args = validate( @_, { uuid => 1, props => 1, type => 1 } );
-
- my $file = $self->_file_for( uuid => $args{uuid}, type => $args{type} );
- for my $prop ( keys %{ $args{'props'} } ) {
- eval {
- local $SIG{__DIE__} = 'DEFAULT';
- $self->current_edit->root->change_node_prop( $file, $prop, $args{'props'}->{$prop}, undef )
- };
- Carp::confess($@) if ($@);
- }
-}
-
-=head2 delete_record {uuid => $uuid, type => $type }
-
-Deletes the record C<$uuid> of type C<$type> from the current replica.
-
-Manufactures its own new edit if C<$self->current_edit> is undefined.
-
-=cut
-
-sub delete_record {
- my $self = shift;
- my %args = validate( @_, { uuid => 1, type => 1 } );
-
- my $inside_edit = $self->current_edit ? 1 : 0;
- $self->begin_edit() unless ($inside_edit);
-
- $self->current_edit->root->delete( $self->_file_for( uuid => $args{uuid}, type => $args{type} ) );
- $self->commit_edit() unless ($inside_edit);
- return 1;
-}
-
-=head2 set_record_props { uuid => $uuid, type => $type, props => {hash of kv pairs }}
-
-
-Updates the record of type C<$type> with uuid C<$uuid> to set each property defined by the props hash. It does NOT alter any property not defined by the props hash.
-
-Manufactures its own current edit if none exists.
-
-=cut
-
-sub set_record_props {
- my $self = shift;
- my %args = validate( @_, { uuid => 1, props => 1, type => 1 } );
-
- my $inside_edit = $self->current_edit ? 1 : 0;
- $self->begin_edit() unless ($inside_edit);
-
- my $file = $self->_file_for( uuid => $args{uuid}, type => $args{'type'} );
- $self->_set_record_props(
- uuid => $args{uuid},
- props => $args{props},
- type => $args{'type'}
- );
- $self->commit_edit() unless ($inside_edit);
-
-}
-
-=head2 get_record_props {uuid => $uuid, type => $type }
-
-Returns a hashref of all properties for the record of type $type with uuid C<$uuid>.
-
-=cut
-
-sub get_record_props {
- my $self = shift;
- my %args = validate( @_, { uuid => 1, type => 1 } );
- return $self->_current_root->node_proplist( $self->_file_for( uuid => $args{'uuid'}, type => $args{'type'} ) );
-}
-
-=head2 _file_for { uuid => $UUID, type => $type }
-
-Returns a file path within the repository (starting from the root)
-
-=cut
-
-sub _file_for {
- my $self = shift;
- my %args = validate( @_, { uuid => 1, type => 1 } );
- Carp::cluck unless $args{uuid};
- my $file = join( "/", $self->_directory_for_type( type => $args{'type'} ), $args{'uuid'} );
- return $file;
-
-}
-
-sub _directory_for_type {
- my $self = shift;
- my %args = validate( @_, { type => 1 } );
- Carp::cluck unless defined $args{type};
- return join( "/", $self->db_uuid, $args{'type'} );
-
-}
-
-=head2 record_exists {uuid => $uuid, type => $type, root => $root }
-
-Returns true if the record in question exists. False otherwise
-
-=cut
-
-sub record_exists {
- my $self = shift;
- my %args = validate( @_, { uuid => 1, type => 1, root => undef } );
-
- my $root = $args{'root'} || $self->_current_root;
- return $root->check_path( $self->_file_for( uuid => $args{'uuid'}, type => $args{'type'} ) );
-
-}
-
-=head2 list_records { type => $type }
-
-Returns a reference to a list of all the records of type $type
-
-=cut
-
-sub list_records {
- my $self = shift;
- my %args = validate( @_ => { type => 1 } );
- return [ keys %{ $self->_current_root->dir_entries( $self->db_uuid . '/' . $args{type} . '/' ) } ];
-}
-
-=head2 list_types
-
-Returns a reference to a list of all the known types in your Prophet database
-
-=cut
-
-sub list_types {
- my $self = shift;
- return [ keys %{ $self->_current_root->dir_entries( $self->db_uuid . '/' ) } ];
-}
-
-
-=head2 type_exists { type => $type }
-
-Returns true if we have any records of type C<$type>
-
-=cut
-
-
-sub type_exists {
- my $self = shift;
- my %args = validate( @_, { type => 1, root => undef } );
-
- my $root = $args{'root'} || $self->_current_root;
- return $root->check_path( $self->_directory_for_type( type => $args{'type'}, ) );
-
-}
-
-__PACKAGE__->meta->make_immutable;
-no Moose;
-
-1;
-
diff --git a/lib/Prophet/Replica/svn/ReplayEditor.pm b/lib/Prophet/Replica/svn/ReplayEditor.pm
deleted file mode 100644
index 90acd2e..0000000
--- a/lib/Prophet/Replica/svn/ReplayEditor.pm
+++ /dev/null
@@ -1,231 +0,0 @@
-use warnings;
-use strict;
-
-package Prophet::Replica::svn::ReplayEditor;
-use SVN::Delta;
-use base qw/SVN::Delta::Editor/;
-
-
-=head1 NAME
-
-Prophet::Replica::svn::ReplayEditor
-
-=head1 DESCRIPTION
-
-This class encapsulates a Subversion "replay" editor. Prophet's
-Subversion synchronization client (L<Prophet::Replica::svn>)
-uses it to turn a set of subversion
-deltas into a set of L<Prophet::ChangeSet> objects.
-
-
-=head1 METHODS
-
-=cut
-
-=head2 new
-
-Instantiates a new subversion "editor" to track a single remote revision
-
-
-=cut
-
-=head2 ra [$RA]
-
-Gets or sets the Subversion RA object.
-
-=cut
-
-sub ra {
- my $self = shift;
- $self->{'_ra'} = shift if (@_);
- return $self->{'_ra'};
-
-}
-
-=head2 open_root ($edit_baton, $base_rev, $dir_pool, $root_baton)
-
-Called by subversion at the beginning of any edit. We only care about the base_rev
-
-=cut
-
-sub open_root {
- my $self = shift;
- my ( $edit_baton, $base_rev, $dir_pool, $root_baton ) = (@_);
- $self->{'base_rev'} = $base_rev;
-}
-
-=head2 open_directory($path, $parent_baton, $base_rev, $dir_pool, $child_baton)
-
-Called by the subversion RA layer each time SVN descends into a new directory within an open edit.
-Pushes the directory onto the internal L</dir_stack>
-
-=cut
-
-sub open_directory {
- my $self = shift;
- my ( $path, $parent_baton, $base_rev, $dir_pool, $child_baton ) = (@_);
- push @{ $self->{'dir_stack'} }, { path => $path, base_rev => $base_rev };
-}
-
-=head2 delete_entry ($path, $revision, $parent_baton)
-
-Called for any file/directory deleted within this edit.
-
-=cut
-
-sub delete_entry {
- my $self = shift;
- my ( $path, $revision, $parent_baton ) = (@_);
- $self->{'paths'}->{$path}->{fs_operation} = 'delete';
-}
-
-=head2 add_file ($path, $parent_baton, $copy_path, $copy_revision, $file_pool, $file_baton)
-
-Called whenever a file is added within an edit.
-
-=cut
-
-sub add_file {
- my $self = shift;
- my ( $path, $parent_baton, $copy_path, $copy_revision, $file_pool, $file_baton ) = (@_);
- $self->{'current_file'} = $path;
- $self->{'current_file_base_rev'} = "newly created";
- $self->{'paths'}->{$path}->{fs_operation} = 'add_file';
-}
-
-=head2 add_directory ($path, $parent_baton, $copy_path, $copy_revision, $dir_pool, $child_baton)
-
-Called whenever a directory is added within an edit.
-
-=cut
-
-sub add_directory {
- my $self = shift;
- my ( $path, $parent_baton, $copyfrom_path, $copyfrom_revision, $dir_pool, $child_baton ) = (@_);
- push @{ $self->{'dir_stack'} }, { path => $path, base_rev => -1 };
- $self->{'paths'}->{$path}->{fs_operation} = 'add_dir';
-}
-
-=head2 open_file ($path, $parent_baton, $base_rev, $file_pool, $file_baton)
-
-Called whenever a file is opened for writing within the current
-edit. This routine sets the context of future content or property
-changes.
-
-=cut
-
-sub open_file {
- my $self = shift;
- my ( $path, $parent_baton, $base_rev, $file_pool, $file_baton ) = (@_);
-
- $self->{'current_file'} = $path;
- $self->{'current_file_base_rev'} = $base_rev;
-
- my ( $stream, $pool );
-
- my ( $rev_fetched, $prev_props ) = $self->ra->get_file( $path, $self->{'revision'} - 1, $stream, $pool );
-
- $self->{'paths'}->{$path}->{fs_operation} = 'update_file';
- $self->{'paths'}->{$path}->{prev_properties} = $prev_props;
-}
-
-=head2 close_file ($file_baton, $text_checksum,$pool)
-
-Called when all edits to a file are complete. This routine ends the 'current file' context
-
-=cut
-
-sub close_file {
- my $self = shift;
- my ( $file_baton, $text_checksum, $pool ) = (@_);
- delete $self->{'current_file'};
- delete $self->{'current_file_base_rev'};
-
-}
-
-#sub absent_file {
-# my $self = shift;
-# my ($file_baton, $text_checksum, $pool) = (@_);
-#}
-
-=head2 close_directory ($dir_baton, $pool)
-
-Called by Subversion to indicate that all edits inside a directory have been completed
-
-=cut
-
-sub close_directory {
- my $self = shift;
- my ( $dir_baton, $pool ) = (@_);
- pop @{ $self->{dir_stack} };
-}
-
-#sub absent_directory {
-# my $self = shift;
-# my ($path, $parent_baton, $pool) = (@_);
-#}
-
-=head2 change_file_prop ($baton, $name, $value,$pool)
-
-Called by Subversion when a file property changes. All Subversion
-tells us is that 'the current record's property called $name has
-changed to $value'. This routine roots around and builds a delta
-from the previous value to the new value.
-
-=cut
-
-sub change_file_prop {
- my $self = shift;
- my ( $file_baton, $name, $value, $pool ) = (@_);
-
- $self->{'paths'}->{ $self->{'current_file'} }->{prop_deltas}->{$name} = {
- old => $self->{'paths'}->{ $self->{'current_file'} }->{'prev_properties'}->{$name},
- new => $value
- };
-}
-
-=head2 change_dir_prop ($baton, $name, $value,$pool)
-
-Called by Subversion when a directory property changes. All Subversion
-tells us is that 'the current record's property called $name has
-changed to $value'. This routine roots around and builds a delta
-from the previous value to the new value.
-
-=cut
-
-sub change_dir_prop {
- my $self = shift;
- my ( $dir_baton, $name, $value, $pool ) = (@_);
- $self->{'paths'}->{ $self->{'dir_stack'}->[-1]->{path} }->{prop_deltas}->{$name} = {
- old => $self->{'paths'}->{ $self->{'dir_stack'}->[-1]->{path} }->{'prev_properties'}->{$name},
- new => $value
- };
-
-}
-
-#sub close_edit {
-# my $self = shift;
-# my ($edit_baton, $pool) = (@_);
-#}
-
-=head2 dump_deltas
-
-Returns a data structure describiing the revision and all the changes made to it:
-
- { revision => 1234,
- paths => { 'foo' => { ... }
- }
- }
-
-
-
-=cut
-
-sub dump_deltas {
- my $self = shift;
- return { revision => $self->{'revision'}, paths => $self->{'paths'} }
-
-}
-
-1;
-
diff --git a/lib/Prophet/Replica/svn/Util.pm b/lib/Prophet/Replica/svn/Util.pm
deleted file mode 100644
index db01cca..0000000
--- a/lib/Prophet/Replica/svn/Util.pm
+++ /dev/null
@@ -1,198 +0,0 @@
-# XXX CARGO CULTED FROM SVK::Util;
-package Prophet::Replica::svn::Util;
-use Moose;
-use MooseX::ClassAttribute;
-
-use SVN::Client;
-
-my $pool = SVN::Pool->new;
-
-=head1 NAME
-
-Prophet::Replica::svn::Util
-
-=head1 DESCRIPTION
-
-A library of utility functions for Subversion repository authentication. Ripped from SVK
-
-=cut
-
-class_has svnconfig => (
- is => 'rw',
- lazy => 1,
- default => sub {
- my $self = shift;
- return undef if $ENV{PROPHET_NO_SVN_CONFIG};
-
- SVN::Core::config_ensure(undef);
- return $self->_svnconfig( SVN::Core::config_get_config( undef, $pool ) );
- },
-);
-
-# XXX: this is 1.3 api. use SVN::Auth::* for 1.4 and we don't have to load ::Client anymore
-# (well, fix svn perl bindings to wrap the prompt functions correctly first.
-
-class_has auth_providers => (
- is => 'rw',
- lazy => 1,
- default => sub { sub {
- my $keychain = SVN::_Core->can('svn_auth_get_keychain_simple_provider');
- my $win32 = SVN::_Core->can('svn_auth_get_windows_simple_provider');
- [ $keychain ? $keychain : (),
- $win32 ? $win32 : (),
- SVN::Client::get_simple_provider(),
- SVN::Client::get_ssl_server_trust_file_provider(),
- SVN::Client::get_username_provider(),
- SVN::Client::get_simple_prompt_provider( \&_simple_prompt, 2 ),
- SVN::Client::get_ssl_server_trust_prompt_provider( \&_ssl_server_trust_prompt ),
- SVN::Client::get_ssl_client_cert_prompt_provider( \&_ssl_client_cert_prompt, 2 ),
- SVN::Client::get_ssl_client_cert_pw_prompt_provider( \&_ssl_client_cert_pw_prompt, 2 ),
- SVN::Client::get_username_prompt_provider( \&_username_prompt, 2 ),
- ];
- }},
-);
-
-
-=head2 svnconfig
-
-Returns a handle to the user's Subversion configuration.
-
-=cut
-
-=head2 get_auth_providers
-
-Returns an array of Subversion authentication providers
-
-# Note: Use a proper default pool when calling get_auth_providers
-
-=cut
-
-sub get_auth_providers {
- my $class = shift;
- return $class->auth_providers->();
-}
-
-use constant OK => $SVN::_Core::SVN_NO_ERROR;
-
-# Implement auth callbacks
-sub _simple_prompt {
- my ( $cred, $realm, $default_username, $may_save, $pool ) = @_;
-
- if ( defined $default_username and length $default_username ) {
- print "Authentication realm: $realm\n" if defined $realm and length $realm;
- $cred->username($default_username);
- } else {
- _username_prompt( $cred, $realm, $may_save, $pool );
- }
-
- $cred->password( _read_password( "Password for '" . $cred->username . "': " ) );
- $cred->may_save($may_save);
-
- return OK;
-}
-
-sub _ssl_server_trust_prompt {
- my ( $cred, $realm, $failures, $cert_info, $may_save, $pool ) = @_;
-
- print "Error validating server certificate for '$realm':\n";
-
- print " - The certificate is not issued by a trusted authority. Use the\n",
- " fingerprint to validate the certificate manually!\n"
- if ( $failures & $SVN::Auth::SSL::UNKNOWNCA );
-
- print " - The certificate hostname does not match.\n"
- if ( $failures & $SVN::Auth::SSL::CNMISMATCH );
-
- print " - The certificate is not yet valid.\n"
- if ( $failures & $SVN::Auth::SSL::NOTYETVALID );
-
- print " - The certificate has expired.\n"
- if ( $failures & $SVN::Auth::SSL::EXPIRED );
-
- print " - The certificate has an unknown error.\n"
- if ( $failures & $SVN::Auth::SSL::OTHER );
-
- printf(
- "Certificate information:\n"
- . " - Hostname: %s\n"
- . " - Valid: from %s until %s\n"
- . " - Issuer: %s\n"
- . " - Fingerprint: %s\n",
- map $cert_info->$_,
- qw(hostname valid_from valid_until issuer_dname fingerprint)
- );
-
- print( $may_save
- ? "(R)eject, accept (t)emporarily or accept (p)ermanently? "
- : "(R)eject or accept (t)emporarily? "
- );
-
- my $choice = lc( substr( <STDIN> || 'R', 0, 1 ) );
-
- if ( $choice eq 't' ) {
- $cred->may_save(0);
- $cred->accepted_failures($failures);
- } elsif ( $may_save and $choice eq 'p' ) {
- $cred->may_save(1);
- $cred->accepted_failures($failures);
- }
-
- return OK;
-}
-
-sub _ssl_client_cert_prompt {
- my ( $cred, $realm, $may_save, $pool ) = @_;
-
- print "Client certificate filename: ";
- chomp( my $filename = <STDIN> );
- $cred->cert_file($filename);
-
- return OK;
-}
-
-sub _ssl_client_cert_pw_prompt {
- my ( $cred, $realm, $may_save, $pool ) = @_;
-
- $cred->password( _read_password("Passphrase for '%s': ") );
-
- return OK;
-}
-
-sub _username_prompt {
- my ( $cred, $realm, $may_save, $pool ) = @_;
-
- print "Authentication realm: $realm\n" if defined $realm and length $realm;
- print "Username: ";
- chomp( my $username = <STDIN> );
- $username = '' unless defined $username;
-
- $cred->username($username);
-
- return OK;
-}
-
-sub _read_password {
- my ($prompt) = @_;
-
- print $prompt;
-
- require Term::ReadKey;
- Term::ReadKey::ReadMode('noecho');
-
- my $password = '';
- while ( defined( my $key = Term::ReadKey::ReadKey(0) ) ) {
- last if $key =~ /[\012\015]/;
- $password .= $key;
- }
-
- Term::ReadKey::ReadMode('restore');
- print "\n";
-
- return $password;
-}
-
-__PACKAGE__->meta->make_immutable;
-no Moose;
-no MooseX::ClassAttribute;
-
-1;
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list