File Coverage

lib/CPANPLUS/Internals/Utils.pm
Criterion Covered Total %
statement 198 237 83.5
branch 60 104 57.6
condition 26 52 50.0
subroutine 28 29 96.5
pod n/a
total 312 422 73.9


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Utils;
2              
3 20     20   179 use strict;
  20         43  
  20         630  
4              
5 20     20   116 use CPANPLUS::Error;
  20         43  
  20         1407  
6 20     20   158 use CPANPLUS::Internals::Constants;
  20         45  
  20         7611  
7              
8 20     20   159 use Cwd qw[chdir cwd];
  20         40  
  20         1358  
9 20     20   11267 use File::Copy;
  20         49739  
  20         1339  
10 20     20   166 use Params::Check qw[check];
  20         48  
  20         901  
11 20     20   126 use Module::Load::Conditional qw[can_load];
  20         50  
  20         922  
12 20     20   121 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  20         43  
  20         167  
13 20     20   5564 use version;
  20         49  
  20         133  
14              
15 20     20   1505 use vars qw[$VERSION];
  20         58  
  20         73134  
16             $VERSION = "0.9914";
17              
18             local $Params::Check::VERBOSE = 1;
19              
20             =pod
21              
22             =head1 NAME
23              
24             CPANPLUS::Internals::Utils - convenience functions for CPANPLUS
25              
26             =head1 SYNOPSIS
27              
28             my $bool = $cb->_mkdir( dir => 'blah' );
29             my $bool = $cb->_chdir( dir => 'blah' );
30             my $bool = $cb->_rmdir( dir => 'blah' );
31              
32             my $bool = $cb->_move( from => '/some/file', to => '/other/file' );
33             my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' );
34              
35             my $cont = $cb->_get_file_contents( file => '/path/to/file' );
36              
37              
38             my $version = $cb->_perl_version( perl => $^X );
39              
40             =head1 DESCRIPTION
41              
42             C holds a few convenience functions for
43             CPANPLUS libraries.
44              
45             =head1 METHODS
46              
47             =head2 $cb->_mkdir( dir => '/some/dir' )
48              
49             C<_mkdir> creates a full path to a directory.
50              
51             Returns true on success, false on failure.
52              
53             =cut
54              
55             sub _mkdir {
56 17     17   5878 my $self = shift;
57              
58 17         163 my %hash = @_;
59              
60 17         153 my $tmpl = {
61             dir => { required => 1 },
62             };
63              
64 17 50       126 my $args = check( $tmpl, \%hash ) or (
65             error(loc( Params::Check->last_error ) ), return
66             );
67              
68 17 50       1734 unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
69 0         0 error( loc("Could not use File::Path! This module should be core!") );
70 0         0 return;
71             }
72              
73 17         170539 eval { File::Path::mkpath($args->{dir}) };
  17         7592  
74              
75 17 50       151 if($@) {
76 0         0 chomp($@);
77 0         0 error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ ));
78 0         0 return;
79             }
80              
81 17         208 return 1;
82             }
83              
84             =pod
85              
86             =head2 $cb->_chdir( dir => '/some/dir' )
87              
88             C<_chdir> changes directory to a dir.
89              
90             Returns true on success, false on failure.
91              
92             =cut
93              
94             sub _chdir {
95 66     66   743 my $self = shift;
96 66         829 my %hash = @_;
97              
98 66         875 my $tmpl = {
99             dir => { required => 1, allow => DIR_EXISTS },
100             };
101              
102 66 100       696 my $args = check( $tmpl, \%hash ) or return;
103              
104 65 50       10988 unless( chdir $args->{dir} ) {
105 0         0 error( loc(q[Could not chdir into '%1'], $args->{dir}) );
106 0         0 return;
107             }
108              
109 65         774 return 1;
110             }
111              
112             =pod
113              
114             =head2 $cb->_rmdir( dir => '/some/dir' );
115              
116             Removes a directory completely, even if it is non-empty.
117              
118             Returns true on success, false on failure.
119              
120             =cut
121              
122             sub _rmdir {
123 1     1   1088 my $self = shift;
124 1         8 my %hash = @_;
125              
126 1         7 my $tmpl = {
127             dir => { required => 1, allow => IS_DIR },
128             };
129              
130 1 50       10 my $args = check( $tmpl, \%hash ) or return;
131              
132 1 50       42 unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
133 0         0 error( loc("Could not use File::Path! This module should be core!") );
134 0         0 return;
135             }
136              
137 1         233 eval { File::Path::rmtree($args->{dir}) };
  1         447  
