File Coverage

blib/lib/LCFG/Build/VCS/CVS.pm
Criterion Covered Total %
statement 32 192 16.6
branch 0 90 0.0
condition 0 3 0.0
subroutine 11 23 47.8
pod 7 9 77.7
total 50 317 15.7


line stmt bran cond sub pod time code
1             package LCFG::Build::VCS::CVS; # -*-perl-*-
2 1     1   777 use strict;
  1         3  
  1         28  
3 1     1   5 use warnings;
  1         2  
  1         39  
4              
5             # $Id: CVS.pm.in 35424 2019-01-18 10:01:16Z squinney@INF.ED.AC.UK $
6             # $Source: /var/cvs/dice/LCFG-Build-VCS/lib/LCFG/Build/VCS/CVS.pm.in,v $
7             # $Revision: 35424 $
8             # $HeadURL: https://svn.lcfg.org/svn/source/tags/LCFG-Build-VCS/LCFG_Build_VCS_0_3_9/lib/LCFG/Build/VCS/CVS.pm.in $
9             # $Date: 2019-01-18 10:01:16 +0000 (Fri, 18 Jan 2019) $
10              
11             our $VERSION = '0.3.9';
12              
13 1     1   11 use v5.10;
  1         3  
14              
15 1     1   7 use Cwd ();
  1         2  
  1         15  
16 1     1   4 use File::Find ();
  1         7  
  1         23  
17 1     1   5 use File::Path ();
  1         2  
  1         19  
18 1     1   5 use File::Spec ();
  1         2  
  1         19  
19 1     1   445 use IO::File qw(O_WRONLY O_CREAT O_NONBLOCK O_NOCTTY);
  1         8111  
  1         71  
20 1     1   493 use Try::Tiny;
  1         1934  
  1         56  
21              
22 1     1   572 use Moose;
  1         462061  
  1         8  
23             with 'LCFG::Build::VCS';
24              
25             has '+binpath' => ( default => 'cvs' );
26              
27             has 'root' => (
28             is => 'rw',
29             isa => 'Str',
30             lazy => 1,
31             default => sub { _get_root(@_) },
32             );
33              
34             has '+id' => ( default => 'CVS' );
35              
36             # This should give a speed-up in loading
37              
38 1     1   7618 no Moose;
  1         3  
  1         6  
