Subversion Repositories DevTools

Rev

Go to most recent revision | Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
267 dpurdie 1
########################################################################
2
# Copyright (C) 2008 ERG Limited, All rights reserved
3
#
4
# Module name   : JatsSvnCore.pm
5
# Module type   : Jats Support Module
6
# Compiler(s)   : Perl
7
# Environment(s): jats
8
#
9
# Description   : JATS LowLevel Subversion Interface Functions
10
#
11
#                 Requires a subversion client to be present on the machine
12
#                 Does require at least SubVersion 1.5
13
#                 Uses features not available in 1.4
14
#
15
#                 The package currently implements a set of functions
16
#                 There are some intentional limitations:
17
#                   1) Non recursive
18
#                   2) Errors terminate operation
19
#
20
#                 This package contains experimental argument passing
21
#                 processes. Sometimes use a hash of arguments
22
#
23
#......................................................................#
24
 
25
require 5.008_002;
26
use strict;
27
use warnings;
28
use JatsEnv;
29
 
30
#
31
#   Global Variables
32
#   Configuration variables imported from environment
33
#   Must be 'our' to work with EnvImport
34
#
35
our $GBE_SVN_PATH;                      # Optional: SVN bin directory
36
our $GBE_SVN_USERNAME;                  # Optional: User name
37
our $GBE_SVN_PASSWORD;                  # Optional: User passwrd
363 dpurdie 38
our $USER;
267 dpurdie 39
 
40
package JatsSvnCore;
41
 
42
use JatsError;
43
use JatsSystem;
44
use IPC::Open3;
45
 
46
 
47
use File::Path;             # Instead of FileUtils
48
use File::Basename;
49
use Cwd;
50
 
51
 
52
# automatically export what we need into namespace of caller.
53
use Exporter();
54
our (@ISA, @EXPORT, %EXPORT_TAGS, @EXPORT_OK);
55
@ISA         = qw(Exporter);
56
@EXPORT      = qw(
57
                    SvnSession
58
                    SvnUserCmd
59
                    SvnComment
60
 
61
                );
62
@EXPORT_OK =  qw(
63
                    ProcessRevNo
353 dpurdie 64
                    %SVN_URLS
65
                    @SVN_URLS_LIST
66
 
267 dpurdie 67
                );
68
 
69
%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);
70
 
71
 
72
#
73
#   Package Global
74
#
353 dpurdie 75
my  $svn;                               # Abs path to 'svn' utility
76
my  $stdmux;                            # Abs path to stdmux utlity
77
our %SVN_URLS;                          # Exported repository URLs
78
our @SVN_URLS_LIST;                     # Exported repository URLs scan order
267 dpurdie 79
 
80
#-------------------------------------------------------------------------------
81
# Function        : BEGIN
82
#
83
# Description     : Module Initialization
84
#                   Invoked by Perl as soon as possible
85
#                       Setup environment variables
86
#                       Calculate globals
87
#
88
# Inputs          : None
89
#
90
# Returns         : Nothing
91
#
92
sub BEGIN
93
{
94
    #
95
    #   Determine authentication information
96
    #   If not present then assume that the user is already athenticated
97
    #
363 dpurdie 98
    ::EnvImportOptional('USER');
267 dpurdie 99
    ::EnvImportOptional('GBE_SVN_USERNAME');
100
    ::EnvImportOptional('GBE_SVN_PASSWORD');
101
 
102
    #
103
    #   User can provide a path to the svn utility
104
    #   It will be used if its present
105
    #
106
    ::EnvImportOptional('GBE_SVN_PATH', '');
107
 
297 dpurdie 108
    #
109
    #   For some reason thats not clear these EnvVars must be used in this function
110
    #   for them to be available elsewhere.
111
    #
112
    #   No it doesn't make sence to me either
113
    #   Problem seen on Linx. Not investigated on others
114
    #
115
    Debug ("GBE_SVN_USERNAME", $::GBE_SVN_USERNAME);
116
    Debug ("GBE_SVN_PASSWORD", $::GBE_SVN_PASSWORD);
117
    Debug ("GBE_SVN_PATH", $::GBE_SVN_PATH);
118
 
271 dpurdie 119
    $stdmux = LocateProgInPath ( 'stdmux');
311 dpurdie 120
    $svn    = LocateProgInPath ( 'svn', '--All', '--Path=' . $::GBE_SVN_PATH );
353 dpurdie 121
 
122
    #
123
    #   Extract GBE_SVN_XXXX_URL information from the environment
124
    #       XXXX is the first element of the repository path and will
125
    #            be globally (ERG) unique
126
    #       The value will be the URL to access this named repository path
127
    #       It will normally include the repository path
128
    #       The saved URL will be terminated with a single '/' to simplify usage
129
    #
130
    foreach ( sort keys %ENV )
131
    {
132
        if ( m ~^GBE_SVN_URL_*(.*)~ )
133
        {
134
            my $url = $ENV{$_};
135
            my $key = $1;
136
            $url =~ s~/*$~/~;
137
            $SVN_URLS{$key} = $url;
138
 
139
            #
140
            #   Ensure that it is in valid format
141
            #   Four forms are supported, although not all should be used
142
            #
143
            if ( $url =~ m{^svn://[^/]+} ) {
144
                #
145
                #   Type is SVN server
146
                #   Protocol + server name
147
                #
148
            } elsif ( $url =~ m{^https{0,1}://.+} ) {
149
                #
150
                #   Type is HTTP server
151
                #   Protocol + server name + path on server
152
                #
153
            } elsif ( $url =~ m{^file:///+[A-Z]:/} ) {
154
                #
155
                #   Type is local Repo (file)
156
                #   Windows absolute pathname
157
                #   file:///I:/path/...
158
                #
159
            } elsif ( $url =~ m{^file:///+[^/]} ) {
160
                #
161
                #   Type is local Repo (file)
162
                #   Unix absolute pathname
163
                #   file:///path/...
164
                #
165
            } else {
166
                ReportError ("GBE_SVN_URL format not understood","$key: $url");
167
            }
168
 
169
        }
170
    }
171
    @SVN_URLS_LIST = reverse sort keys %SVN_URLS;
172
    ErrorDoExit();
173
#DebugDumpData("%SVN_URLS", \%SVN_URLS, \@SVN_URLS_LIST);
267 dpurdie 174
}
175
 
176
#-------------------------------------------------------------------------------
177
# Function        : SvnSession
178
#
179
# Description     : Create a new SvnSession
180
#                   Simply used to contain information about the operations
181
#
182
# Inputs          : Nothing
183
#
184
# Returns         : A blessed ref
185
#
186
sub SvnSession
187
{
188
    my $self = {};
189
 
190
    #
311 dpurdie 191
    #   Delayed error reporting
192
    #   Allows the the package to be used when SVN is not installed
193
    #   as long as we don't want to use any of the features
194
    #
195
    #   Think of 'help' when svn is not yet installed
196
    #
197
    Error ("The JATS stdmux utility cannot be found" ) unless ( $stdmux );
198
    Error ("The svn utility cannot be found", "Configured Path: $::GBE_SVN_PATH") unless ( $svn );
199
 
200
    #
267 dpurdie 201
    #   Documented instance variables
202
    #
203
    $self->{REVNO} = undef;         # Revision of last Repository operation
204
    $self->{ERROR_LIST} = [];       # Last SVN operation errors
205
    $self->{RESULT_LIST} = [];      # Last SVN operation results
206
    $self->{PRINTDATA} = 0;         # Global control of ProcessRevNo
207
 
208
    bless ($self, __PACKAGE__);
209
}
210
 
211
#-------------------------------------------------------------------------------
212
# Function        : SvnDelete
213
#
214
# Description     : Delete a directory within a repostory
215
#                   Intended to be used to remove tags and branches
216
#
217
# Inputs          : $self       - Instance data
218
#                   A hash of named arguments
219
#                       target     - Path to remove
220
#                       comment    - User comment
221
#                       noerror    - Don't panic on failure
222
#
223
#
224
# Returns         : True - delete failed and 'noerror' was present
225
#
226
sub SvnDelete
227
{
228
    my $self = shift;
229
    my %opt = @_;
230
    Debug ("SvnDelete");
231
    Error ("Odd number of args to SvnDelete") unless ((@_ % 2) == 0);
232
    Error ("SvnDelete: No target specified" ) unless ( $opt{'target'} );
233
 
234
    my $error =  $opt{'noerror'} ? '' : "SvnDelete: Target not deleted";
235
 
236
    my $rv = SvnCmd ($self, 'delete'
237
                    , $opt{'target'}
238
                    , '-m', SvnComment( $opt{'comment'}, 'Deleted by SvnDelete' ),
239
                    , { 'credentials' => 1,
240
                        'error' => $error } );
241
    return $rv;
242
}
243
 
244
 
245
#-------------------------------------------------------------------------------
246
# Function        : SvnRename
247
#
248
# Description     : Rename something within a repository
249
#                   Intended to be used to rename tags and branches
250
#
251
#                   A few tricks
252
#                   - Rename is the same as a copy-delete
253
#                     but it doesn't work if the source is pegged
254
#                     so we just use a copy.
255
#                   - Need to ensure the target does not exist
256
#                     because if it does then we may create a subdir
257
#                     within it.
258
#
259
# Inputs          : $self           - Instance data
260
#                   A hash of named arguments
261
#                       old      - Location within the repository to copy from
262
#                       new      - Location within the repository to copy to
263
#                       comment  - Commit comment
264
#                       revision - ref to returned revision tag
265
#                       tag      - ref to URL of the Check In
266
#                       replace  - True: Delete existing tag if present
267
#
268
# Returns         : Revision of the copy
269
#
270
sub SvnRename
271
{
272
    my $self = shift;
273
    my %opt = @_;
274
    Debug ("SvnRename");
275
    Error ("Odd number of args to SvnRename") unless ((@_ % 2) == 0);
276
 
277
    #
278
    #   Insert defaults
279
    #
280
    my $old = $opt{old} || Error ("SvnRename: Source not specified" );
281
    my $new = $opt{new} || Error ("SvnRename: Target not specified" );
282
 
283
    #
284
    #   Validate the source
285
    #   Must do this in case the target-delete fails
286
    #
287
    SvnValidateTarget ( $self,
288
                        'cmd'    => 'SvnRename',
289
                        'target' => $old,
290
                        'require' => 1,
291
                        );
292
 
293
    #
294
    #   Validate the target
295
    #   Repo needs to be valid, but we may be able
296
    #   to delete the target if it does exist
297
    #
298
    SvnValidateTarget ( $self,
299
                        'target' => $new,
300
                        'delete' => $opt{replace},
301
                        );
302
    #
303
    #   The 'rename' command does not handle a pegged source
304
    #   Detect this and use a 'copy' command
305
    #   We don't need to delete the source - as its pegged.
306
    #
307
    my $cmd = ($old =~ m~@\d+$~) ? 'copy' : 'rename';
308
    SvnCmd ($self, $cmd
309
                    , $old
310
                    , $new
311
                    , '-m', SvnComment($opt{'comment'},'Renamed by SvnRename'),
312
                    , { 'credentials' => 1,
313
                        'process' => \&ProcessRevNo
314
                      , 'error' => "SvnRename: Target not renamed" } );
315
 
316
 
317
    CalcRmReference($self, $new );
318
    Message ("Tag is: " . $self->{RMREF} );
319
    return $self->{RMREF} ;
320
}
321
 
322
#-------------------------------------------------------------------------------
323
# Function        : SvnCopy
324
#
325
# Description     : Copy something within a repository
326
#                   Intended to be used to copy tags and branches
327
#
328
#                   A few tricks
329
#                   - Need to ensure the target does not exist
330
#                     because if it does then we may create a subdir
331
#                     within it.
332
#
333
# Inputs          : $self           - Instance data
334
#                   A hash of named arguments
335
#                       old         - Location within the repository to copy from
336
#                       new         - Location within the repository to copy to
337
#                       comment     - Commit comment
338
#                       revision    - ref to returned revision tag
339
#                       tag         - ref to URL of the Check In
340
#                       replace     - True: Delete existing tag if present
341
#                       cmd         - Error Prefix
342
#                       validated   - Locations already validated
343
#
344
# Returns         : Revision of the copy
345
#
346
sub SvnCopy
347
{
348
    my $self = shift;
349
    my %opt = @_;
350
    Debug ("SvnCopy");
351
    Error ("Odd number of args to SvnCopy") unless ((@_ % 2) == 0);
352
 
353
    #
354
    #   Insert defaults
355
    #
356
    my $cmd = $opt{'cmd'} || 'SvnCopy';
357
    my $old = $opt{old} || Error ("$cmd: Source not specified" );
358
    my $new = $opt{new} || Error ("$cmd: Target not specified" );
359
 
360
    #
361
    #   Validate the source
362
    #   Must do this in case the target-delete fails
363
    #
364
    SvnValidateTarget ( $self,
365
                        'cmd'    => $cmd,
366
                        'target' => $old,
367
                        'require' => 1,
368
                        );
369
 
370
    #
371
    #   Validate the target
372
    #   Repo needs to be valid, but we may be able
373
    #   to delete the target if it does exist
374
    #
375
    SvnValidateTarget ( $self,
376
                        'cmd'    => $cmd,
377
                        'target' => $new,
378
                        'delete' => $opt{replace},
379
                        );
380
    #
381
    #   Copy the URLs
382
    #
383
    SvnCmd ($self   , 'copy'
384
                    , $old
385
                    , $new
386
                    , '-m', SvnComment($opt{'comment'},"Copied by $cmd"),
387
                    , { 'credentials' => 1
388
                      , 'process' => \&ProcessRevNo
389
                      , 'error' => "$cmd: Source not copied" } );
390
 
391
    CalcRmReference($self, $new );
392
    Message ("Tag is: " . $self->{RMREF} );
393
    return $self->{RMREF} ;
394
}
395
 
396
 
397
#-------------------------------------------------------------------------------
398
# Function        : SvnValidateTarget
399
#
400
# Description     : Validate a target within the repository
401
#                   Optional allow the target to be deleted
402
#                   Mostly used internally
403
#
404
# Inputs          : $self           - Instance data
405
#                   A hash of named arguments
406
#                       target      - Location within the repository to test
407
#                       cmd         - Name of command to use in messages
408
#                       delete      - Delete if it exists
409
#                       require     - Target must exist
410
#                       available   - Target must NOT exist
411
#                       comment     - Deletion comment
412
#                       test        - Just test existance
413
#
414
# Returns         : May not return
415
#                   True : Exists
416
#                   False: Not exist (any more)
417
#
418
sub SvnValidateTarget
419
{
420
    my $self = shift;
421
    my %opt = @_;
422
    Debug ("SvnValidateTarget", $opt{target});
423
    Error ("Odd number of args to SvnValidateTarget") unless ((@_ % 2) == 0);
424
 
425
    #
426
    #   Validate options
427
    #
428
    Error ("SvnValidateTarget: No target specified") unless ( $opt{target} );
429
    $opt{cmd} = "SvnValidateTarget" unless ( $opt{cmd} );
430
    my $cmd = $opt{cmd};
431
 
432
    #
433
    #   Ensure that the target path does not exist
434
    #   Cannot allow a 'copy'/'rename' to copy into an existing path as
435
    #   Two problems:
436
    #       1) We end up copying the source into a subdir of
437
    #          target path, which is not what we want.
438
    #       2) Should use update to do that sort of a job
439
    #
440
    unless ( SvnTestPath ( $self, $cmd, $opt{target} ))
441
    {
442
        #
443
        #   Target does not exist
444
        #
445
        return 0 if ( $opt{'test'} || $opt{'available'} );
446
 
447
        Error ("$cmd: Element does not exist", "Element: $opt{target}")
448
            if ( $opt{'require'} );
449
    }
450
    else
451
    {
452
        #
453
        #    Target DOES exist
454
        #       - Good if the user requires the target
455
        #       - Error unless the user is prepared to delete it
456
        #
457
        return 1
458
                if ( $opt{'require'} || $opt{'test'} );
459
 
460
        Error ("$cmd: Element exists", "Element: $opt{target}")
461
            unless ( $opt{'delete'} );
462
 
463
        #
464
        #   The user has requested that an existing target be deleted
465
        #
466
        SvnCmd ($self, 'delete'
467
                        , $opt{target}
468
                        , '-m', SvnComment($opt{'comment'},"Deleted by $cmd"),
469
                        , { 'credentials' => 1,
470
                            'error' => "$cmd: Element not deleted" } );
471
    }
472
    return 0;
473
}
474
 
475
#-------------------------------------------------------------------------------
476
# Function        : ProcessRevNo
477
#
478
# Description     : Callback function for SvnCmd to Extract a revision number
479
#                   from the svn command output stream
480
#
481
# Inputs          : $self           - Instance data
482
#                   $line           - Command output
483
#
484
#                   Globals:
485
#
486
# Returns         : zero - we don't want to kill the command
487
#
488
sub ProcessRevNo
489
{
490
    my ($self, $line ) = @_;
491
 
492
    if ( $line =~ m~Committed revision\s+(\d+)\.~i )
493
    {
494
        $self->{REVNO} = $1;
495
    } elsif ( $self->{PRINTDATA} ) {
496
        Message ( $line ) if $line;
497
    }
498
    return 0;
499
}
500
 
501
#-------------------------------------------------------------------------------
502
# Function        : SvnScanPath
503
#
504
# Description     : Internal helper function
505
#                   Scan a directory and split contents into three groups
506
#
507
# Inputs          : $self               - Instance data
508
#                   $cmd                - Command prefix for errros
509
#                   $path               - Path to test
510
#
511
# Returns         : $ref_files          - Ref to array of files
512
#                   $ref_dirs           - Ref to array of dirs
513
#                   $ref_svn            - Ref to array of svn dirs
514
#                   $found              - True: Path found
515
#
516
sub SvnScanPath
517
{
518
    my $self = shift;
519
    my ($cmd, $path) = @_;
520
    my @files;
521
    my @dirs;
522
    my @svn;
523
 
524
    Debug ("SvnScanPath");
525
    Verbose2 ("SvnScanPath: $path");
526
    #
527
    #   Read in the directory information
528
    #   Just one level. Gets files and dirs
529
    #
530
    if ( ! SvnTestPath( $self, $cmd, $path, 1 ) )
531
    {
532
        #
533
        #   Path does not exist
534
        #
535
        return \@files, \@dirs, \@svn, 0;
536
    }
537
 
538
    #
539
    #   Path exists
540
    #   Sort into three sets
541
    #       - Svn Directories
542
    #       - Other Directories
543
    #       - Files
544
    #
545
    foreach ( @{$self->{RESULT_LIST}} )
546
    {
547
        if ( $_ eq 'trunk/' || $_ eq 'tags/' || $_ eq 'branches/' ) {
548
            push @svn, $_;
549
 
550
        } elsif ( substr ($_, -1) eq '/' ) {
551
            push @dirs, $_;
552
 
553
        } else {
554
            push @files, $_;
555
        }
556
    }
557
 
558
    return \@files, \@dirs, \@svn, 1;
559
}
560
 
561
#-------------------------------------------------------------------------------
562
# Function        : SvnTestPath
563
#
564
# Description     : Internal helper function
565
#                   Test a path within the Repo for existance
566
#                   Optionally read in immediate directory data
567
#
568
# Inputs          : $self               - Instance data
569
#                   $cmd                - Command prefix for errros
570
#                   $path               - Path to test
571
#                   $mode               - True: Read in immediate data
572
#
573
# Returns         : True  : Path found
574
#                   False : Path is non-existent in revision
575
#
576
#                   May populate @RESULT_LIST with 'immediate' data
577
#
578
sub SvnTestPath
579
{
580
    my $self = shift;
581
    my ($cmd, $path, $mode) = @_;
582
    my $depth = $mode ? 'immediates' : 'empty';
583
    Debug ("SvnTestPath", @_);
584
 
585
    #
586
    #   Read in the directory information - but no data
587
    #
588
    if ( SvnCmd ( $self, 'list', $path
589
                        , '--depth', $depth
590
                        , {'credentials' => 1,}
591
                        ))
592
    {
593
        #
594
        #   Error occurred
595
        #   If the path does not exist then this is an error that
596
        #   we can handle. The path does nto exist in the Repository
597
        #
598
        return 0
599
            if (    $self->{ERROR_LIST}[0] =~ m~' non-existent in that revision$~
600
                 || $self->{ERROR_LIST}[0] =~ m~: No repository found in '~
601
                 || $self->{ERROR_LIST}[0] =~ m~: Error resolving case of '~
602
                );
603
 
604
        Error ("$cmd: Unexpected error", @{$self->{ERROR_LIST}});
605
    }
606
    return 1;
607
}
608
 
609
#-------------------------------------------------------------------------------
610
# Function        : CalcRmReference
611
#
612
# Description     : Determine the Release Manager Reference for a SVN
613
#                   operation
614
#
615
# Inputs          : $self                   - Instance data
616
#                   $target                 - target
617
#                   $self->{REVNO}          - Revision number
618
#
619
# Returns         : RMREF - String Reference
620
#
621
sub CalcRmReference
622
{
623
    my ($self, $target) = @_;
624
    Error ("CalcRmReference: No Target") unless ( $target );
353 dpurdie 625
    Debug ("CalcRmReference: $target");
267 dpurdie 626
 
627
    #
353 dpurdie 628
    #   Insert any revision information to create a pegged URL
629
    #
630
    $target .= '@' . $self->{REVNO} if $self->{REVNO};
631
 
632
    #
267 dpurdie 633
    #   Take target and remove the reference to the local repository,
634
    #   if its present. This will provide a ref that we can use on any site
635
    #
353 dpurdie 636
    #   Note: %SVN_URLS values will have a trailing '/'
267 dpurdie 637
    #
353 dpurdie 638
    #   Sort in reverse order to ensure that the default URL is found last
639
    #
640
    foreach my $tag ( @SVN_URLS_LIST )
641
    {
642
        if ( $target =~ s~^\Q$SVN_URLS{$tag}\E~$tag/~ )
643
        {
644
            $target =~ s~^/~~;
645
            last;
646
        }
647
    }
267 dpurdie 648
    return $self->{RMREF} = $target;
649
}
650
 
651
#-------------------------------------------------------------------------------
652
# Function        : SvnComment
653
#
654
# Description     : Create a nice SVN comment from a string or an array
655
#
656
# Inputs          : user            - User comment
657
#                   default         - Default comment
658
#
659
#                   Comments may be:
660
#                       1) A string - Simple
661
#                       2) An array
662
#
663
# Returns         : A string comment
664
#
665
sub SvnComment
666
{
667
    my ($user, $default) = @_;
668
 
669
    $user = $default unless ( $user );
670
    return '' unless ( $user );
671
 
672
    my $type = ref $user;
673
    if ( $type eq '' ) {
674
        return $user;
675
 
676
    } elsif ( $type eq 'ARRAY' ) {
677
        return join ("\n", @{$user});
678
 
679
    } else {
680
        Error ("Unknown comment type: $type");
681
    }
682
}
683
 
684
 
685
#-------------------------------------------------------------------------------
686
# Function        : SvnCredentials
687
#
688
# Description     : Return an array of login credentials
689
#                   Used to extend command lines where repository access
690
#                   is required.
691
#
692
#                   There are security implications in using EnvVars
693
#                   to contain passwords. Its best to avoid their use
694
#                   and to let cached authentication from a user-session
695
#                   handle the process.
696
#
697
# Inputs          : None
698
#
699
# Returns         : An array - may be empty
700
#
701
sub SvnCredentials
702
{
703
    my @result;
363 dpurdie 704
    Verbose2 ("SvnCredentials: $::USER");
267 dpurdie 705
    if ( $::GBE_SVN_USERNAME )
706
    {
363 dpurdie 707
        Verbose2 ("SvnCredentials: GBE_SVN_USERNAME : $::GBE_SVN_USERNAME");
708
        Verbose2 ("SvnCredentials: GBE_SVN_PASSWORD : Defined" ) if ($::GBE_SVN_PASSWORD);
709
 
267 dpurdie 710
        push @result, '--no-auth-cache';
711
        push @result, '--username', $::GBE_SVN_USERNAME;
712
        push @result, '--password', $::GBE_SVN_PASSWORD if ($::GBE_SVN_PASSWORD);
713
    }
714
 
715
    return @result;
716
}
717
 
718
#-------------------------------------------------------------------------------
719
# Function        : SvnCmd
720
#
721
# Description     : Run a Subversion Command and capture/process the
722
#                   output
723
#
724
#                   See also SvnUserCmd
725
#
726
# Inputs          : $self           - Instance data
727
#                   Command arguments
728
#                   Last argument may be a hash of options.
729
#                       credentials - Add credentials
730
#                       nosavedata  - Don't save the data
731
#                       process     - Callback function
732
#                       error       - Error Message
733
#                                     Used as first line of an Error call
734
#
735
# Returns         : non-zero on errors detected
736
#
737
sub SvnCmd
738
{
739
    my $self = shift;
740
    Debug ("SvnCmd");
741
 
742
    #
743
    #   Extract arguments and options
744
    #   If last argument is a hesh, then its a hash of options
745
    #
746
    my $opt;
747
    $opt = pop @_
748
        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));
749
 
750
    #
751
    #   All commands are non-interactive, prepend argument
752
    #
753
    unshift @_, '--non-interactive';
754
    Verbose2 "SvnCmd $svn @_";
755
 
756
    #
757
    #   Prepend credentials, but don't show to users
758
    #
759
    unshift @_, SvnCredentials() if ( $opt->{'credentials'} );
760
 
761
    #
762
    # Useful debugging
763
    #
764
    # $self->{LAST_CMD} = [$svn, @_];
765
 
766
    #
767
    #   Reset command output data
768
    #
769
    $self->{ERROR_LIST} = [];
770
    $self->{RESULT_LIST} = [];
771
 
772
    #
271 dpurdie 773
    #   Make use of a wrapper program to mux the STDERR and STDOUT into
774
    #   one stream (STDOUT). #   This solves a lot of problems
775
    #
267 dpurdie 776
    #   Do not use IO redirection of STDERR because as this will cause a
777
    #   shell (sh or cmd.exe) to be invoked and this makes it much
271 dpurdie 778
    #   harder to kill on all platforms.
267 dpurdie 779
    #
780
    #   Use open3 as it allows the arguments to be passed
781
    #   directly without escaping and without any shell in the way
782
    #
271 dpurdie 783
    local (*CHLD_OUT, *CHLD_IN);
784
    my $pid = open3( \*CHLD_IN, \*CHLD_OUT, '>&STDERR', $stdmux, $svn, @_);
267 dpurdie 785
 
786
    #
787
    #   Looks as though we always get a PID - even if the process dies
788
    #   straight away or can't be found. I suspect that open3 doesn't set
789
    #   $! anyway. I know it doesn't set $?
790
    #
791
    Debug ("Pid: $pid");
792
    Error ("Can't run command: $!") unless $pid;
793
 
794
    #
795
    #   Close the input handle
796
    #   We don't have anything to send to this program
797
    #
798
    close(CHLD_IN);
799
 
800
    #
801
    #   Monitor the output from the utility
271 dpurdie 802
    #   Have used stdmux to multiplex stdout and stderr
267 dpurdie 803
    #
804
    #   Note: IO::Select doesn't work on Windows :(
271 dpurdie 805
    #   Note: Open3 will cause blocking unless both streams are read
806
    #         Can read both streams becsue IO::Select doesn't work
267 dpurdie 807
    #
808
    #   Observation:
809
    #       svn puts errors to STDERR
810
    #       svn puts status to STDOUT
811
    #
812
    while (<CHLD_OUT>)
813
    {
814
        s~\s+$~~;
815
        tr~\\/~/~;
816
 
271 dpurdie 817
        Verbose3 ( "SvnCmd:" . $_);
818
        m~^STD(...):(.+)~;
819
        my $data = $1 ? $2 : $_;
820
        next unless ( $data );
821
 
822
        if ( $1 && $1 eq 'ERR' )
267 dpurdie 823
        {
271 dpurdie 824
            #
825
            #   Process STDERR output
826
            #
827
            push @{$self->{ERROR_LIST}}, $data;
267 dpurdie 828
        }
271 dpurdie 829
        else
830
        {
831
            #
832
            #   Process STDOUT data
833
            #
834
            push @{$self->{RESULT_LIST}}, $data unless ($opt->{'nosavedata'});
835
 
836
            #
837
            #   If the user has specified a processing function then pass each
838
            #   line to the specified function.  A non-zero return will
839
            #   be taken as a signal to kill the command.
840
            #
841
            if ( exists ($opt->{'process'}) && $opt->{'process'}($self, $data) )
842
            {
843
                kill 9, $pid;
844
                last;
845
            }
846
        }
267 dpurdie 847
    }
848
 
849
    close(CHLD_OUT);
850
 
851
    #
852
    #   MUST wait for the process
853
    #   Under Windows if this is not done then we eventually fill up some
854
    #   perl-internal structure and can't spawn anymore processes.
855
    #
856
    my $rv = waitpid ( $pid, 0);
857
 
858
    #
859
    #   If an error condition was detected and the user has provided
860
    #   an error message, then display the error
861
    #
862
    #   This simplifies the user error processing
863
    #
864
    if ( @{$self->{ERROR_LIST}} && $opt->{'error'}  )
865
    {
866
        Error ( $opt->{'error'}, @{$self->{ERROR_LIST}} );
867
    }
868
 
869
    #
870
    #   Exit status has no meaning since open3 has been used
871
    #   This is because perl does not treat the opened process as a child
872
    #   Not too sure it makes any difference anyway
873
    #
874
    #
875
    Debug ("Useless Exit Status: $rv");
876
    my $result = @{$self->{ERROR_LIST}} ? 1 : 0;
877
    Verbose3 ("Exit Code: $result");
878
 
879
    return $result;
880
}
881
 
271 dpurdie 882
 
267 dpurdie 883
#-------------------------------------------------------------------------------
884
# Function        : SvnUserCmd
885
#
886
# Description     : Run a Subversion Command for interactive user
887
#                   Intended to be used interactive
888
#                   No data captured or processed
889
#                   See also SvnCmd
890
#
891
# Inputs          : Command arguments
892
#                   Last argument may be a hash of options.
893
#                       credentials - Add credentials
894
#
895
# Returns         : Result code of the SVN command
896
#
897
sub SvnUserCmd
898
{
899
    #
900
    #   Extract arguments and options
901
    #   If last argument is a hesh, then its a hash of options
902
    #
903
    my $opt;
904
    $opt = pop @_
905
        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));
906
 
907
    Verbose2 "SvnUserCmd $svn @_";
908
 
909
    #
910
    #   Prepend credentials, but don't show to users
911
    #
912
    unshift @_, SvnCredentials() if ( $opt->{'credentials'} );
913
 
914
 
915
    #
916
    #   Run the command
917
    #
918
    my $rv = system( $svn, @_ );
919
    Verbose2 "System Result Code: $rv";
920
    Verbose2 "System Result Code: $!" if ($rv);
921
 
922
     return $rv / 256;
923
}
924
 
925
#------------------------------------------------------------------------------
926
1;
363 dpurdie 927