138              
139 1 50       8 if($@) {
140 0         0 chomp($@);
141 0         0 error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ ));
142 0         0 return;
143             }
144              
145 1         11 return 1;
146             }
147              
148             =pod
149              
150             =head2 $cb->_perl_version ( perl => 'some/perl/binary' );
151              
152             C<_perl_version> returns the version of a certain perl binary.
153             It does this by actually running a command.
154              
155             Returns the perl version on success and false on failure.
156              
157             =cut
158              
159             sub _perl_version {
160 19     19   1649 my $self = shift;
161 19         126 my %hash = @_;
162              
163 19         75 my $perl;
164 19         175 my $tmpl = {
165             perl => { required => 1, store => \$perl },
166             };
167              
168 19 50       125 check( $tmpl, \%hash ) or return;
169              
170 19         1584 my $perl_version;
171             ### special perl, or the one we are running under?
172 19 50       186 if( $perl eq $^X ) {
173             ### just load the config
174 19         324 require Config;
175 19         462 $perl_version = $Config::Config{version};
176              
177             } else {
178 0         0 my $cmd = $perl .
179             ' -MConfig -eprint+Config::config_vars+version';
180 0         0 ($perl_version) = (`$cmd` =~ /version='(.*)'/);
181             }
182              
183 19 50       286 return $perl_version if defined $perl_version;
184 0         0 return;
185             }
186              
187             =pod
188              
189             =head2 $cb->_version_to_number( version => $version );
190              
191             Returns a proper module version, or '0.0' if none was available.
192              
193             =cut
194              
195             sub _version_to_number {
196 71     71   7973 my $self = shift;
197 71         303 my %hash = @_;
198              
199 71         144 my $version;
200 71         477 my $tmpl = {
201             version => { default => '0.0', store => \$version },
202             };
203              
204 71 50       379 check( $tmpl, \%hash ) or return;
205              
206 71         6279 $version =~ s!_!!g; # *sigh*
207 71 100       980 return $version if $version =~ /^\d*(?:\.\d+)?$/;
208 8 100       90 if ( my ($vers) = $version =~ /^(v?\d+(?:\.\d+(?:\.\d+)?)?)/ ) {
209 6         30 return eval { version->parse($vers)->numify };
  6         229  
210             }
211 2         16 return '0.0';
212             }
213              
214             =pod
215              
216             =head2 $cb->_whoami
217              
218             Returns the name of the subroutine you're currently in.
219              
220             =cut
221              
222 1     1   852 sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name }
  1         16  
  1         5  
