[Bps-public-commit] r11388 - in SVN-PropDB: . bin lib/Prophet lib/Prophet/Test

jesse at bestpractical.com jesse at bestpractical.com
Wed Apr 2 06:27:16 EDT 2008


Author: jesse
Date: Wed Apr  2 06:27:16 2008
New Revision: 11388

Added:
   SVN-PropDB/bin/prophet   (contents, props changed)
Modified:
   SVN-PropDB/   (props changed)
   SVN-PropDB/lib/Prophet/CLI.pm
   SVN-PropDB/lib/Prophet/Sync/Source.pm
   SVN-PropDB/lib/Prophet/Test.pm
   SVN-PropDB/lib/Prophet/Test/Participant.pm

Log:
 r28984 at 31b:  jesse | 2008-04-02 00:27:01 -1000
 * create a single master 'prophet' command. move all the logic to CLI.pm. Update chicken tests to use the cli object rather than spawning


Added: SVN-PropDB/bin/prophet
==============================================================================
--- (empty file)
+++ SVN-PropDB/bin/prophet	Wed Apr  2 06:27:16 2008
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+
+use Prophet::CLI;
+my $cli = Prophet::CLI->new();
+my $cmd = shift @ARGV;
+$cli->parse_record_cmd_args();
+
+if (my $sub = $cli->can('do_'.$cmd)) {
+    $sub->($cli);
+    } else {
+    die "I don't know how to do the $cmd";
+    }
+
+
+    

Modified: SVN-PropDB/lib/Prophet/CLI.pm
==============================================================================
--- SVN-PropDB/lib/Prophet/CLI.pm	(original)
+++ SVN-PropDB/lib/Prophet/CLI.pm	Wed Apr  2 06:27:16 2008
@@ -10,11 +10,13 @@
 use Prophet::Handle;
 use Prophet::Record;
 use Prophet::Collection;
+use Prophet::Sync::Source;
 
 sub new {
     my $class = shift;
-    my $self = $class->SUPER::new(@_);
-    $self->handle; $self->resdb_handle;
+    my $self  = $class->SUPER::new(@_);
+    $self->handle;
+    $self->resdb_handle;
     return $self;
 }
 
