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
#
1403 dpurdie 219
# Description     : Delete a directory within a repository
267 dpurdie 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
379 dpurdie 418
#                       create      - Create if it doesn't exist
267 dpurdie 419
#
420
# Returns         : May not return
385 dpurdie 421
#                   2 : Exists and was created
422
#                   1 : Exists
423
#                   0 : Not exist (any more)
267 dpurdie 424
#
425
sub SvnValidateTarget
426
{
427
    my $self = shift;
428
    my %opt = @_;
429
    Debug ("SvnValidateTarget", $opt{target});
430
    Error ("Odd number of args to SvnValidateTarget") unless ((@_ % 2) == 0);
431
 
432
    #
433
    #   Validate options
434
    #
435
    Error ("SvnValidateTarget: No target specified") unless ( $opt{target} );
436
    $opt{cmd} = "SvnValidateTarget" unless ( $opt{cmd} );
437
    my $cmd = $opt{cmd};
438
 
439
    #
440
    #   Ensure that the target path does not exist
441
    #   Cannot allow a 'copy'/'rename' to copy into an existing path as
442
    #   Two problems:
443
    #       1) We end up copying the source into a subdir of
444
    #          target path, which is not what we want.
445
    #       2) Should use update to do that sort of a job
446
    #
447
    unless ( SvnTestPath ( $self, $cmd, $opt{target} ))
448
    {
449
        #
450
        #   Target does not exist
451
        #
452
        return 0 if ( $opt{'test'} || $opt{'available'} );
453
 
379 dpurdie 454
        #
455
        #   Create target if required
456
        #
457
        if ( $opt{create} )
458
        {
459
            $self->SvnCmd ('mkdir', $opt{target}
385 dpurdie 460
                           , '-m', $self->Path() . ': Created by ' . $cmd
379 dpurdie 461
                           , '--parents'
385 dpurdie 462
                           , { 'credentials' => 1
463
                              ,'error' => "SvnCreateBranch"
464
                              ,'process' => \&ProcessRevNo
465
                             } );
466
            return 2;
379 dpurdie 467
        }
468
 
267 dpurdie 469
        Error ("$cmd: Element does not exist", "Element: $opt{target}")
470
            if ( $opt{'require'} );
471
    }
472
    else
473
    {
474
        #
475
        #    Target DOES exist
476
        #       - Good if the user requires the target
477
        #       - Error unless the user is prepared to delete it
478
        #
479
        return 1
379 dpurdie 480
                if ( $opt{'require'} || $opt{'test'} || $opt{'create'}  );
267 dpurdie 481
 
482
        Error ("$cmd: Element exists", "Element: $opt{target}")
483
            unless ( $opt{'delete'} );
484
 
485
        #
486
        #   The user has requested that an existing target be deleted
487
        #
488
        SvnCmd ($self, 'delete'
489
                        , $opt{target}
490
                        , '-m', SvnComment($opt{'comment'},"Deleted by $cmd"),
491
                        , { 'credentials' => 1,
492
                            'error' => "$cmd: Element not deleted" } );
493
    }
494
    return 0;
495
}
496
 
497
#-------------------------------------------------------------------------------
498
# Function        : ProcessRevNo
499
#
500
# Description     : Callback function for SvnCmd to Extract a revision number
501
#                   from the svn command output stream
502
#
503
# Inputs          : $self           - Instance data
504
#                   $line           - Command output
505
#
506
#                   Globals:
507
#
508
# Returns         : zero - we don't want to kill the command
509
#
510
sub ProcessRevNo
511
{
512
    my ($self, $line ) = @_;
513
 
514
    if ( $line =~ m~Committed revision\s+(\d+)\.~i )
515
    {
516
        $self->{REVNO} = $1;
517
    } elsif ( $self->{PRINTDATA} ) {
518
        Message ( $line ) if $line;
519
    }
520
    return 0;
521
}
522
 
523
#-------------------------------------------------------------------------------
1329 dpurdie 524
# Function        : SvnInfo
525
#
526
# Description     : Determine Subversion Info for a specified target
527
#
528
# Inputs          : $self               - Instance Data
529
#                   $url                - Path or URL to get Info on
530
#                   $tag                - Name of tag within $self to store data
1403 dpurdie 531
#                                         Currently InfoWs and InfoRepo
1329 dpurdie 532
#
533
# Returns         : Non Zero if errors detected
534
#
535
sub SvnInfo
536
{
537
    my ($self, $url, $tag) = @_;
538
    Error ("Internal: SvnInfo. No Tag provided") unless ( defined $tag );
539
    Error ("Internal: SvnInfo. No URL provided") unless ( defined $url );
540
 
541
    #
542
    #   Only call  once
543
    #       Must simulate a good call
544
    #
545
    if ( exists $self->{$tag} )
546
    {
547
#DebugDumpData("MeCache: $tag", $self );
548
        $self->{ERROR_LIST} = [];
549
        return 0;
550
    }
551
 
552
    #
553
    #   Get basic information on the target
554
    #
555
    $self->{'infoTag'} = $tag;
556
    $self->{$tag}{SvnInfoPath} = $url;
557
    my $rv = $self->SvnCmd ('info', $url, '--depth', 'empty'
558
                    , { 'credentials' => 1,
559
                        'nosavedata' => 1,
560
                        'process' => \&ProcessInfo
561
                    }
562
     );
563
 
564
    delete $self->{$tag} if ( @{$self->{ERROR_LIST}} );
565
    delete $self->{'infoTag'};
566
#DebugDumpData("Me: $tag", $self );
567
    return $rv;
568
}
569
 
570
#-------------------------------------------------------------------------------
571
# Function        : ProcessInfo
572
#
573
# Description     : Process info for SvnInfo
574
#
575
# Inputs          : $self           - Instance data
576
#                   $line           - Command output
577
#
578
# Returns         : zero - we don't want to kill the command
579
#
580
sub ProcessInfo
581
{
582
    my ($self, $line ) = @_;
583
 
584
    Message ( $line ) if $self->{PRINTDATA};
585
    $line =~ m~(.*?):\s+(.*)~;
586
    $self->{$self->{'infoTag'}}{$1} = $2;
587
    return 0;
588
}
589
 
590
#-------------------------------------------------------------------------------
267 dpurdie 591
# Function        : SvnScanPath
592
#
593
# Description     : Internal helper function
594
#                   Scan a directory and split contents into three groups
595
#
596
# Inputs          : $self               - Instance data
597
#                   $cmd                - Command prefix for errros
598
#                   $path               - Path to test
599
#
600
# Returns         : $ref_files          - Ref to array of files
601
#                   $ref_dirs           - Ref to array of dirs
602
#                   $ref_svn            - Ref to array of svn dirs
603
#                   $found              - True: Path found
604
#
605
sub SvnScanPath
606
{
607
    my $self = shift;
608
    my ($cmd, $path) = @_;
609
    my @files;
610
    my @dirs;
611
    my @svn;
612
 
613
    Debug ("SvnScanPath");
614
    Verbose2 ("SvnScanPath: $path");
615
    #
616
    #   Read in the directory information
617
    #   Just one level. Gets files and dirs
618
    #
619
    if ( ! SvnTestPath( $self, $cmd, $path, 1 ) )
620
    {
621
        #
622
        #   Path does not exist
623
        #
624
        return \@files, \@dirs, \@svn, 0;
625
    }
626
 
627
    #
628
    #   Path exists
629
    #   Sort into three sets
630
    #       - Svn Directories
631
    #       - Other Directories
632
    #       - Files
633
    #
634
    foreach ( @{$self->{RESULT_LIST}} )
635
    {
636
        if ( $_ eq 'trunk/' || $_ eq 'tags/' || $_ eq 'branches/' ) {
637
            push @svn, $_;
638
 
639
        } elsif ( substr ($_, -1) eq '/' ) {
640
            push @dirs, $_;
641
 
642
        } else {
643
            push @files, $_;
644
        }
645
    }
646
 
647
    return \@files, \@dirs, \@svn, 1;
648
}
649
 
650
#-------------------------------------------------------------------------------
651
# Function        : SvnTestPath
652
#
653
# Description     : Internal helper function
654
#                   Test a path within the Repo for existance
655
#                   Optionally read in immediate directory data
656
#
657
# Inputs          : $self               - Instance data
658
#                   $cmd                - Command prefix for errros
659
#                   $path               - Path to test
660
#                   $mode               - True: Read in immediate data
661
#
662
# Returns         : True  : Path found
663
#                   False : Path is non-existent in revision
664
#
665
#                   May populate @RESULT_LIST with 'immediate' data
666
#
667
sub SvnTestPath
668
{
669
    my $self = shift;
670
    my ($cmd, $path, $mode) = @_;
671
    my $depth = $mode ? 'immediates' : 'empty';
672
    Debug ("SvnTestPath", @_);
673
 
674
    #
675
    #   Read in the directory information - but no data
676
    #
677
    if ( SvnCmd ( $self, 'list', $path
678
                        , '--depth', $depth
679
                        , {'credentials' => 1,}
680
                        ))
681
    {
682
        #
683
        #   Error occurred
684
        #   If the path does not exist then this is an error that
369 dpurdie 685
        #   we can handle. The path does not exist in the Repository
267 dpurdie 686
        #
687
        return 0
688
            if (    $self->{ERROR_LIST}[0] =~ m~' non-existent in that revision$~
369 dpurdie 689
                 || $self->{ERROR_LIST}[0] =~ m~' non-existent in revision ~
267 dpurdie 690
                 || $self->{ERROR_LIST}[0] =~ m~: No repository found in '~
691
                 || $self->{ERROR_LIST}[0] =~ m~: Error resolving case of '~
692
                );
693
 
694
        Error ("$cmd: Unexpected error", @{$self->{ERROR_LIST}});
695
    }
696
    return 1;
697
}
698
 
699
#-------------------------------------------------------------------------------
700
# Function        : CalcRmReference
701
#
702
# Description     : Determine the Release Manager Reference for a SVN
703
#                   operation
704
#
705
# Inputs          : $self                   - Instance data
706
#                   $target                 - target
707
#                   $self->{REVNO}          - Revision number
708
#
709
# Returns         : RMREF - String Reference
710
#
711
sub CalcRmReference
712
{
713
    my ($self, $target) = @_;
714
    Error ("CalcRmReference: No Target") unless ( $target );
353 dpurdie 715
    Debug ("CalcRmReference: $target");
267 dpurdie 716
 
717
    #
353 dpurdie 718
    #   Insert any revision information to create a pegged URL
719
    #
369 dpurdie 720
    my $peg = $self->{REVNO} || $self->{WSREVNO};
721
    $target .= '@' . $peg if $peg;
353 dpurdie 722
 
723
    #
1403 dpurdie 724
    #   Attempt to Calculate Release Manager
725
    #       SourcePath::Tag
726
    #
727
    if ( $self->{DEVBRANCH} )
728
    {
729
        my $sourcePath = $self->CalcSymbolicUrl($self->FullPath()) . '/' . $self->{DEVBRANCH};
730
        my $tag = 'Unknown';
731
        if ( $target =~ m~/tags/(.*)~ ) {
732
            $tag = $1;
733
        } else {
734
            $tag = $peg if ( $peg );
735
        }
736
        $self->{SVNTAG} = $sourcePath . '::' . $tag;
737
    }
738
 
739
    return $self->{RMREF} = $self->CalcSymbolicUrl($target);
740
}
741
 
742
#-------------------------------------------------------------------------------
743
# Function        : CalcSymbolicUrl
744
#
745
# Description     : Given a URL, return a symbolic URL
746
#
747
# Inputs          : $target                 - FULL URL
748
#
749
# Returns         : Imput string with a Symbolic URL if possible
750
#
751
sub CalcSymbolicUrl
752
{
753
    my ($self, $target) = @_;
754
 
755
    #
267 dpurdie 756
    #   Take target and remove the reference to the local repository,
757
    #   if its present. This will provide a ref that we can use on any site
758
    #
353 dpurdie 759
    #   Note: %SVN_URLS values will have a trailing '/'
267 dpurdie 760
    #
353 dpurdie 761
    #   Sort in reverse order to ensure that the default URL is found last
399 dpurdie 762
    #   Do case-insensitive compare. Cut the system some slack.
353 dpurdie 763
    #
764
    foreach my $tag ( @SVN_URLS_LIST )
765
    {
399 dpurdie 766
        if ( $target =~ s~^\Q$SVN_URLS{$tag}\E~$tag/~i )
353 dpurdie 767
        {
768
            $target =~ s~^/~~;
769
            last;
770
        }
771
    }
1403 dpurdie 772
    return $target;
267 dpurdie 773
}
774
 
775
#-------------------------------------------------------------------------------
776
# Function        : SvnComment
777
#
778
# Description     : Create a nice SVN comment from a string or an array
779
#
780
# Inputs          : user            - User comment
781
#                   default         - Default comment
782
#
783
#                   Comments may be:
784
#                       1) A string - Simple
785
#                       2) An array
786
#
787
# Returns         : A string comment
788
#
789
sub SvnComment
790
{
791
    my ($user, $default) = @_;
792
 
793
    $user = $default unless ( $user );
794
    return '' unless ( $user );
795
 
796
    my $type = ref $user;
797
    if ( $type eq '' ) {
798
        return $user;
799
 
800
    } elsif ( $type eq 'ARRAY' ) {
801
        return join ("\n", @{$user});
802
 
803
    } else {
804
        Error ("Unknown comment type: $type");
805
    }
806
}
807
 
808
 
809
#-------------------------------------------------------------------------------
810
# Function        : SvnCredentials
811
#
812
# Description     : Return an array of login credentials
813
#                   Used to extend command lines where repository access
814
#                   is required.
815
#
816
#                   There are security implications in using EnvVars
817
#                   to contain passwords. Its best to avoid their use
818
#                   and to let cached authentication from a user-session
819
#                   handle the process.
820
#
821
# Inputs          : None
822
#
823
# Returns         : An array - may be empty
824
#
825
sub SvnCredentials
826
{
827
    my @result;
363 dpurdie 828
    Verbose2 ("SvnCredentials: $::USER");
267 dpurdie 829
    if ( $::GBE_SVN_USERNAME )
830
    {
363 dpurdie 831
        Verbose2 ("SvnCredentials: GBE_SVN_USERNAME : $::GBE_SVN_USERNAME");
832
        Verbose2 ("SvnCredentials: GBE_SVN_PASSWORD : Defined" ) if ($::GBE_SVN_PASSWORD);
833
 
267 dpurdie 834
        push @result, '--no-auth-cache';
835
        push @result, '--username', $::GBE_SVN_USERNAME;
836
        push @result, '--password', $::GBE_SVN_PASSWORD if ($::GBE_SVN_PASSWORD);
837
    }
838
 
839
    return @result;
840
}
841
 
842
#-------------------------------------------------------------------------------
843
# Function        : SvnCmd
844
#
845
# Description     : Run a Subversion Command and capture/process the
846
#                   output
847
#
848
#                   See also SvnUserCmd
849
#
850
# Inputs          : $self           - Instance data
851
#                   Command arguments
852
#                   Last argument may be a hash of options.
853
#                       credentials - Add credentials
854
#                       nosavedata  - Don't save the data
855
#                       process     - Callback function
1403 dpurdie 856
#                       printdata   - Print data
267 dpurdie 857
#                       error       - Error Message
858
#                                     Used as first line of an Error call
859
#
860
# Returns         : non-zero on errors detected
861
#
862
sub SvnCmd
863
{
864
    my $self = shift;
865
    Debug ("SvnCmd");
866
 
867
    #
868
    #   Extract arguments and options
869
    #   If last argument is a hesh, then its a hash of options
870
    #
871
    my $opt;
872
    $opt = pop @_
873
        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));
874
 
1403 dpurdie 875
    my $savedPrintData = $self->{PRINTDATA};
876
    $self->{PRINTDATA} = $opt->{'printdata'} if ( exists $opt->{'printdata'} );
877
 
267 dpurdie 878
    #
879
    #   All commands are non-interactive, prepend argument
367 dpurdie 880
    #   Accept serve certs. Only applies to https connections. VisualSvn
881
    #   perfers https and it uses self-signed certificates.
267 dpurdie 882
    #
367 dpurdie 883
    unshift @_, '--non-interactive', '--trust-server-cert';
267 dpurdie 884
    Verbose2 "SvnCmd $svn @_";
885
 
886
    #
887
    #   Prepend credentials, but don't show to users
888
    #
889
    unshift @_, SvnCredentials() if ( $opt->{'credentials'} );
890
 
891
    #
892
    # Useful debugging
893
    #
894
    # $self->{LAST_CMD} = [$svn, @_];
895
 
896
    #
897
    #   Reset command output data
898
    #
899
    $self->{ERROR_LIST} = [];
900
    $self->{RESULT_LIST} = [];
1403 dpurdie 901
#    $self->{LAST_CMD} = \@_;
267 dpurdie 902
 
903
    #
271 dpurdie 904
    #   Make use of a wrapper program to mux the STDERR and STDOUT into
905
    #   one stream (STDOUT). #   This solves a lot of problems
906
    #
267 dpurdie 907
    #   Do not use IO redirection of STDERR because as this will cause a
908
    #   shell (sh or cmd.exe) to be invoked and this makes it much
271 dpurdie 909
    #   harder to kill on all platforms.
267 dpurdie 910
    #
911
    #   Use open3 as it allows the arguments to be passed
912
    #   directly without escaping and without any shell in the way
913
    #
271 dpurdie 914
    local (*CHLD_OUT, *CHLD_IN);
915
    my $pid = open3( \*CHLD_IN, \*CHLD_OUT, '>&STDERR', $stdmux, $svn, @_);
267 dpurdie 916
 
917
    #
918
    #   Looks as though we always get a PID - even if the process dies
919
    #   straight away or can't be found. I suspect that open3 doesn't set
920
    #   $! anyway. I know it doesn't set $?
921
    #
922
    Debug ("Pid: $pid");
923
    Error ("Can't run command: $!") unless $pid;
924
 
925
    #
926
    #   Close the input handle
927
    #   We don't have anything to send to this program
928
    #
929
    close(CHLD_IN);
930
 
931
    #
932
    #   Monitor the output from the utility
271 dpurdie 933
    #   Have used stdmux to multiplex stdout and stderr
267 dpurdie 934
    #
935
    #   Note: IO::Select doesn't work on Windows :(
271 dpurdie 936
    #   Note: Open3 will cause blocking unless both streams are read
937
    #         Can read both streams becsue IO::Select doesn't work
267 dpurdie 938
    #
939
    #   Observation:
940
    #       svn puts errors to STDERR
941
    #       svn puts status to STDOUT
942
    #
943
    while (<CHLD_OUT>)
944
    {
945
        s~\s+$~~;
946
        tr~\\/~/~;
947
 
379 dpurdie 948
 
271 dpurdie 949
        Verbose3 ( "SvnCmd:" . $_);
950
        m~^STD(...):(.+)~;
951
        my $data = $1 ? $2 : $_;
952
        next unless ( $data );
953
 
954
        if ( $1 && $1 eq 'ERR' )
267 dpurdie 955
        {
271 dpurdie 956
            #
957
            #   Process STDERR output
958
            #
959
            push @{$self->{ERROR_LIST}}, $data;
267 dpurdie 960
        }
271 dpurdie 961
        else
962
        {
963
            #
964
            #   Process STDOUT data
965
            #
966
            push @{$self->{RESULT_LIST}}, $data unless ($opt->{'nosavedata'});
967
 
968
            #
969
            #   If the user has specified a processing function then pass each
970
            #   line to the specified function.  A non-zero return will
971
            #   be taken as a signal to kill the command.
972
            #
973
            if ( exists ($opt->{'process'}) && $opt->{'process'}($self, $data) )
974
            {
975
                kill 9, $pid;
976
                last;
977
            }
978
        }
267 dpurdie 979
    }
980
 
981
    close(CHLD_OUT);
982
 
983
    #
984
    #   MUST wait for the process
985
    #   Under Windows if this is not done then we eventually fill up some
986
    #   perl-internal structure and can't spawn anymore processes.
987
    #
988
    my $rv = waitpid ( $pid, 0);
989
 
990
    #
991
    #   If an error condition was detected and the user has provided
992
    #   an error message, then display the error
993
    #
994
    #   This simplifies the user error processing
995
    #
996
    if ( @{$self->{ERROR_LIST}} && $opt->{'error'}  )
997
    {
998
        Error ( $opt->{'error'}, @{$self->{ERROR_LIST}} );
999
    }
1000
 
1001
    #
1002
    #   Exit status has no meaning since open3 has been used
1003
    #   This is because perl does not treat the opened process as a child
1004
    #   Not too sure it makes any difference anyway
1005
    #
1006
    #
1007
    Debug ("Useless Exit Status: $rv");
1008
    my $result = @{$self->{ERROR_LIST}} ? 1 : 0;
1009
    Verbose3 ("Exit Code: $result");
1010
 
1403 dpurdie 1011
    $self->{PRINTDATA} = $savedPrintData;
267 dpurdie 1012
    return $result;
1013
}
1014
 
271 dpurdie 1015
 
267 dpurdie 1016
#-------------------------------------------------------------------------------
1017
# Function        : SvnUserCmd
1018
#
1019
# Description     : Run a Subversion Command for interactive user
1020
#                   Intended to be used interactive
1021
#                   No data captured or processed
1022
#                   See also SvnCmd
1023
#
1024
# Inputs          : Command arguments
1025
#                   Last argument may be a hash of options.
1026
#                       credentials - Add credentials
1027
#
1028
# Returns         : Result code of the SVN command
1029
#
1030
sub SvnUserCmd
1031
{
1032
    #
1033
    #   Extract arguments and options
1403 dpurdie 1034
    #   If last argument is a hash, then its a hash of options
267 dpurdie 1035
    #
1036
    my $opt;
1037
    $opt = pop @_
1038
        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));
1039
 
1040
    Verbose2 "SvnUserCmd $svn @_";
365 dpurdie 1041
 
267 dpurdie 1042
    #
365 dpurdie 1043
    #   Delayed error reporting
1044
    #   Allows the the package to be used when SVN is not installed
1045
    #   as long as we don't want to use any of the features
1046
    #
1047
    #   Think of 'help' when svn is not yet installed
1048
    #
1049
    Error ("The JATS stdmux utility cannot be found" ) unless ( $stdmux );
1050
    Error ("The svn utility cannot be found", "Configured Path: $::GBE_SVN_PATH") unless ( $svn );
1051
 
1052
    #
267 dpurdie 1053
    #   Prepend credentials, but don't show to users
1054
    #
1055
    unshift @_, SvnCredentials() if ( $opt->{'credentials'} );
1056
 
1057
 
1058
    #
1059
    #   Run the command
1060
    #
1061
    my $rv = system( $svn, @_ );
1062
    Verbose2 "System Result Code: $rv";
1063
    Verbose2 "System Result Code: $!" if ($rv);
1064
 
1065
     return $rv / 256;
1066
}
1067
 
1068
#------------------------------------------------------------------------------
1069
1;
363 dpurdie 1070