subversion/bindings/swig/perl/native/t/3client.t

   1 #!/usr/bin/perl -w
   2
   3 use Test::More tests => 118;
   4 use strict;
   5
   6 # shut up about variables that are only used once.
   7 # these come from constants and variables used
   8 # by the bindings but not elsewhere in perl space.
   9 no warnings 'once';
  10
  11 use_ok('SVN::Core');
  12 use_ok('SVN::Repos');
  13 use_ok('SVN::Client');
  14 use_ok('SVN::Wc'); # needed for status
  15 use File::Spec::Functions;
  16 use File::Temp qw(tempdir);
  17 use File::Path qw(rmtree);
  18
  19 # do not use cleanup because it will fail, some files we
  20 # will not have write perms to.
  21 my $testpath = tempdir('svn-perl-test-XXXXXX', TMPDIR => 1, CLEANUP => 1);
  22
  23 my $repospath = catdir($testpath,'repo');
  24 my $reposurl = 'file://' . (substr($repospath,0,1) ne '/' ? '/' : '')
  25                . $repospath;
  26 my $wcpath = catdir($testpath,'wc');
  27 my $importpath = catdir($testpath,'import');
  28
  29 # track current rev ourselves to test against
  30 my $current_rev = 0;
  31
  32 # We want to trap errors ourself
  33 $SVN::Error::handler = undef;
  34
  35 # Get username we are running as
  36 my $username = getpwuid($>);
  37
  38 # This is ugly to create the test repo with SVN::Repos, but
  39 # it seems to be the most reliable way.
  40 ok(SVN::Repos::create("$repospath", undef, undef, undef, undef),
  41    "create repository at $repospath");
  42
  43 my ($ctx) = SVN::Client->new;
  44 isa_ok($ctx,'SVN::Client','Client Object');
  45
  46 my $uuid_from_url = $ctx->uuid_from_url($reposurl);
  47 ok($uuid_from_url,'Valid return from uuid_from_url method form');
  48
  49 # test non method invocation passing a SVN::Client
  50 ok(SVN::Client::uuid_from_url($reposurl,$ctx),
  51    'Valid return from uuid_from_url function form with SVN::Client object');
  52
  53 # test non method invocation passing a _p_svn_client_ctx_t
  54 ok(SVN::Client::uuid_from_url($reposurl,$ctx->{'ctx'}),
  55    'Valid return from uuid_from_url function form with _p_svn_client_ctx object');
  56
  57
  58 my ($ci_dir1) = $ctx->mkdir(["$reposurl/dir1"]);
  59 isa_ok($ci_dir1,'_p_svn_client_commit_info_t');
  60 $current_rev++;
  61 is($ci_dir1->revision,$current_rev,"commit info revision equals $current_rev");
  62
  63
  64
  65 my ($rpgval,$rpgrev) = $ctx->revprop_get('svn:author',$reposurl,$current_rev);
  66 is($rpgval,$username,'svn:author set to expected username from revprop_get');
  67 is($rpgrev,$current_rev,'Returned revnum of current rev from revprop_get');
  68
  69 SKIP: {
  70     skip 'Difficult to test on Win32', 3 if $^O eq 'MSWin32';
  71
  72     ok(rename("$repospath/hooks/pre-revprop-change.tmpl",
  73               "$repospath/hooks/pre-revprop-change"),
  74        'Rename pre-revprop-change hook');
  75     ok(chmod(0700,"$repospath/hooks/pre-revprop-change"),
  76        'Change permissions on pre-revprop-change hook');
  77
  78     my ($rps_rev) = $ctx->revprop_set('svn:log','mkdir dir1',
  79                                       $reposurl, $current_rev, 0);
  80     is($rps_rev,$current_rev,
  81        'Returned revnum of current rev from revprop_set');
  82
  83 }
  84
  85 my ($rph, $rplrev) = $ctx->revprop_list($reposurl,$current_rev);
  86 isa_ok($rph,'HASH','Returned hash reference form revprop_list');
  87 is($rplrev,$current_rev,'Returned current rev from revprop_list');
  88 is($rph->{'svn:author'},$username,
  89    'svn:author is expected user from revprop_list');
  90 if ($^O eq 'MSWin32') {
  91     # we skip the log change test on win32 so we have to test
  92     # for a different var here
  93     is($rph->{'svn:log'},'Make dir1',
  94        'svn:log is expected value from revprop_list');
  95 } else {
  96     is($rph->{'svn:log'},'mkdir dir1',
  97        'svn:log is expected value from revprop_list');
  98 }
  99 ok($rph->{'svn:date'},'svn:date is set from revprop_list');
 100
 101 is($ctx->checkout($reposurl,$wcpath,'HEAD',1),$current_rev,
 102    'Returned current rev from checkout');
 103
 104 is(SVN::Client::url_from_path($wcpath),$reposurl,
 105    "Returned $reposurl from url_from_path");
 106
 107 ok(open(NEW, ">$wcpath/dir1/new"),'Open new file for writing');
 108 ok(print(NEW 'addtest'), 'Print to new file');
 109 ok(close(NEW),'Close new file');
 110
 111 # no return means success
 112 is($ctx->add("$wcpath/dir1/new",0),undef,
 113    'Returned undef from add schedule operation');
 114
 115 # test the log_msg callback
 116 $ctx->log_msg(
 117     sub
 118     {
 119         my ($log_msg,$tmp_file,$commit_items,$pool) = @_;
 120         isa_ok($log_msg,'SCALAR','log_msg param to callback is a SCALAR');
 121         isa_ok($tmp_file,'SCALAR','tmp_file param to callback is a SCALAR');
 122         isa_ok($commit_items,'ARRAY',
 123                'commit_items param to callback is a SCALAR');
 124         isa_ok($pool,'_p_apr_pool_t',
 125                'pool param to callback is a _p_apr_pool_t');
 126         my $commit_item = shift @$commit_items;
 127         isa_ok($commit_item,'_p_svn_client_commit_item3_t',
 128                'commit_item element is a _p_svn_client_commit_item3_t');
 129         is($commit_item->path(),"$wcpath/dir1/new",
 130            "commit_item has proper path for committed file");
 131         is($commit_item->kind(),$SVN::Node::file,
 132            "kind() shows the node as a file");
 133         is($commit_item->url(),"$reposurl/dir1/new",
 134            'URL matches our repos url');
 135         # revision is 0 because the commit has not happened yet
 136         # and this is not a copy
 137         is($commit_item->revision(),0,
 138            'Revision is 0 since commit has not happened yet');
 139         is($commit_item->copyfrom_url(),undef,
 140            'copyfrom_url is undef since file is not a copy');
 141         is($commit_item->state_flags(),$SVN::Client::COMMIT_ITEM_ADD |
 142                                        $SVN::Client::COMMIT_ITEM_TEXT_MODS,
 143            'state_flags are ADD and TEXT_MODS');
 144         my $prop_changes = $commit_item->incoming_prop_changes();
 145         isa_ok($prop_changes, 'ARRAY',
 146                'incoming_prop_changes returns an ARRAY');
 147         is(scalar(@$prop_changes), 0,
 148            'No elements in the incoming_prop_changes array because ' .
 149            ' we did not make any');
 150         $prop_changes = $commit_item->outgoing_prop_changes();
 151         is($prop_changes, undef,
 152            'No outgoing_prop_changes array because we did not create one');
 153         $$log_msg = 'Add new';
 154         return 0;
 155     } );
 156
 157
 158 my ($ci_commit1) = $ctx->commit($wcpath,0);
 159 isa_ok($ci_commit1,'_p_svn_client_commit_info_t',
 160        'Commit returns a _p_svn_client_commit_info');
 161 $current_rev++;
 162 is($ci_commit1->revision,$current_rev,
 163    "commit info revision equals $current_rev");
 164
 165 # get rid of log_msg callback
 166 is($ctx->log_msg(undef),undef,
 167    'Clearing the log_msg callback works');
 168
 169 # test info() on WC
 170 is($ctx->info("$wcpath/dir1/new", undef, 'WORKING',
 171               sub
 172               {
 173                  my($infopath,$svn_info_t,$pool) = @_;
 174                  is($infopath,"new",'path passed to receiver is same as WC');
 175                  isa_ok($svn_info_t,'_p_svn_info_t');
 176                  isa_ok($pool,'_p_apr_pool_t',
 177                         'pool param is _p_apr_pool_t');
 178               }, 0),
 179    undef,
 180    'info should return undef');
 181
 182 isa_ok($ctx->info("$wcpath/dir1/newxyz", undef, 'WORKING', sub {}, 0),
 183        '_p_svn_error_t',
 184        'info should return _p_svn_error_t for a nonexistent file');
 185
 186 # test getting the log
 187 is($ctx->log("$reposurl/dir1/new",$current_rev,$current_rev,1,0,
 188              sub
 189              {
 190                  my ($changed_paths,$revision,
 191                      $author,$date,$message,$pool) = @_;
 192                  isa_ok($changed_paths,'HASH',
 193                         'changed_paths param is a HASH');
 194                  isa_ok($changed_paths->{'/dir1/new'},
 195                         '_p_svn_log_changed_path_t',
 196                         'Hash value is a _p_svn_log_changed_path_t');
 197                  is($changed_paths->{'/dir1/new'}->action(),'A',
 198                     'action returns A for add');
 199                  is($changed_paths->{'/dir1/new'}->copyfrom_path(),undef,
 200                     'copyfrom_path returns undef as it is not a copy');
 201                  is($changed_paths->{'/dir1/new'}->copyfrom_rev(),
 202                     $SVN::Core::INVALID_REVNUM,
 203                     'copyfrom_rev is set to INVALID as it is not a copy');
 204                  is($revision,$current_rev,
 205                     'revision param matches current rev');
 206                  is($author,$username,
 207                     'author param matches expected username');
 208                  ok($date,'date param is defined');
 209                  is($message,'Add new',
 210                     'message param is the expected value');
 211                  isa_ok($pool,'_p_apr_pool_t',
 212                         'pool param is _p_apr_pool_t');
 213              }),
 214    undef,
 215    'log returns undef');
 216
 217 is($ctx->update($wcpath,'HEAD',1),$current_rev,
 218    'Return from update is the current rev');
 219
 220 # no return so we should get undef as the result
 221 # we will get a _p_svn_error_t if there is an error.
 222 is($ctx->propset('perl-test','test-val',"$wcpath/dir1",0),undef,
 223    'propset on a working copy path returns undef');
 224
 225 my ($ph) = $ctx->propget('perl-test',"$wcpath/dir1",undef,0);
 226 isa_ok($ph,'HASH','propget returns a hash');
 227 is($ph->{"$wcpath/dir1"},'test-val','perl-test property has the correct value');
 228
 229 # No revnum for the working copy so we should get INVALID_REVNUM
 230 is($ctx->status($wcpath, undef, sub {
 231                                       my ($path,$wc_status) = @_;
 232                                       is($path,"$wcpath/dir1",
 233                                          'path param to status callback is' .
 234                                          'the correct path.');
 235                                       isa_ok($wc_status,'_p_svn_wc_status_t',
 236                                              'wc_stats param is a' .
 237                                              ' _p_svn_wc_status_t');
 238                                       is($wc_status->prop_status(),
 239                                          $SVN::Wc::status_modified,
 240                                          'prop_status is status_modified');
 241                                       # TODO test the rest of the members
 242                                     },
 243                 1, 0, 0, 0),
 244    $SVN::Core::INVALID_REVNUM,
 245    'status returns INVALID_REVNUM when run against a working copy');
 246
 247 my ($ci_commit2) = $ctx->commit($wcpath,0);
 248 isa_ok($ci_commit2,'_p_svn_client_commit_info_t',
 249        'commit returns a _p_svn_client_commit_info_t');
 250 $current_rev++;
 251 is($ci_commit2->revision(),$current_rev,
 252    "commit info revision equals $current_rev");
 253
 254 my $dir1_rev = $current_rev;
 255
 256
 257 my($pl) = $ctx->proplist($reposurl,$current_rev,1);
 258 isa_ok($pl,'ARRAY','proplist returns an ARRAY');
 259 isa_ok($pl->[0], '_p_svn_client_proplist_item_t',
 260        'array element is a _p_svn_client_proplist_item_t');
 261 is($pl->[0]->node_name(),"$reposurl/dir1",
 262    'node_name is the expected value');
 263 my $plh = $pl->[0]->prop_hash();
 264 isa_ok($plh,'HASH',
 265        'prop_hash returns a HASH');
 266 is_deeply($plh, {'perl-test' => 'test-val'}, 'test prop list prop_hash values');
 267
 268 # add a dir to test update
 269 my ($ci_dir2) = $ctx->mkdir(["$reposurl/dir2"]);
 270 isa_ok($ci_dir2,'_p_svn_client_commit_info_t',
 271        'mkdir returns a _p_svn_client_commit_info_t');
 272 $current_rev++;
 273 is($ci_dir2->revision(),$current_rev,
 274    "commit info revision equals $current_rev");
 275
 276 # Use explicit revnum to test that instead of just HEAD.
 277 is($ctx->update($wcpath,$current_rev,$current_rev),$current_rev,
 278    'update returns current rev');
 279
 280 # commit action against a repo returns undef
 281 is($ctx->delete(["$wcpath/dir2"],0),undef,
 282    'delete returns undef');
 283
 284 # no return means success
 285 is($ctx->revert($wcpath,1),undef,
 286    'revert returns undef');
 287
 288 my ($ci_copy) = $ctx->copy("$reposurl/dir1",2,"$reposurl/dir3");
 289 isa_ok($ci_copy,'_p_svn_client_commit_info_t',
 290        'copy returns a _p_svn_client_commitn_info_t when run against repo');
 291 $current_rev++;
 292 is($ci_copy->revision,$current_rev,
 293    "commit info revision equals $current_rev");
 294
 295 ok(mkdir($importpath),'Make import path dir');
 296 ok(open(FOO, ">$importpath/foo"),'Open file for writing in import path dir');
 297 ok(print(FOO 'foobar'),'Print to the file in import path dir');
 298 ok(close(FOO),'Close file in import path dir');
 299
 300 my ($ci_import) = $ctx->import($importpath,$reposurl,0);
 301 isa_ok($ci_import,'_p_svn_client_commit_info_t',
 302        'Import returns _p_svn_client_commint_info_t');
 303 $current_rev++;
 304 is($ci_import->revision,$current_rev,
 305    "commit info revision equals $current_rev");
 306
 307 is($ctx->blame("$reposurl/foo",'HEAD','HEAD', sub {
 308                                               my ($line_no,$rev,$author,
 309                                                   $date, $line,$pool) = @_;
 310                                               is($line_no,0,
 311                                                  'line_no param is zero');
 312                                               is($rev,$current_rev,
 313                                                  'rev param is current rev');
 314                                               is($author,$username,
 315                                                  'author param is expected' .
 316                                                  'value');
 317                                               ok($date,'date is defined');
 318                                               is($line,'foobar',
 319                                                  'line is expected value');
 320                                               isa_ok($pool,'_p_apr_pool_t',
 321                                                      'pool param is ' .
 322                                                      '_p_apr_pool_t');
 323                                             }),
 324    undef,
 325    'blame returns undef');
 326
 327 ok(open(CAT, "+>$testpath/cattest"),'open file for cat output');
 328 is($ctx->cat(\*CAT, "$reposurl/foo", 'HEAD'),undef,
 329    'cat returns undef');
 330 ok(seek(CAT,0,0),
 331    'seek the beginning of the cat file');
 332 is(readline(*CAT),'foobar',
 333    'read the first line of the cat file');
 334 ok(close(CAT),'close cat file');
 335
 336 # the string around the $current_rev exists to expose a past
 337 # bug.  In the past we did not accept values that simply
 338 # had not been converted to a number yet.
 339 my ($dirents) = $ctx->ls($reposurl,"$current_rev", 1);
 340 isa_ok($dirents, 'HASH','ls returns a HASH');
 341 isa_ok($dirents->{'dir1'},'_p_svn_dirent_t',
 342        'hash value is a _p_svn_dirent_t');
 343 is($dirents->{'dir1'}->kind(),$SVN::Core::node_dir,
 344    'kind() returns a dir node');
 345 is($dirents->{'dir1'}->size(),0,
 346    'size() returns 0 for a directory');
 347 is($dirents->{'dir1'}->has_props(),1,
 348    'has_props() returns true');
 349 is($dirents->{'dir1'}->created_rev(),$dir1_rev,
 350    'created_rev() returns expected rev');
 351 ok($dirents->{'dir1'}->time(),
 352    'time is defined');
 353 #diag(scalar(localtime($dirents->{'dir1'}->time() / 1000000)));
 354 is($dirents->{'dir1'}->last_author(),$username,
 355    'last_auth() returns expected username');
 356
 357 # test removing a property
 358 is($ctx->propset('perl-test', undef, "$wcpath/dir1", 0),undef,
 359    'propset returns undef');
 360
 361 my ($ph2) = $ctx->propget('perl-test', "$wcpath/dir1", 'WORKING', 0);
 362 isa_ok($ph2,'HASH','propget returns HASH');
 363 is(scalar(keys %$ph2),0,
 364    'No properties after deleting a property');
 365
 366 SKIP: {
 367     # This is ugly.  It is included here as an aide to understand how
 368     # to test this and because it makes my life easier as I only have
 369     # one command to run to test it.  If you want to use this you need
 370     # to change the usernames, passwords, and paths to the client cert.
 371     # It assumes that there is a repo running on localhost port 443 at
 372     # via SSL.  The repo cert should trip a client trust issue.  The
 373     # client cert should be encrypted and require a pass to use it.
 374     # Finally uncomment the skip line below.
 375
 376     # Before shipping make sure the following line is uncommented.
 377     skip 'Impossible to test without external effort to setup https', 7;
 378
 379     sub simple_prompt {
 380         my $cred = shift;
 381         my $realm = shift;
 382         my $username_passed = shift;
 383         my $may_save = shift;
 384         my $pool = shift;
 385
 386         ok(1,'simple_prompt called');
 387         $cred->username('breser');
 388         $cred->password('foo');
 389     }
 390
 391     sub ssl_server_trust_prompt {
 392         my $cred = shift;
 393         my $realm = shift;
 394         my $failures = shift;
 395         my $cert_info = shift;
 396         my $may_save = shift;
 397         my $pool = shift;
 398
 399         ok(1,'ssl_server_trust_prompt called');
 400         $cred->may_save(0);
 401         $cred->accepted_failures($failures);
 402     }
 403
 404     sub ssl_client_cert_prompt {
 405         my $cred = shift;
 406         my $realm = shift;
 407         my $may_save = shift;
 408         my $pool = shift;
 409
 410         ok(1,'ssl_client_cert_prompt called');
 411         $cred->cert_file('/home/breser/client-pass.p12');
 412     }
 413
 414     sub ssl_client_cert_pw_prompt {
 415         my $cred = shift;
 416         my $may_save = shift;
 417         my $pool = shift;
 418
 419         ok(1,'ssl_client_cert_pw_prompt called');
 420         $cred->password('test');
 421     }
 422
 423     my $oldauthbaton = $ctx->auth();
 424
 425     isa_ok($ctx->auth(SVN::Client::get_simple_prompt_provider(
 426                                 sub { simple_prompt(@_,'x') },2),
 427                SVN::Client::get_ssl_server_trust_prompt_provider(
 428                                 \&ssl_server_trust_prompt),
 429                SVN::Client::get_ssl_client_cert_prompt_provider(
 430                                 \&ssl_client_cert_prompt,2),
 431                SVN::Client::get_ssl_client_cert_pw_prompt_provider(
 432                                 \&ssl_client_cert_pw_prompt,2)
 433               ),'_p_svn_auth_baton_t',
 434               'auth() accessor returns _p_svn_auth_baton');
 435
 436     # if this doesn't work we will get an svn_error_t so by
 437     # getting a hash we know it worked.
 438     my ($dirents) = $ctx->ls('https://localhost/svn/test','HEAD',1);
 439     isa_ok($dirents,'HASH','ls returns a HASH');
 440
 441     # return the auth baton to its original setting
 442     isa_ok($ctx->auth($oldauthbaton),'_p_svn_auth_baton_t',
 443            'Successfully set auth_baton back to old value');
 444 }
 445
 446 END {
 447 diag('cleanup');
 448 rmtree($testpath);
 449 }