@@ -25,27 +27,24 @@
 
 sub handle {
     my $self = shift;
-    unless ($self->_handle) {
-        my $root = $ENV{'PROPHET_REPO'} || dir($ENV{'HOME'},'.prophet');
-        my $path = $ENV{'PROPHET_REPO_PATH'} ||'_prophet';
-        $self->_handle( Prophet::Handle->new( repository => $root, db_root => $path ));
+    unless ( $self->_handle ) {
+        my $root = $ENV{'PROPHET_REPO'} || dir( $ENV{'HOME'}, '.prophet' );
+        my $path = $ENV{'PROPHET_REPO_PATH'} || '_prophet';
+        $self->_handle( Prophet::Handle->new( repository => $root, db_root => $path ) );
     }
     return $self->_handle();
 }
 
-
 sub resdb_handle {
     my $self = shift;
-    unless ($self->_resdb_handle) {
-        my $root = ($ENV{'PROPHET_REPO'} || dir($ENV{'HOME'},'.prophet'))."_res";
-        my $path = $ENV{'PROPHET_REPO_PATH'} ||'_prophet';
-        $self->_resdb_handle( Prophet::Handle->new( repository => $root, db_root => $path ));
+    unless ( $self->_resdb_handle ) {
+        my $root = ( $ENV{'PROPHET_REPO'} || dir( $ENV{'HOME'}, '.prophet' ) ) . "_res";
+        my $path = $ENV{'PROPHET_REPO_PATH'} || '_prophet';
+        $self->_resdb_handle( Prophet::Handle->new( repository => $root, db_root => $path ) );
     }
     return $self->_resdb_handle();
 }
 
-
-
 =head2 parse_args
 
 This routine pulls arguments passed on the command line out of ARGV and sticks them in L</args>. The keys have leading "--" stripped.
@@ -55,8 +54,8 @@
 
 sub parse_args {
     my $self = shift;
-    %{$self->{'args'}} = @ARGV;
-    for my $name ( keys %{$self->{'args'}} ) {
+    %{ $self->{'args'} } = @ARGV;
+    for my $name ( keys %{ $self->{'args'} } ) {
         die "$name doesn't look like --prop-name" if ( $name !~ /^--/ );
         $name =~ /^--(.*)$/;
         $self->{args}->{$1} = delete $self->{'args'}->{$name};
@@ -75,12 +74,10 @@
     $self->parse_args();
 
     if ( my $uuid = delete $self->{args}->{uuid} ) {
-        $self->uuid( $uuid);
+        $self->uuid($uuid);
     }
     if ( $self->{args}->{type} ) {
         $self->type( delete $self->{args}->{'type'} );
-    } else {
-        die 'Node "--type" argument is mandatory';
     }
 }
 
@@ -90,11 +87,113 @@
 
 =cut
 
-
 sub args {
     my $self = shift;
     return $self->{'args'};
 
 }
 
+sub do_create {
+    my $cli = shift;
+    my $record = Prophet::Record->new( handle => $cli->handle, type => $cli->type );
+    my ( $id, $results ) = $record->create( props => $cli->args );
+    print "Created " . $cli->type . " " . $record->uuid . "\n";
+
+}
+
+sub do_search {
+    my $cli = shift;
+
+    my $regex;
+    unless ( $regex = $cli->args->{regex} ) {
+        die "Specify a regular expression and we'll search for records matching that regex";
+    }
+
+    my $records = Prophet::Collection->new( handle => $cli->handle, type => $cli->type );
+    $records->matching(
+        sub {
+            my $item  = shift;
+            my $props = $item->get_props;
+            map { return 1 if $props->{$_} =~ $regex } keys %$props;
+            return 0;
+        }
+    );
+
+    for ( @{ $records->as_array_ref } ) {
+        printf( "%s %s %s \n", $_->uuid, $_->prop('summary') || "(no summary)", $_->prop('status') || '(no status)' );
+    }
+}
+
+sub do_update {
+    my $cli = shift;
+
+    my $record = Prophet::Record->new( handle => $cli->handle, type => $cli->type );
+    $record->load( uuid => $cli->uuid );
+    $record->set_props( props => $cli->args );
+
+}
+
+sub do_delete {
+    my $cli = shift;
+
+    my $record = Prophet::Record->new( handle => $cli->handle, type => $cli->type );
+    $record->load( uuid => $cli->uuid );
+    if ( $record->delete ) {
+        print $record->type . " " . $record->uuid . " deleted.\n";
+    } else {
+        print $record->type . " " . $record->uuid . "could not be deleted.\n";
+    }
+
+}
+
+sub do_show {
+    my $cli = shift;
+
+    my $record = Prophet::Record->new( handle => $cli->handle, type => $cli->type );
+    $record->load( uuid => $cli->uuid );
+    print "id: " . $record->uuid . "\n";
+    my $props = $record->get_props();
+    for ( keys %$props ) {
+        print $_. ": " . $props->{$_} . "\n";
+    }
+
+}
+
+sub do_merge {
+    my $cli = shift;
+
+    my $opts = $cli->args();
+
+    my $source = Prophet::Sync::Source->new( { url => $opts->{'from'} } );
+    my $target = Prophet::Sync::Source->new( { url => $opts->{'to'} } );
+
+    if ( $target->uuid eq $source->uuid ) {
+        fatal_error( "You appear to be trying to merge two identical replicas. "
+                . "Either you're trying to merge a replica to itself or "
+                . "someone did a bad job cloning your database" );
+    }
+
+    if ( !$target->accepts_changesets ) {
+        fatal_error( $target->url . " does not accept changesets. Perhaps it's unwritable or something" );
+    }
+
+    $target->import_changesets(
+        from      => $source,
+        use_resdb => 1,
+        $ENV{'PROPHET_RESOLVER'}
+        ? ( resolver_class => 'Prophet::Resolver::' . $ENV{'PROPHET_RESOLVER'} )
+        : ( ( $opts->{'prefer'} eq 'to'   ? ( resolver_class => 'Prophet::Resolver::AlwaysTarget' ) : () ),
+            ( $opts->{'prefer'} eq 'from' ? ( resolver_class => 'Prophet::Resolver::AlwaysSource' ) : () )
+        )
+    );
+
+
+    sub fatal_error {
+        my $reason = shift;
+        die $reason . "\n";
+
+    }
+
+}
+
 1;

Modified: SVN-PropDB/lib/Prophet/Sync/Source.pm
==============================================================================
--- SVN-PropDB/lib/Prophet/Sync/Source.pm	(original)
+++ SVN-PropDB/lib/Prophet/Sync/Source.pm	Wed Apr  2 06:27:16 2008
@@ -4,7 +4,7 @@
 package Prophet::Sync::Source;
 use base qw/Class::Accessor/;
 use Params::Validate qw(:all);
-
+use UNIVERSAL::require;
 
 =head1 NAME
 
@@ -43,7 +43,9 @@
 
 sub rebless_to_replica_type {
    my $self = shift;
-   bless $self, 'Prophet::Sync::Source::SVN';
+   my $class = 'Prophet::Sync::Source::SVN';
+   $class->require;
+   bless $self, $class;
 }
 
 

Modified: SVN-PropDB/lib/Prophet/Test.pm
==============================================================================
--- SVN-PropDB/lib/Prophet/Test.pm	(original)
+++ SVN-PropDB/lib/Prophet/Test.pm	Wed Apr  2 06:27:16 2008
@@ -109,10 +109,16 @@
 
 =cut
 
+our $RUNCNT;
+
 sub _get_perl_cmd {
     my $script = shift;
     my @cmd = ($^X, (map { "-I$_" } @INC));
     push @cmd, '-MDevel::Cover' if $INC{'Devel/Cover.pm'};
+    if ($INC{'Devel/DProf.pm'}) {
+        push @cmd, '-d:DProf';
+        $ENV{'PERL_DPROF_OUT_FILE_NAME'} = 'tmon.out.'.$$.'.'.$RUNCNT++;
+    }
     push @cmd, 'bin/'.$script;
     return @cmd;
 }

Modified: SVN-PropDB/lib/Prophet/Test/Participant.pm
==============================================================================
--- SVN-PropDB/lib/Prophet/Test/Participant.pm	(original)
+++ SVN-PropDB/lib/Prophet/Test/Participant.pm	Wed Apr  2 06:27:16 2008
@@ -22,7 +22,7 @@
 
 sub _setup {
     my $self = shift;
-    as_user($self->name, sub { run_ok('prophet-node-search', [qw(--type Bug --regex .)])});
+    as_user($self->name, sub { call_func_ok( [qw(search --type Bug --regex .)])});
 
 
 }
@@ -79,7 +79,9 @@
 
     return undef unless ($args->{record});
     $self->record_action('delete_record', $args);
-    run_ok('prophet-node-delete', [qw(--type Scratch --uuid),  $args->{record}]);
+    call_func_ok( [qw(delete --type Scratch --uuid),  $args->{record}]);
+
+
 
 }
 sub create_record {
@@ -87,7 +89,7 @@
     my $args = shift;
     @{$args->{props}} = _random_props() unless $args->{props};
 
-    my ($ret, $out, $err) = run_script('prophet-node-create', [qw(--type Scratch),   @{$args->{props}} ]);
+    my ($ret, $out, $err) = call_func_ok( [qw(create --type Scratch),   @{$args->{props}} ]);
 
     ok($ret, $self->name . " created a record");
     if ($out =~ /Created\s+(.*?)\s+(.*)$/i) {
@@ -103,16 +105,15 @@
     $args->{record} ||= get_random_local_record();
     return undef unless($args->{'record'});
 
-    my ($ok, $stdout, $stderr) = run_script('prophet-node-show', [qw(--type Scratch --uuid), $args->{record}]);
-    
+    my ($ok, $stdout, $stderr) = call_func_ok([qw(update --type Scratch --uuid), $args->{record}]);
+   
     my %props = map { split(/: /,$_,2) } split(/\n/,$stdout);
     delete $props{id};
 
     %{$args->{props}} =_permute_props(%props) unless $args->{props};
     %props = %{ $args->{props} };
 
-    run_ok( 'prophet-node-update',
-        [ qw(--type Scratch --uuid), $args->{record},
+   call_func_ok( [ qw(update --type Scratch --uuid), $args->{record},
             map { '--' . $_ => $props{$_} } keys %props ], $self->name . " updated a record" );
 
     $self->record_action('update_record', $args);
@@ -126,21 +127,20 @@
 
     $self->record_action('sync_from_peer', $args);
 
-    @_ = ( 'prophet-merge',
-            [ '--prefer', 'to', '--from', repo_uri_for($from),
+    @_ = ( 
+            ['merge', '--prefer', 'to', '--from', repo_uri_for($from),
                 '--to', repo_uri_for($self->name) ], $self->name . " sync from " . $from . " ran ok!" );
-    goto \&run_ok;
+    goto \&call_func_ok;
 
 }
 
 sub get_random_local_record {
-    my ($ok, $stdout, $stderr) = run_script('prophet-node-search', [qw(--type Scratch --regex .)]);
+    my ($ok, $stdout, $stderr) = call_func_ok([qw(search --type Scratch --regex .)]);
     my $update_record = (shuffle( map { $_ =~ /^(\S*)/ } split(/\n/,$stdout)))[0];
     return $update_record;
 }
 
 
-sub sync_from_all_peers {}
 sub dump_state {
     my $self = shift;
     my $cli = Prophet::CLI->new();
@@ -176,5 +176,31 @@
     $self->arena->record($self->name, $action, @arg);
 }
 
+use IO::String;
+
+sub call_func_ok {
+    my @args = @{ shift @_ };
+    my $cmd  = shift @args;
+    local (@ARGV) = (@args);
+    my $cli = Prophet::CLI->new();
+    $cli->parse_record_cmd_args();
+
+    my $str;
+    my $str_fh = IO::String->new($str);
+
+    my $old_fh = select($str_fh);
+
+    my $ret;
+    if ( my $sub = $cli->can( 'do_' . $cmd ) ) {
+        $ret = $sub->($cli);
+    } else {
+        die "I don't know how to do the $cmd";
+    }
+    select($old_fh) if defined $old_fh;
+    ok(1, join(" ", $cmd, @ARGV));
+
+    return ( $ret, $str, undef);
+}
+
 
 1;



More information about the Bps-public-commit mailing list