223              
224             =pod
225              
226             =head2 _get_file_contents( file => $file );
227              
228             Returns the contents of a file
229              
230             =cut
231              
232             sub _get_file_contents {
233 63     63   1088 my $self = shift;
234 63         1010 my %hash = @_;
235              
236 63         462 my $file;
237 63         865 my $tmpl = {
238             file => { required => 1, store => \$file }
239             };
240              
241 63 50       1342 check( $tmpl, \%hash ) or return;
242              
243 63 50       10859 my $fh = OPEN_FILE->($file) or return;
244 63         392 my $contents = do { local $/; <$fh> };
  63         538  
  63         3498  
245              
246 63         2017 return $contents;
247             }
248              
249             =pod
250              
251             =head2 $cb->_move( from => $file|$dir, to => $target );
252              
253             Moves a file or directory to the target.
254              
255             Returns true on success, false on failure.
256              
257             =cut
258              
259             sub _move {
260 2     2   1270 my $self = shift;
261 2         27 my %hash = @_;
262              
263 2         15 my $from; my $to;
264 2         28 my $tmpl = {
265             file => { required => 1, allow => [IS_FILE,IS_DIR],
266             store => \$from },
267             to => { required => 1, store => \$to }
268             };
269              
270 2 50       28 check( $tmpl, \%hash ) or return;
271              
272 2 100       105 if( File::Copy::move( $from, $to ) ) {
273 1         159 return 1;
274             } else {
275 1         560 error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!));
276 1         17 return;
277             }
278             }
279              
280             =pod
281              
282             =head2 $cb->_copy( from => $file|$dir, to => $target );
283              
284             Moves a file or directory to the target.
285              
286             Returns true on success, false on failure.
287              
288             =cut
289              
290             sub _copy {
291 0     0   0 my $self = shift;
292 0         0 my %hash = @_;
293              
294 0         0 my($from,$to);
295 0         0 my $tmpl = {
296             file =>{ required => 1, allow => [IS_FILE,IS_DIR],
297             store => \$from },
298             to => { required => 1, store => \$to }
299             };
300              
301 0 0       0 check( $tmpl, \%hash ) or return;
302              
303 0 0       0 if( File::Copy::copy( $from, $to ) ) {
304 0         0 return 1;
305             } else {
306 0         0 error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!));
307 0         0 return;
308             }
309             }
310              
311             =head2 $cb->_mode_plus_w( file => '/path/to/file' );
312              
313             Sets the +w bit for the file.
314              
315             Returns true on success, false on failure.
316              
317             =cut
318              
319             sub _mode_plus_w {
320 188     188   2048 my $self = shift;
321 188         599 my %hash = @_;
322              
323 188         7122 require File::stat;
324              
325 188         52179 my $file;
326 188         826 my $tmpl = {
327             file => { required => 1, allow => IS_FILE, store => \$file },
328             };
329              
330 188 50       713 check( $tmpl, \%hash ) or return;
331              
332             ### set the mode to +w for a file and +wx for a dir
333 188         4939 my $x = File::stat::stat( $file );
334 188 100       31437 my $mask = -d $file ? 0100 : 0200;
335              
336 188 50 33     5443 if( $x and chmod( $x->mode|$mask, $file ) ) {
337 188         7085 return 1;
338              
339             } else {
340 0         0 error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!));
341 0         0 return;
342             }
343             }
344              
345             =head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH );
346              
347             Turns a CPANPLUS::Config style C entry into an URI string.
348              
349             Returns the uri on success, and false on failure
350              
351             =cut
352              
353             sub _host_to_uri {
354 2     2   800 my $self = shift;
355 2         36 my %hash = @_;
356              
357 2         12 my($scheme, $host, $path);
358 2         31 my $tmpl = {
359             scheme => { required => 1, store => \$scheme },
360             host => { default => 'localhost', store => \$host },
361             path => { default => '', store => \$path },
362             };
363              
364 2 50       17 check( $tmpl, \%hash ) or return;
365              
366             ### it's an URI, so unixify the path.
367             ### VMS has a special method for just that
368 2         334 $path = ON_VMS
369             ? VMS::Filespec::unixify($path)
370             : File::Spec::Unix->catdir( File::Spec->splitdir( $path ) );
371              
372 2         26 return "$scheme://" . File::Spec::Unix->catdir( $host, $path );
373             }
374              
375             =head2 $cb->_vcmp( VERSION, VERSION );
376              
377             Normalizes the versions passed and does a '<=>' on them, returning the result.
378              
379             =cut
380              
381             sub _vcmp {
382 24     24   104 my $self = shift;
383 24         271 my ($x, $y) = @_;
384              
385 24         311 $x = $self->_version_to_number(version => $x);
386 24         115 $y = $self->_version_to_number(version => $y);
387              
388 24         246 return $x <=> $y;
389             }
390              
391             =head2 $cb->_home_dir
392              
393             Returns the user's homedir, or C if it could not be found
394              
395             =cut
396              
397             sub _home_dir {
398              
399 40 50   40   285 if ( can_load( modules => { 'File::HomeDir' => 0.0 } ) ) {
400 40 0 33     320688 if ( defined $ENV{APPDATA} && length $ENV{APPDATA} && !ON_WIN32 ) {
      50        
401 0         0 msg("'APPDATA' env var is set and not on MSWin32, " .
402             "please use 'PERL5_CPANPLUS_HOME' instead to change .cpanplus location", 1 );
403             }
404 40 50       203 return File::HomeDir->my_home if -d File::HomeDir->my_home;
405             }
406              
407 0         0 my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN );
408              
409 0         0 for my $env ( @os_home_envs ) {
410 0 0       0 next unless exists $ENV{ $env };
411 0 0 0     0 next unless defined $ENV{ $env } && length $ENV{ $env };
412 0 0       0 return $ENV{ $env } if -d $ENV{ $env };
413             }
414              
415 0         0 return cwd();
416             }
417              
418             =head2 $path = $cb->_safe_path( path => $path );
419              
420             Returns a path that's safe to us on Win32 and VMS.
421              
422             Only cleans up the path on Win32 if the path exists.
423              
424             On VMS, it encodes dots to _ using C
425              
426             =cut
427              
428             sub _safe_path {
429 46     46   249 my $self = shift;
430              
431 46         374 my %hash = @_;
432              
433 46         221 my $path;
434 46         245 my $tmpl = {
435             path => { required => 1, store => \$path },
436             };
437              
438 46 50       292 check( $tmpl, \%hash ) or return;
439              
440 46         3659 if( ON_WIN32 ) {
441             ### only need to fix it up if there's spaces in the path
442             return $path unless $path =~ /\s+/;
443              
444             ### clean up paths if we are on win32
445             return Win32::GetShortPathName( $path ) || $path;
446              
447 0         0 } elsif ( ON_VMS ) {
448             ### XXX According to John Malmberg, there's an VMS issue:
449             ### catdir on VMS can not currently deal with directory components
450             ### with dots in them.
451             ### Fixing this is a three step procedure, which will work for
452             ### VMS in its traditional ODS-2 mode, and it will also work if
453             ### VMS is in the ODS-5 mode that is being implemented.
454             ### If the path is already in VMS syntax, assume that we are done.
455              
456             ### VMS format is a path with a trailing ']' or ':'
457             return $path if $path =~ /\:|\]$/;
458              
459             ### 1. Make sure that the value to be converted, $path is
460             ### in UNIX directory syntax by appending a '/' to it.
461             $path .= '/' unless $path =~ m|/$|;
462              
463             ### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to
464             ### underscores if needed. The trailing '/' is needed as so that
465             ### C knows that it should use directory translation instead of
466             ### filename translation, as filename translation leaves one dot.
467             $path = VMS::Filespec::vmsify( $path );
468              
469             ### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify(
470             ### $path . '/') to remove the directory delimiters.
471              
472             ### From John Malmberg:
473             ### File::Spec->catdir will put the path back together.
474             ### The '/' trick only works if the string is a directory name
475             ### with UNIX style directory delimiters or no directory delimiters.
476             ### It is to force vmsify to treat the input specification as UNIX.
477             ###
478             ### There is a VMS::Filespec::unixpath() to do the appending of the '/'
479             ### to the specification, which will do a VMS::Filespec::vmsify()
480             ### if needed.
481             ### However it is not a good idea to call vmsify() on a pathname
482             ### returned by unixify(), and it is not a good idea to call unixify()
483             ### on a pathname returned by vmsify(). Because of the nature of the
484             ### conversion, not all file specifications can make the round trip.
485             ###
486             ### I think that directory specifications can safely make the round
487             ### trip, but not ones containing filenames.
488             $path = File::Spec->catdir( File::Spec->splitdir( $path ) )
489             }
490              
491 46         939 return $path;
492             }
493              
494              
495             =head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING );
496              
497             Splits the name of a CPAN package string up into its package, version
498             and extension parts.
499              
500             For example, C would return the following parts:
501              
502             Package: Foo-Bar
503             Version: 1.2
504             Extension: tar.gz
505              
506             =cut
507              
508             sub _distname_info {
509 344 50   344   918 my $file = shift or return;
510              
511 344 50       4390 my ($dist, $version) = $file =~ /^
512             ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
513             (?:
514             [A-Za-z](?=[^A-Za-z]|$)
515             |
516             \d(?=-)
517             )(?
518             )+)(.*)
519             $/xs or return ($file,undef,undef);
520              
521 344 50 33     1237 if ($dist =~ /-undef\z/ and ! length $version) {
522 0         0 $dist =~ s/-undef\z//;
523             }
524              
525             # Remove potential -withoutworldwriteables suffix
526 344         1045 $version =~ s/-withoutworldwriteables$//;
527              
528 344 100       861 if ($version =~ /^(-[Vv].*)-(\d.*)/) {
529              
530             # Catch names like Unicode-Collate-Standard-V3_1_1-0.1
531             # where the V3_1_1 is part of the distname
532 5         15 $dist .= $1;
533 5         10 $version = $2;
534             }
535              
536 344 50       880 if ($version =~ /(.+_.*)-(\d.*)/) {
537             # Catch names like Task-Deprecations5_14-1.00.tar.gz where the 5_14 is
538             # part of the distname. However, names like libao-perl_0.03-1.tar.gz
539             # should still have 0.03-1 as their version.
540 0         0 $dist .= $1;
541 0         0 $version = $2;
542             }
543              
544             # Normalize the Dist.pm-1.23 convention which CGI.pm and
545             # a few others use.
546 344         657 $dist =~ s{\.pm$}{};
547              
548 344 50 66     1173 $version = $1
549             if !length $version and $dist =~ s/-(\d+\w)$//;
550              
551 344 50 33     1350 $version = $1 . $version
552             if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
553              
554 344 100       1412 if ($version =~ /\d\.\d/) {
555 308         1111 $version =~ s/^[-_.]+//;
556             }
557             else {
558 36         95 $version =~ s/^[-_]+//;
559             }
560              
561 344         615 my $dev;
562 344 100       718 if (length $version) {
563 327 100 66     1723 if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
    100          
564 24 50 66     441 $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
      33        
      33        
      33        
565             }
566             elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
567 15         26 $dev = 1;
568             }
569             }
570             else {
571 17         32 $version = undef;
572             }
573              
574 344         2097 ($dist, $version, $dev);
575             }
576              
577             { my $del_re = qr/[-_\+]/i; # delimiter between elements
578             my $pkg_re = qr/[a-z] # any letters followed by
579             [a-z\d]* # any letters, numbers
580             (?i:\.pm)? # followed by '.pm'--authors do this :(
581             (?: # optionally repeating:
582             $del_re # followed by a delimiter
583             [a-z] # any letters followed by
584             [a-z\d]* # any letters, numbers
585             (?i:\.pm)? # followed by '.pm'--authors do this :(
586             )*
587             /xi;
588              
589             my $ver_re = qr/[a-z]*\d*?[a-z]* # contains a digit and possibly letters
590             (?: # however, some start with a . only :(
591             [-._] # followed by a delimiter
592             [a-z\d]+ # and more digits and or letters
593             )*?
594             /xi;
595              
596             my $ext_re = qr/[a-z] # a letter, followed by
597             [a-z\d]* # letters and or digits, optionally
598             (?:
599             \. # followed by a dot and letters
600             [a-z\d]+ # and or digits (like .tar.bz2)
601             )? # optionally
602             /xi;
603              
604             my $ver_ext_re = qr/
605             ($ver_re+) # version, optional
606             (?:
607             \. # a literal .
608             ($ext_re) # extension,
609             )? # optional, but requires version
610             /xi;
611              
612             ### composed regex for CPAN packages
613             my $full_re = qr/
614             ^
615             ( # the whole thing
616             ($pkg_re+) # package
617             (?:
618             $del_re # delimiter
619             $ver_ext_re # version + extension
620             )?
621             )
622             $
623             /xi;
624              
625             ### composed regex for perl packages
626             my $perl = PERL_CORE;
627             my $perl_re = qr/
628             ^
629             ( # the whole thing
630             ($perl) # package name for 'perl'
631             (?:
632             $ver_ext_re # version + extension
633             )?
634             )
635             $
636             /xi;
637              
638              
639             sub _split_package_string {
640 344     344   600 my $self = shift;
641 344         1073 my %hash = @_;
642              
643 344         622 my $str;
644 344         1309 my $tmpl = { package => { required => 1, store => \$str } };
645 344 50       1559 check( $tmpl, \%hash ) or return;
646              
647 344         24644 my ($dpkg,$dver);
648             {
649 344         585 my ($base,$ext);
  344         538  
650 344 100       3039 if ( $str =~ m,([^/]+)\.(tar\.(?:[gx]?z|bz2)|zip|tbz|tgz|txz)$,i ) {
651 311         1018 $base = $1;
652 311         659 $ext = $2;
653             }
654             else {
655 33         80 $base = $str;
656             }
657 344         996 ($dpkg,$dver) = _distname_info($base);
658             }
659              
660             ### 2 different regexes, one for the 'perl' package,
661             ### one for ordinary CPAN packages.. try them both,
662             ### first match wins.
663 344         861 for my $re ( $full_re, $perl_re ) {
664              
665             ### try the next if the match fails
666 372 100       6040 $str =~ $re or next;
667              
668 339   50     1595 my $full = $1 || '';
669 339   50     919 my $pkg = $2 || '';
670 339   100     1053 my $ver = $3 || '';
671 339   100     1319 my $ext = $4 || '';
672              
673             ### this regex resets the capture markers!
674             ### strip the trailing delimiter
675 339         1837 $pkg =~ s/$del_re$//;
676              
677             ### strip the .pm package suffix some authors insist on adding
678 339         795 $pkg =~ s/\.pm$//i;
679              
680 339 100 66     1511 $pkg = $dpkg if $dpkg && $pkg ne $dpkg;
681 339 100 100     1396 $ver = $dver if $dver && $ver ne $dver;
682              
683 339         2395 return ($pkg, $ver, $ext, $full );
684             }
685              
686 5         221 return;
687             }
688             }
689              
690             { my %escapes = map {
691             chr($_) => sprintf("%%%02X", $_)
692             } 0 .. 255;
693              
694             sub _uri_encode {
695 3     3   347 my $self = shift;
696 3         15 my %hash = @_;
697              
698 3         12 my $str;
699 3         23 my $tmpl = {
700             uri => { store => \$str, required => 1 }
701             };
702              
703 3 50       17 check( $tmpl, \%hash ) or return;
704              
705             ### XXX taken straight from URI::Encode
706             ### Default unsafe characters. RFC 2732 ^(uric - reserved)
707 3         279 $str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g;
708              
709 3         41 return $str;
710             }
711              
712              
713             sub _uri_decode {
714 8     8   993 my $self = shift;
715 8         38 my %hash = @_;
716              
717 8         20 my $str;
718 8         42 my $tmpl = {
719             uri => { store => \$str, required => 1 }
720             };
721              
722 8 50       46 check( $tmpl, \%hash ) or return;
723              
724             ### XXX use unencode routine in utils?
725 8         719 $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  88         303  
726              
727 8         50 return $str;
728             }
729             }
730              
731             sub _update_timestamp {
732 95     95   898 my $self = shift;
733 95         1083 my %hash = @_;
734              
735 95         523 my $file;
736 95         1329 my $tmpl = {
737             file => { required => 1, store => \$file, allow => FILE_EXISTS }
738             };
739              
740 95 50       823 check( $tmpl, \%hash ) or return;
741              
742             ### `touch` the file, so windoze knows it's new -jmb
743             ### works on *nix too, good fix -Kane
744             ### make sure it is writable first, otherwise the `touch` will fail
745              
746 95         3382 my $now = time;
747 95 50 33     5005 unless( chmod( 0644, $file) && utime ($now, $now, $file) ) {
748 0         0 error( loc("Couldn't touch %1", $file) );
749 0         0 return;
750             }
751              
752 95         2271 return 1;
753             }
754              
755              
756             1;
757              
758             # Local variables:
759             # c-indentation-style: bsd
760             # c-basic-offset: 4
761             # indent-tabs-mode: nil
762             # End:
763             # vim: expandtab shiftwidth=4: