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