File Coverage

blib/lib/Test/Smoke/Syncer/Snapshot.pm
Criterion Covered Total %
statement 182 271 67.1
branch 64 156 41.0
condition 15 47 31.9
subroutine 18 20 90.0
pod 2 2 100.0
total 281 496 56.6


line stmt bran cond sub pod time code
1             package Test::Smoke::Syncer::Snapshot;
2 11     11   88 use warnings;
  11         21  
  11         409  
3 11     11   62 use strict;
  11         23  
  11         436  
4              
5             our $VERSION = '0.029';
6              
7 11     11   78 use base 'Test::Smoke::Syncer::Base';
  11         27  
  11         1151  
8              
9             =head1 Test::Smoke::Syncer::Snapshot
10              
11             This handles syncing from a snapshot with the B module.
12             It should only be visible from the "parent-package" so no direct
13             user-calls on this.
14              
15             =cut
16              
17 11     11   78 use Cwd;
  11         39  
  11         782  
18 11     11   87 use File::Path;
  11         44  
  11         983  
19 11     11   89 use Test::Smoke::Util qw( whereis clean_filename );
  11         37  
  11         42415  
20              
21             =head2 Test::Smoke::Syncer::Snapshot->new( %args )
22              
23             This crates the new object. Keys for C<%args>:
24              
25             * ddir: destination directory ( ./perl-current )
26             * server: the server to get the snapshot from ( public.activestate.com )
27             * sdir: server directory ( /pub/apc/perl-current-snap )
28             * snapext: the extension used for snapdhots ( tgz )
29             * tar: howto untar ( Archive::Tar or 'gzip -d -c %s | tar x -' )
30             * v: verbose
31              
32             =cut
33              
34             =head2 $syncer->sync( )
35              
36             Make a connection to the ftp server, change to the {sdir} directory.
37             Get the list of snapshots (C<< /^perl@\d+\.tgz$/ >>) and determin the
38             highest patchlevel. Fetch this file. Remove the current source-tree
39             and extract the snapshot.
40              
41             =cut
42              
43             sub sync {
44 2     2 1 1978 my $self = shift;
45              
46 2         39 $self->pre_sync;
47             # we need to have {ddir} before we can save the snapshot
48 2 100       329 -d $self->{ddir} or mkpath( $self->{ddir} );
49              
50 2 50       29 $self->{snapshot} = $self->_fetch_snapshot or return undef;
51              
52 2         27 $self->_clear_source_tree;
53              
54 2         24 $self->_extract_snapshot;
55              
56 2 50       77 $self->patch_a_snapshot if $self->{patchup};
57              
58 2         48 my $plevel = $self->check_dot_patch;
59 2         59 $self->post_sync;
60 2         33 return $plevel;
61             }
62              
63             =head2 $syncer->_fetch_snapshot( )
64              
65             C<_fetch_snapshot()> checks to see if
66             C<< S<< $self->{server} =~ m|^https?://| >> && $self->{sfile} >>.
67             If so let B do the fetching else do the FTP thing.
68              
69             =cut
70              
71             sub _fetch_snapshot {
72 2     2   9 my $self = shift;
73              
74 2 50       28 return $self->_fetch_snapshot_HTTP if $self->{server} =~ m|^https?://|i;
75              
76 2         33 require Net::FTP;
77 2 50       69 my $ftp = Net::FTP->new($self->{server}, Debug => 0, Passive => 1) or do {
78 0         0 require Carp;
79 0         0 Carp::carp( "[Net::FTP] Can't open $self->{server}: $@" );
80 0         0 return undef;
81             };
82              
83 2         66 my @login = ( $self->{ftpusr}, $self->{ftppwd} );
84 2 50       37 $ftp->login( @login ) or do {
85 0         0 require Carp;
86 0         0 Carp::carp( "[Net:FTP] Can't login( @login )" );
87 0         0 return undef;
88             };
89              
90 2 50       27 $self->{v} and print "Connected to $self->{server}\n";
91 2 50       35 $ftp->cwd( $self->{sdir} ) or do {
92 0         0 require Carp;
93 0         0 Carp::carp( "[Net::FTP] Can't chdir '$self->{sdir}'" );
94 0         0 return undef;
95             };
96              
97             my $snap_name = $self->{sfile} ||
98 2   33     188 __find_snap_name( $ftp, $self->{snapext}, $self->{v} );
99              
100 2 50       10 unless ( $snap_name ) {
101 0         0 require Carp;
102 0         0 Carp::carp("Couldn't find a snapshot at $self->{server}$self->{sdir}");
103 0         0 return undef;
104             }
105              
106 2         31 $ftp->binary(); # before you ask for size!
107 2         36 my $snap_size = $ftp->size( $snap_name );
108 2 50       140 my $ddir_var = $self->{vms_ddir} ? 'vms_ddir' : 'ddir';
109 2         60 my $local_snap = File::Spec->catfile( $self->{ $ddir_var },
110             File::Spec->updir,
111             clean_filename( $snap_name ) );
112 2         19 $local_snap = File::Spec->canonpath( $local_snap );
113              
114 2 50 33     47 if ( -f $local_snap && $snap_size == -s $local_snap ) {
115 0 0       0 $self->{v} and print "Skipping download of '$snap_name'\n";
116             } else {
117 2 50       14 $self->{v} and print "get ftp://$self->{server}$self->{sdir}/" .
118             "$snap_name\n as $local_snap ";
119 2         42 my $l_file = $ftp->get( $snap_name, $local_snap );
120 2   33     663 my $ok = $l_file eq $local_snap && $snap_size == -s $local_snap;
121 2 50 0     18 $ok or printf "Error in get(%s) [%d]\n", $l_file || "",
122             (-s $local_snap);
123 2 50 33     24 $ok && $self->{v} and print "[$snap_size] OK\n";
124             }
125 2         15 $ftp->quit;
126              
127 2         39 return $local_snap;
128             }
129              
130             =head2 $syncer->_fetch_snapshot_HTTP( )
131              
132             C<_fetch_snapshot_HTTP()> simply invokes C<< LWP::Simple::mirror() >>.
133              
134             =cut
135              
136             sub _fetch_snapshot_HTTP {
137 0     0   0 my $self = shift;
138              
139 0         0 require LWP::Simple;
140             my $snap_name = $self->{server} eq 'http://github.com/Perl'
141             ? 'perl-current.tar.gz'
142 0 0       0 : $self->{sfile};
143              
144 0 0       0 print "$self->{server}/$self->{sdir} => $snap_name\n" if $self->{v} > 1;
145 0 0       0 unless ( $snap_name ) {
146 0         0 require Carp;
147 0         0 Carp::carp( "No snapshot specified for $self->{server}$self->{sdir}" );
148 0         0 return undef;
149             }
150              
151             my $local_snap = File::Spec->catfile( $self->{ddir},
152 0         0 File::Spec->updir, $snap_name );
153 0         0 $local_snap = File::Spec->canonpath( $local_snap );
154              
155 0         0 my $remote_snap = "$self->{server}$self->{sdir}/$self->{sfile}";
156              
157 0 0       0 $self->{v} and print "LWP::Simple::mirror($remote_snap)";
158 0         0 my $result = LWP::Simple::mirror( $remote_snap, $local_snap );
159 0 0       0 if ( LWP::Simple::is_success( $result ) ) {
    0          
160 0 0       0 $self->{v} and print " OK\n";
161 0         0 return $local_snap;
162             } elsif ( LWP::Simple::is_error( $result ) ) {
163 0 0       0 $self->{v} and print " not OK\n";
164 0         0 return undef;
165             } else {
166 0 0       0 $self->{v} and print " skipped\n";
167 0         0 return $local_snap;
168             }
169             }
170              
171             =head2 __find_snap_name( $ftp, $snapext[, $verbose] )
172              
173             [Not a method!]
174              
175             Get a list with all the B files, use an ST to sort these and
176             return the one with the highes number.
177              
178             =cut
179              
180             sub __find_snap_name {
181 2     2   14 my( $ftp, $snapext, $verbose ) = @_;
182 2   50     9 $snapext ||= 'tgz';
183 2   50     35 $verbose ||= 0;
184 2 50       10 $verbose > 1 and print "Looking for /$snapext\$/\n";
185              
186 2         21 my @list = $ftp->ls();
187              
188 2         25 my $snap_name = ( map $_->[0], sort { $a->[1] <=> $b->[1] } map {
189 4         60 my( $p_level ) = /^perl[@#_](\d+)/;
190 4 50       39 $verbose > 1 and print "Kept: $_ ($p_level)\n";
191 4         33 [ $_, $p_level ]
192             } grep {
193 4 50       134 /^perl[@#_]\d+/ &&
194             /$snapext$/
195 2 50       303 } map { $verbose > 1 and print "Found snapname: $_\n"; $_ } @list )[-1];
  4         39  
  4         16  
196              
197 2         23 return $snap_name;
198             }
199              
200             =head2 $syncer->_extract_snapshot( )
201              
202             C<_extract_snapshot()> checks the B attribute to find out how to
203             extract the snapshot. This could be an external command or the
204             B/B modules.
205              
206             =cut
207              
208             sub _extract_snapshot {
209 2     2   6 my $self = shift;
210              
211 2 50 33     56 unless ( $self->{snapshot} && -f $self->{snapshot} ) {
212 0         0 require Carp;
213 0         0 Carp::carp( "No snapshot to be extracted!" );
214 0         0 return undef;
215             }
216              
217 2         10997 my $cwd = cwd();
218              
219             # Files in the snapshot are relative to the 'perl/' directory,
220             # they may need to be moved and that is not easy when you've
221             # extracted them in the target directory! so we go updir()
222 2 50       79 my $ddir = $^O eq 'VMS' ? $self->{vms_ddir} : $self->{ddir};
223 2         90 my $extract_base = File::Spec->catdir( $ddir, File::Spec->updir );
224 2 50       47 chdir $extract_base or do {
225 0         0 require Carp;
226 0         0 Carp::croak( "Can't chdir '$extract_base': $!" );
227             };
228              
229 2         10 my $snap_base;
230             EXTRACT: {
231 2   50     124 local $_ = $self->{tar} || 'Archive::Tar';
  2         25  
232              
233 2 100       34 /^Archive::Tar$/ && do {
234 1         13 $snap_base = $self->_extract_with_Archive_Tar;
235 1         19 last EXTRACT;
236             };
237              
238             # assume a commandline template for $self->{tar}
239 1         38 $snap_base = $self->_extract_with_external;
240             }
241              
242 2         139 $self->_relocate_tree( $snap_base );
243              
244 2 50       44 chdir $cwd or do {
245 0         0 require Carp;
246 0         0 Carp::croak( "Can't chdir($extract_base) back: $!" );
247             };
248              
249 2 50       23 if ( $self->{cleanup} & 1 ) {
250 2         243 1 while unlink $self->{snapshot};
251             }
252             }
253              
254             =head2 $syncer->_extract_with_Archive_Tar( )
255              
256             C<_extract_with_Archive_Tar()> uses the B and
257             B modules to extract the snapshot.
258             (This tested verry slow on my Linux box!)
259              
260             =cut
261              
262             sub _extract_with_Archive_Tar {
263 1     1   10 my $self = shift;
264              
265 1         19 require Archive::Tar;
266              
267 1 50       28 my $archive = Archive::Tar->new() or do {
268 0         0 require Carp;
269 0         0 Carp::carp( "Can't Archive::Tar->new: " . $Archive::Tar::error );
270 0         0 return undef;
271             };
272              
273 1 50       54 $self->{v} and printf "Extracting '$self->{snapshot}' (%s) ", cwd();
274 1         14 $archive->read( $self->{snapshot}, 1 );
275 1 50       12024 $Archive::Tar::error and do {
276 0         0 require Carp;
277 0         0 Carp::carp("Error reading '$self->{snapshot}': ".$Archive::Tar::error);
278 0         0 return undef;
279             };
280 1         11 my @files = $archive->list_files;
281 1         206 $archive->extract( @files );
282 1 50       10593 $self->{v} and printf "%d items OK.\n", scalar @files;
283              
284 1         32 ( my $prefix = $files[0] ) =~ s|^([^/]+).+$|$1|;
285 1         5183 my $base_dir = File::Spec->canonpath(File::Spec->catdir( cwd(), $prefix ));
286 1 50       37 $self->{v} and print "Snapshot prefix: '$base_dir'\n";
287 1         229 return $base_dir;
288             }
289              
290             =head2 $syncer->_extract_with_external( )
291              
292             C<_extract_with_external()> uses C<< $self->{tar} >> as a sprintf()
293             template to build a command. Yes that might be dangerous!
294              
295             =cut
296              
297             sub _extract_with_external {
298 1     1   13 my $self = shift;
299              
300 1         32 my @dirs_pre = __get_directory_names();
301              
302 1 50       29 if ( $^O ne 'VMS' ) {
303 1         21 my $command = sprintf $self->{tar}, $self->{snapshot};
304 1 50       16 $command .= " $self->{snapshot}" if $command eq $self->{tar};
305              
306 1 50       10 $self->{v} and print "$command ";
307 1 50       13232 if ( system $command ) {
308 0         0 my $error = $? >> 8;
309 0         0 require Carp;
310 0         0 Carp::carp( "Error in command: $error" );
311 0         0 return undef;
312             };
313 1 50       45 $self->{v} and print "OK\n";
314             } else {
315 0         0 __vms_untargz( $self->{tar}, $self->{snapshot}, $self->{v} );
316             }
317              
318             # Yes another process can also create directories here!
319             # Be careful.
320 1         44 my %dirs_post = map { ($_ => 1) } __get_directory_names();
  4         78  
321             exists $dirs_post{ $_ } and delete $dirs_post{ $_ }
322 1   33     38 foreach @dirs_pre;
323             # I'll pick the first one that has 'perl' in it
324 1   33     57 my( $prefix ) = grep /\bperl/ || /perl\b/ => keys %dirs_post;
325 1 50       51 my $ddir = $^O eq 'VMS' ? $self->{vms_ddir} : $self->{ddir};
326 1   33     32 $prefix ||= File::Spec->abs2rel( $ddir, cwd() );
327              
328 1         6078 my $base_dir = File::Spec->canonpath(File::Spec->catdir( cwd(), $prefix ));
329 1 50       48 $self->{v} and print "Snapshot prefix: '$base_dir'\n";
330 1         105 return $base_dir;
331             }
332              
333             =head2 __vms_untargz( $untargz, $tgzfile, $verbose )
334              
335             Gunzip and extract the archive in C<$tgzfile> using a small DCL script
336              
337             =cut
338              
339             sub __vms_untargz {
340 0     0   0 my( $cmd, $file, $verbose ) = @_;
341 0         0 my( $gzip_cmd, $tar_cmd ) = split /\s*\|\s*/, $cmd;
342 0 0       0 my $gzip = $gzip_cmd =~ /^((?:MCR )?\S+)/ ? $1 : 'GZIP';
343 0 0 0     0 my $tar = $tar_cmd =~ /^((?:MCR )?\S+)/
344             ? $1 : (whereis( 'vmstar' ) || whereis( 'tar' ) );
345 0 0       0 my $tar_sw = $verbose ? '-xvf' : '-xf';
346              
347 0 0       0 $verbose and print "Writing 'TS-UNTGZ.COM'";
348 0         0 local *TMPCOM;
349 0 0       0 open TMPCOM, "> TS-UNTGZ.COM" or return 0;
350 0 0       0 print TMPCOM <
  0         0  
351             \$! TS-UNTGZ.COM - Generated by Test::Smoke::Syncer
352             \$ define/user sys\$output TS-UNTGZ.TAR
353             \$ $gzip "-cd" $file
354             \$ $tar $tar_sw TS-UNTGZ.TAR
355             \$ delete TS-UNTGZ.TAR;*
356             EO_UNTGZ
357 0 0       0 $verbose and print " OK\n";
358              
359 0         0 my $ret = system "\@TS-UNTGZ.COM";
360 0         0 1 while unlink "TS-UNTGZ.COM";
361              
362 0         0 return ! $ret;
363             }
364              
365             =head2 $syncer->patch_a_snapshot( $patch_number )
366              
367             C tries to fetch all the patches between
368             C<$patch_number> and C and apply them.
369             This requires a working B program.
370              
371             You should pass this extra information to
372             C<< Test::Smoke::Syncer::Snapshot->new() >>:
373              
374             * patchup: should we do this? ( 0 )
375             * pserver: which FTP server? ( public.activestate.com )
376             * pdir: directory ( /pub/apc/perl-current-diffs )
377             * unzip: ( gzip ) [ Compress::Zlib ]
378             * patchbin: ( patch )
379             * cleanup: remove patches after applied? ( 1 )
380              
381             =cut
382              
383             sub patch_a_snapshot {
384 2     2 1 4260 my( $self, $patch_number ) = @_;
385              
386 2   33     9 $patch_number ||= $self->check_dot_patch;
387              
388 2         37 my @patches = $self->_get_patches( $patch_number );
389              
390 2         11 $self->_apply_patches( @patches );
391              
392 2         79 return $self->check_dot_patch;
393             }
394              
395             =head2 $syncer->_get_patches( [$patch_number] )
396              
397             C<_get_patches()> sets up the FTP connection and gets all patches
398             beyond C<$patch_number>. Remember that patch numbers do not have to be
399             consecutive.
400              
401             =cut
402              
403             sub _get_patches {
404 2     2   19 my( $self, $patch_number ) = @_;
405              
406 2 50       78 my $ftp = Net::FTP->new($self->{pserver}, Debug => 0, Passive => 1) or do {
407 0         0 require Carp;
408 0         0 Carp::carp( "[Net::FTP] Can't open '$self->{pserver}': $@" );
409 0         0 return undef;
410             };
411              
412 2         56 my @user_info = ( $self->{ftpusr}, $self->{ftppwd} );
413 2 50       34 $ftp->login( @user_info ) or do {
414 0         0 require Carp;
415 0         0 Carp::carp( "[Net::FTP] Can't login( @user_info )" );
416 0         0 return undef;
417             };
418              
419 2 50       48 $ftp->cwd( $self->{pdir} ) or do {
420 0         0 require Carp;
421 0         0 Carp::carp( "[Net::FTP] Can't cd '$self->{pdir}'" );
422 0         0 return undef;
423             };
424              
425 2 50       105 $self->{v} and print "Connected to $self->{pserver}\n";
426 2         14 my @patch_list;
427              
428 2         41 $ftp->binary;
429 2         21 foreach my $entry ( $ftp->ls ) {
430 10 50       488 next unless $entry =~ /^(\d+)\.gz$/;
431 10         54 my $patch_num = $1;
432 10 100       40 next unless $patch_num > $patch_number;
433              
434             my $local_patch = File::Spec->catfile( $self->{ddir},
435 8         186 File::Spec->updir, $entry );
436 8         69 my $patch_size = $ftp->size( $entry );
437 8         471 my $l_file;
438 8 50 33     178 if ( -f $local_patch && -s $local_patch == $patch_size ) {
439 0 0       0 $self->{v} and print "Skip $entry $patch_size\n";
440 0         0 $l_file = $local_patch;
441             } else {
442 8 50       34 $self->{v} and print "get $entry ";
443 8         62 $l_file = $ftp->get( $entry, $local_patch );
444 8 50       2229 $self->{v} and printf "%d OK\n", -s $local_patch;
445             }
446 8 50       48 push @patch_list, $local_patch if $l_file;
447             }
448 2         20 $ftp->quit;
449              
450 10         36 @patch_list = map $_->[0] => sort { $a->[1] <=> $b->[1] } map {
451 2         11 my( $patch_num ) = /(\d+).gz$/;
  8         55  
452 8         40 [ $_, $patch_num ];
453             } @patch_list;
454              
455 2         18 return @patch_list;
456             }
457              
458             =head2 $syncer->_apply_patches( @patch_list )
459              
460             C<_apply_patches()> calls the B program to apply the patch
461             and updates B<.patch> accordingly.
462              
463             C<@patch_list> is a list of filenames of these patches.
464              
465             Checks the B attribute to find out how to unzip the patch and
466             uses the B module to apply the patch.
467              
468             =cut
469              
470             sub _apply_patches {
471 2     2   7 my( $self, @patch_list ) = @_;
472              
473 2         10465 my $cwd = cwd();
474 2 50       112 chdir $self->{ddir} or do {
475 0         0 require Carp;
476 0         0 Carp::croak( "Cannot chdir($self->{ddir}): $!" );
477             };
478              
479 2         64 require Test::Smoke::Patcher;
480 2         42 foreach my $file ( @patch_list ) {
481              
482 8 50       124 my $patch = $self->_read_patch( $file ) or next;
483              
484             my $patcher = Test::Smoke::Patcher->new( single => {
485             ddir => $self->{ddir},
486             patchbin => $self->{patchbin},
487             pfile => \$patch,
488             v => $self->{v},
489 8         618 });
490 8         49 eval { $patcher->patch };
  8         58  
491 8 50       72 if ( $@ ) {
492 0         0 require Carp;
493 0         0 Carp::carp( "Error while patching:\n\t$@" );
494 0         0 next;
495             }
496              
497 8 50       493 $self->_fix_dot_patch( $1 ) if $file =~ /(\d+)\.gz$/;
498              
499 8 50       98 if ( $self->{cleanup} & 2 ) {
500 8         1526 1 while unlink $file;
501             }
502             }
503 2 50       83 chdir $cwd or do {
504 0         0 require Carp;
505 0         0 Carp::croak( "Cannot chdir($cwd) back: $!" );
506             };
507             }
508              
509             =head2 $syncer->_read_patch( $file )
510              
511             C<_read_patch()> unzips the patch and returns the contents.
512              
513             =cut
514              
515             sub _read_patch {
516 8     8   59 my( $self, $file ) = @_;
517              
518 8 50       169 return undef unless -f $file;
519              
520 8         34 my $content;
521 8 100       72 if ( $self->{unzip} eq 'Compress::Zlib' ) {
522 4         81 require Compress::Zlib;
523 4 50       104 my $unzip = Compress::Zlib::gzopen( $file, 'rb' ) or do {
524 0         0 require Carp;
525 0         0 Carp::carp( "Can't open '$file': $Compress::Zlib::gzerrno" );
526 0         0 return undef;
527             };
528              
529 4         18591 my $buffer;
530 4         43 $content .= $buffer while $unzip->gzread( $buffer ) > 0;
531              
532 4 50       3284 unless ( $Compress::Zlib::gzerrno == Compress::Zlib::Z_STREAM_END() ) {
533 0         0 require Carp;
534 0         0 Carp::carp( "Error reading '$file': $Compress::Zlib::gzerrno" );
535             }
536              
537 4         54 $unzip->gzclose;
538             } else {
539              
540             # this calls out for `$self->{unzip} $file`
541             # {unzip} could be like 'zcat', 'gunzip -c', 'gzip -dc'
542              
543 4         23591 $content = `$self->{unzip} $file`;
544             }
545              
546 8         1397 return $content;
547             }
548              
549             =head2 $syncer->_fix_dot_patch( $new_level );
550              
551             C<_fix_dot_patch()> updates the B<.patch> file with the new patch level.
552              
553             =cut
554              
555             sub _fix_dot_patch {
556 8     8   265 my( $self, $new_level ) = @_;
557              
558 8 50 33     242 return $self->check_dot_patch
559             unless defined $new_level && $new_level =~ /^\d+$/;
560              
561 8         174 my $dot_patch = File::Spec->catfile( $self->{ddir}, '.patch' );
562              
563 8         128 local *DOTPATCH;
564 8 50       1019 if ( open DOTPATCH, "> $dot_patch" ) {
565 8         125 print DOTPATCH "$new_level\n";
566 8 50       1044 return close DOTPATCH ? $new_level : $self->check_dot_patch;
567             }
568              
569 0         0 return $self->check_dot_patch;
570             }
571              
572             =head2 __get_directory_names( [$dir] )
573              
574             [This is B a method]
575              
576             C<__get_directory_names()> retruns all directory names from
577             C<< $dir || cwd() >>. It does not look at symlinks (there should
578             not be any in the perl source-tree).
579              
580             =cut
581              
582             sub __get_directory_names {
583 2   33 2   12709 my $dir = shift || cwd();
584              
585 2         55 local *DIR;
586 2 50       180 opendir DIR, $dir or return ();
587 2         360 my @dirs = grep -d File::Spec->catfile( $dir, $_ ) => readdir DIR;
588 2         54 closedir DIR;
589              
590 2         42 return @dirs;
591             }
592              
593             1;
594              
595             =head1 COPYRIGHT
596              
597             (c) 2002-2013, All rights reserved.
598              
599             * Abe Timmerman
600              
601             This library is free software; you can redistribute it and/or modify
602             it under the same terms as Perl itself.
603              
604             See:
605              
606             * ,
607             *
608              
609             This program is distributed in the hope that it will be useful,
610             but WITHOUT ANY WARRANTY; without even the implied warranty of
611             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
612              
613             =cut