Subversion Repositories DevTools

Rev

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