39             __PACKAGE__->meta->make_immutable;
40              
41             sub auto_detect {
42 0     0 1   my ( $class, $dir ) = @_;
43              
44 0           my $rootfile = File::Spec->catfile( $dir, 'CVS', 'Root' );
45 0 0         my $is_cvs = -f $rootfile ? 1 : 0;
46              
47 0           return $is_cvs;
48             }
49              
50             sub build_cmd {
51 0     0 0   my ( $self, @args ) = @_;
52              
53 0           my @cmd = ( $self->binpath, '-d', $self->root );
54 0 0         if ( $self->quiet ) {
55 0           push @cmd, '-Q';
56             }
57 0           push @cmd, @args;
58              
59 0           return @cmd;
60             }
61              
62             sub _get_root {
63 0     0     my ($self) = @_;
64              
65 0           my $root;
66              
67 0           my $rootfile = File::Spec->catfile( $self->workdir, 'CVS', 'Root' );
68 0 0         if ( -f $rootfile ) {
69 0           eval {
70 0           my $fh = IO::File->new( $rootfile, 'r' );
71 0           chomp( $root = $fh->getline );
72 0           $fh->close;
73             };
74             }
75              
76 0 0         if ( !$root ) {
77 0           $root = $ENV{CVSROOT};
78             }
79              
80 0           return $root;
81             }
82              
83             sub genchangelog {
84 0     0 1   my ($self) = @_;
85              
86 0           my $dir = $self->workdir;
87 0           my $logfile = $self->logfile;
88              
89 0           my $orig_dir = Cwd::abs_path();
90 0 0         chdir $dir or die "gen: Could not access directory, $dir: $!\n";
91              
92 0 0         if ( !-e $logfile ) {
93              
94             # This bit borrowed from File::Touch
95 0 0         sysopen my $fh, $logfile, O_WRONLY | O_CREAT | O_NONBLOCK | O_NOCTTY
96             or die "Cannot create $logfile : $!\n";
97 0 0         $fh->close or die "Cannot close $logfile : $!\n";
98              
99             # Assume it is not already part of the repository
100 0           $self->run_cmd( 'add', $logfile );
101             }
102              
103 0           my $cmd = 'cvs2cl --hide-filenames --accum --file ' . $logfile;
104              
105 0 0         if ( $self->quiet ) {
106 0           $cmd .= ' --global-opts \'-Q\'';
107             }
108              
109             # This requires a full shell to actually work, I think the cvs
110             # command is the root cause.
111              
112 0 0         if ( $self->dryrun ) {
113 0           print "Dry-run: $cmd\n";
114             }
115             else {
116 0           system $cmd;
117 0 0         if ( $? != 0 ) {
118 0           die "Could not run cvs2cl: $!\n";
119             }
120             }
121              
122 0 0         chdir $orig_dir
123             or die "Could not return to original directory, $orig_dir: $!\n";
124              
125 0           return;
126             }
127              
128             sub checkcommitted {
129 0     0 1   my ($self) = @_;
130              
131 0           my $orig_dir = Cwd::abs_path();
132              
133 0           my $dir = $self->workdir;
134 0 0         chdir $dir or die "check: Could not access directory, $dir: $!\n";
135              
136 0           my @status = $self->run_cmd('status');
137              
138 0           my @notcommitted;
139 0           for my $line (@status) {
140 0 0         if ( $line =~ m/^File: (.+?)\s+Status: (.+)$/ ) {
141 0           my ( $file, $status ) = ( $1, $2 );
142 0 0         if ( $status !~ m/Up-to-date/ ) {
143 0           push @notcommitted, $file;
144             }
145             }
146             }
147              
148 0 0         chdir $orig_dir
149             or die "Could not return to original directory, $orig_dir: $!\n";
150              
151 0           my $allcommitted;
152 0 0         if ( scalar @notcommitted > 0 ) {
153 0           $allcommitted = 0;
154             }
155             else {
156 0           $allcommitted = 1;
157             }
158              
159 0 0         if (wantarray) {
160 0           return ( $allcommitted, @notcommitted );
161             }
162             else {
163 0           return $allcommitted;
164             }
165             }
166              
167             sub tagversion {
168 0     0 1   my ( $self, $version ) = @_;
169              
170 0           $self->update_changelog($version);
171              
172 0           my $tag = $self->gen_tag($version);
173              
174 0           my $orig_dir = Cwd::abs_path();
175              
176 0           my $dir = $self->workdir;
177 0 0         chdir $dir or die "tag: Could not access directory, $dir: $!\n";
178              
179 0           eval { $self->run_cmd( 'commit', '-m', "Release: $version" ) };
  0            
180 0 0         if ($@) {
181 0           die "Could not mark release for $dir at $version\n";
182             }
183              
184 0           eval { $self->run_cmd( 'tag', '-F', '-c', $tag ) };
  0            
185 0 0         if ($@) {
186 0           die "Could not tag $dir with $tag\n";
187             }
188              
189 0           eval { $self->run_cmd( 'tag', '-F', '-c', 'latest' ) };
  0            
190 0 0         if ($@) {
191 0           die "Could not tag $dir as latest\n";
192             }
193              
194 0 0         chdir $orig_dir
195             or die "Could not return to original directory, $orig_dir: $!\n";
196              
197 0           return;
198             }
199              
200             sub _process_cvs_entries {
201 0     0     my ( $workdir, $entries ) = @_;
202              
203 0           my $path = $File::Find::name;
204              
205 0 0         if ( -f $path ) {
206 0           my ( $vol, $dirname, $basename ) = File::Spec->splitpath($path);
207 0           my @dirs = File::Spec->splitdir($dirname);
208              
209             # If the last element of the directory list is empty throw it away
210 0 0         if ( length $dirs[-1] == 0 ) {
211 0           pop @dirs;
212             }
213              
214 0 0 0       if ( $dirs[-1] eq 'CVS' && $basename eq 'Entries' ) {
215 0           pop @dirs; # remove the 'CVS' directory
216              
217             # This is a (hopefully) system-independent way of removing
218             # the working directory from the front of the current
219             # directory name to produce relative filenames.
220              
221 0           for ( my $i=0; $i<scalar(@{$workdir}); $i++) {
  0            
222 0 0         if ( $dirs[0] eq $workdir->[$i] ) {
223 0           shift @dirs;
224             }
225             else {
226 0           last;
227             }
228             }
229              
230 0           my $dir = File::Spec->catdir(@dirs);
231              
232 0 0         my $fh = IO::File->new( $path, 'r' )
233             or die "Could not open $path for reading: $!\n";
234 0           while ( defined( my $entry = $fh->getline ) ) {
235              
236 0 0         if ( $entry =~ m{^/ # Line starts with a forward slash
237             ([^/]+) # Stuff which is not a forward slash
238             / # Another forward slash
239             \d # Any digit (avoids deleted files)
240             }x ) {
241 0           push @{$entries}, [ $dir, $1 ];
  0            
242             }
243             }
244 0           $fh->close;
245             }
246             }
247              
248 0           return;
249             }
250              
251             sub export_devel {
252 0     0 1   my ( $self, $version, $builddir ) = @_;
253              
254 0           my $workdir = $self->workdir;
255 0           my $target = join q{-}, $self->module, $version;
256              
257 0           my $exportdir = File::Spec->catdir( $builddir, $target );
258              
259 0 0         if ( !$self->dryrun ) {
260 0           File::Path::rmtree($exportdir);
261 0           eval { File::Path::mkpath($exportdir) };
  0            
262 0 0         if ($@) {
263 0           die "Could not create $exportdir: $@\n";
264             }
265             }
266              
267 0           my @workdir = File::Spec->splitdir($workdir);
268             # If the last element of the directory list is empty throw it away
269 0 0         if ( length $workdir[-1] == 0 ) {
270 0           pop @workdir;
271             }
272              
273 0           my @entries;
274             File::Find::find(
275 0     0     { wanted => sub { _process_cvs_entries( \@workdir, \@entries ) },
276 0           no_chdir => 1,
277             },
278             $workdir
279             );
280              
281 0           for my $entry (@entries) {
282 0           $self->mirror_file( $workdir, $exportdir, @{$entry} );
  0            
283             }
284              
285 0           return $exportdir;
286             }
287              
288             sub export {
289 0     0 1   my ( $self, $version, $builddir ) = @_;
290              
291 0           my $tag = $self->gen_tag($version);
292              
293 0           my $target = join q{-}, $self->module, $version;
294 0           my $exportdir = File::Spec->catdir( $builddir, $target );
295              
296 0 0         if ( !$self->dryrun ) {
297 0 0         if ( !-d $builddir ) {
298 0           eval { File::Path::mkpath($builddir) };
  0            
299 0 0         if ($@) {
300 0           die "Could not create $builddir: $@\n";
301             }
302             }
303              
304 0 0         if ( -d $exportdir ) {
305 0           File::Path::rmtree($exportdir);
306             }
307             }
308              
309 0           my $orig_dir = Cwd::abs_path();
310              
311 0 0         chdir $builddir
312             or die "export: Could not access directory, $builddir: $!\n";
313              
314 0           $self->run_cmd( 'export', '-r', $tag, '-d', $target, $self->module );
315              
316 0 0         chdir $orig_dir
317             or die "Could not return to original directory, $orig_dir: $!\n";
318              
319 0           return $exportdir;
320             }
321              
322             sub checkout_project {
323 0     0 0   my ( $self, $version, $outdir ) = @_;
324              
325 0 0         if ( !defined $outdir ) {
326 0           $outdir = '.';
327             }
328              
329 0           my @args;
330 0 0         if ( defined $version ) {
331 0           my $tag = $self->gen_tag($version);
332              
333 0           @args = ( 'r', $tag );
334             }
335              
336 0           my $orig_dir = Cwd::abs_path();
337              
338 0 0         chdir $outdir or die "tag: Could not access directory, $outdir: $!\n";
339              
340 0           $self->run_cmd( 'checkout', @args, $self->module );
341              
342 0 0         chdir $orig_dir
343             or die "Could not return to original directory, $orig_dir: $!\n";
344              
345 0           return;
346             }
347              
348             sub import_project {
349 0     0 1   my ( $self, $dir, $version, $message ) = @_;
350              
351 0 0         if ( !defined $message ) {
352 0           $message = 'Imported with LCFG build tools';
353             }
354              
355 0           my $vendor_tag = $self->gen_tag();
356 0           my $release_tag = $self->gen_tag($version);
357              
358 0           my $orig_dir = Cwd::abs_path();
359              
360 0 0         chdir $dir or die "tag: Could not access directory, $dir: $!\n";
361              
362 0           $self->run_cmd( 'import',
363             '-I', '!',
364             '-m', $message,
365             $self->module, $vendor_tag, $release_tag );
366              
367 0 0         chdir $orig_dir
368             or die "Could not return to original directory, $orig_dir: $!\n";
369              
370 0           return;
371             }
372              
373             1;
374             __END__
375              
376             =head1 NAME
377              
378             LCFG::Build::VCS::CVS - LCFG build tools for CVS version-control
379              
380             =head1 VERSION
381              
382             This documentation refers to LCFG::Build::VCS::CVS version 0.3.9
383              
384             =head1 SYNOPSIS
385              
386             my $dir = ".";
387              
388             my $spec = LCFG::Build::PkgSpec->new_from_metafile("$dir/lcfg.yml");
389              
390             my $vcs = LCFG::Build::VCS::CVS->new( module => $spec->fullname,
391             workdir => $dir );
392              
393             $vcs->genchangelog();
394              
395             if ( $vcs->checkcommitted() ) {
396             $vcs->tagversion();
397             }
398              
399             =head1 DESCRIPTION
400              
401             This is part of a suite of tools designed to provide a standardised
402             interface to version-control systems so that the LCFG build tools can
403             deal with project version-control in a high-level abstract fashion.
404              
405             This module implements the interface specified by
406             L<LCFG::Build::VCS>. It provides support for LCFG projects which use
407             the CVS version-control system. Facilities are available for
408             procedures such as importing and exporting projects, doing tagged
409             releases, generating the project changelog from the version-control
410             log and checking all changes are committed.
411              
412             More information on the LCFG build tools is available from the website
413             http://www.lcfg.org/doc/buildtools/
414              
415             =head1 ATTRIBUTES
416              
417             =over
418              
419             =item module
420              
421             The name of the software package in this repository. This is required
422             and there is no default value.
423              
424             =item workdir
425              
426             The directory in which the CVS commands should be carried out. This is
427             required and if none is specified then it will default to '.', the
428             current working directory. This must be an absolute path but if you
429             pass in a relative path coercion will automatically occur based on the
430             current working directory.
431              
432             =item binpath
433              
434             The name of the CVS executable, by default this is C<cvs>.
435              
436             =item root
437              
438             This is the CVS root. If not specified the module will attempt to
439             discover the right thing to use the first time you call the
440             accessor. It will look into the CVS/Root file in the working directory
441             for the project or if that fails use the CVSROOT environment variable.
442              
443             =item quiet
444              
445             This is a boolean value which controls the quietness of the CVS
446             commands. By default it is false and commands, such as CVS, will print
447             lots of extra stuff to the screen. If it is set to true the -Q option
448             will be passed to the CVS binary whenever a command is executed. The
449             cvs2cl(1) command used when automatically generating change log files
450             will also honour this option.
451              
452             =item dryrun
453              
454             This is a boolean value which controls whether the commands will
455             actually have a real effect or just print out what would be done. By
456             default it is false.
457              
458             =item logname
459              
460             The name of the logfile to which information should be directed when
461             doing version updates. This is also the name of the logfile to be used
462             if you utilise the automatic changelog generation option. The default
463             file name is 'ChangeLog'.
464              
465             =back
466              
467             =head1 SUBROUTINES/METHODS
468              
469             The following class methods are available:
470              
471             =over
472              
473             =item new
474              
475             Creates a new instance of the class.
476              
477             =item auto_detect($dir)
478              
479             This method returns a boolean value which indicates whether or not the
480             specified directory is part of a checked out working copy of a
481             CVS repository.
482              
483             =back
484              
485             The following instance methods are available:
486              
487             =over
488              
489             =item checkcommitted()
490              
491             Test to see if there are any uncommitted files in the project
492             directory. Note this test does not spot files which have not been
493             added to the version-control system. In scalar context the subroutine
494             returns 1 if all files are committed and 0 (zero) otherwise. In list
495             context the subroutine will return this code along with a list of any
496             files which require committing.
497              
498             =item genchangelog()
499              
500             This method will generate a changelog (the name of which is controlled
501             by the logname attribute) from the log kept within the version-control
502             system. For CVS the cvs2cl(1) command is used.
503              
504             =item tagversion($version)
505              
506             This method is used to tag a set of files for a project at a
507             particular version. It will also update the changelog
508             appropriately. Tags are generated using the I<gen_tag()> method, see
509             below for details.
510              
511             =item gen_tag($version)
512              
513             Tags are generated from the name and version details passed in by
514             replacing any hyphens or dots with underscores and joining the two
515             fields with an underscore. For example, lcfg-foo and 1.0.1 would
516             become lcfg_foo_1_0_1.
517              
518             =item run_cmd(@args)
519              
520             A method used to handle the running of commands for the particular
521             version-control system. This is required for systems like CVS where
522             shell commands have to be executed. Not all modules will need to
523             implement this method as they may well use a proper Perl module API
524             (e.g. subversion).
525              
526             =item export( $version, $builddir )
527              
528             This will export a particular tagged version of the module. You need
529             to specify the target "build" directory into which the exported tree
530             will be put. The exported tree will be named like
531             "modulename-version". For example:
532              
533             my $vcs = LCFG::Build::VCS::CVS->new(module => "lcfg-foo");
534             $vcs->export( "1.2.3", "/tmp" );
535              
536             Would give you an exported tree of code for the lcfg-foo module tagged
537             as lcfg_foo_1_2_3 and it would be put into /tmp/lcfg-foo-1.2.3/
538              
539             Returns the name of the directory into which the tree was exported.
540              
541             =item export_devel( $version, $builddir )
542              
543             This is similar to the export method. It takes the current working
544             tree for a module and exports it directly to another tree based in the
545             specified target "build" directory. This method copies over everything
546             except the special CVS directories. For example:
547              
548             my $vcs = LCFG::Build::VCS::CVS->new(module => "lcfg-foo");
549             $vcs->export_devel( "1.2.3_dev", "/tmp" );
550              
551             Would give you an exported tree of code for the lcfg-foo module
552             directory and it would be put into /tmp/lcfg-foo-1.2.3_dev/
553              
554             Returns the name of the directory into which the tree was exported.
555              
556             =item import_project( $dir, $version, $message )
557              
558             Imports a project source tree into the version-control system. You
559             need to specify the version for the initial tag. Optionally you can
560             specify a message which will be used.
561              
562             =item logfile()
563              
564             This is a convenience method which returns the full path to the
565             logfile based on the workdir and logname attributes.
566              
567             =back
568              
569             =head1 DEPENDENCIES
570              
571             This module is L<Moose> powered and it depends on
572             L<LCFG::Build::VCS>. You will need a working C<cvs> executable
573             somewhere on your system and a CVS repository for this module to be in
574             anyway useful.
575              
576             =head1 SEE ALSO
577              
578             L<LCFG::Build::PkgSpec>, L<LCFG::Build::VCS::None>,
579             L<LCFG::Build::VCS::SVN>, L<LCFG::Build::Tools>
580              
581             =head1 PLATFORMS
582              
583             This is the list of platforms on which we have tested this
584             software. We expect this software to work on any Unix-like platform
585             which is supported by Perl.
586              
587             FedoraCore5, FedoraCore6, ScientificLinux5
588              
589             =head1 BUGS AND LIMITATIONS
590              
591             There are no known bugs in this application. Please report any
592             problems to bugs@lcfg.org, feedback and patches are also always very
593             welcome.
594              
595             =head1 AUTHOR
596              
597             Stephen Quinney <squinney@inf.ed.ac.uk>
598              
599             =head1 LICENSE AND COPYRIGHT
600              
601             Copyright (C) 2008-2013 University of Edinburgh. All rights reserved.
602              
603             This library is free software; you can redistribute it and/or modify
604             it under the terms of the GPL, version 2 or later.
605              
606             =cut