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