1package DocSet::Util; 2 3use strict; 4use warnings; 5 6use Symbol (); 7use File::Basename (); 8use File::Copy (); 9use File::Path (); 10use File::Find (); 11use Data::Dumper; 12use Carp; 13use Template; 14use File::Spec; 15use File::Spec::Functions; 16 17require DocSet::RunTime; # interdependency with DocSet::Util 18 19use constant IS_WIN32 => $^O eq 'MSWin32'; 20use constant PERL_LT_580 => $] < 5.008; 21 22use vars qw(@ISA @EXPORT); 23@ISA = qw(Exporter); 24@EXPORT = qw(read_file read_file_paras copy_file gzip_file write_file 25 create_dir filename filename_ext require_package dumper 26 sub_trace note get_date get_timestamp proc_tmpl 27 build_matchmany_sub banner confess cluck carp 28 format_bytes expand_dir which path2uri); 29 30# copy_file($src_path, $dst_path); 31# copy a file at $src_path to $dst_path, 32# if one of the directories of the $dst_path doesn't exist -- it'll 33# be created. 34############### 35sub copy_file { 36 my ($src, $dst) = @_; 37 38 die "$src doesn't exist" unless -e $src; 39 my $mode = (stat _)[2]; 40 41 # make sure that the directory exist or create one 42 my $base_dir = File::Basename::dirname $dst; 43 create_dir($base_dir) unless (-d $base_dir); 44 45 # File::Copy::syscopy doesn't preserve the mode :( 46 File::Copy::syscopy($src, $dst); 47 chmod $mode, $dst; 48} 49 50# gzip_file($src_path); 51# gzip a file at $src_path 52############### 53sub gzip_file { 54 my ($src) = @_; 55 system "gzip -f $src"; 56} 57 58 59# write_file($filename, $ref_to_array||scalar); 60# content will be written to the file from the passed array of 61# paragraphs 62############### 63sub write_file { 64 my ($filename, $content) = @_; 65 66 # make sure that the directory exist or create one 67 my $dir = File::Basename::dirname $filename; 68 create_dir($dir) unless -d $dir; 69 70 my $fh = Symbol::gensym; 71 open $fh, ">$filename" or croak "Can't open $filename for writing: $!"; 72 print $fh ref $content ? @$content : defined $content ? $content : ''; 73 close $fh; 74} 75 76 77# recursively creates a multi-layer directory 78############### 79sub create_dir { 80 my $path = shift; 81 return if !defined($path) || -e $path; 82 # META: mode could be made configurable 83 File::Path::mkpath($path, 0, 0755) or croak "Couldn't create $path: $!"; 84} 85 86# read_file($filename, $ref); 87# assign to a ref to a scalar 88############### 89sub read_file { 90 my ($filename, $r_content) = @_; 91 92 my $fh = Symbol::gensym; 93 open $fh, $filename or croak "Can't open $filename for reading: $!"; 94 local $/; 95 $$r_content = <$fh>; 96 close $fh; 97 98} 99 100# read_file_paras($filename, $ref_to_array); 101# read by paragraph 102# content will be set into a ref to an array 103############### 104sub read_file_paras { 105 my ($filename, $ra_content) = @_; 106 107 my $fh = Symbol::gensym; 108 open $fh, $filename or croak "Can't open $filename for reading: $!"; 109 local $/ = ""; 110 @$ra_content = <$fh>; 111 close $fh; 112 113} 114 115# return the filename part of the path 116sub filename { 117 my ($path) = @_; 118 return File::Basename::basename($path); 119} 120 121# return the passed file's extension or '' if there is no one 122# note: that '/foo/bar.conf.in' returns an extension: 'conf.in'; 123# note: a hidden file .foo will be recognized as an extension 'foo' 124sub filename_ext { 125 my ($filename) = @_; 126 my $ext = (File::Basename::fileparse($filename, '\.[^\.]*'))[2] || ''; 127 $ext =~ s/^\.(.*)/lc $1/e; 128 $ext; 129} 130 131 132# since on non-Unix platforms the fs path's separator don't match the 133# URI separator ('/'), we need to rewrite those paths 134# accept a relative native path 135# return relative URI 136sub path2uri { 137 return unless defined $_[0]; 138 return join '/', File::Spec->splitdir(shift); 139} 140 141# File::Spec->abs2rel doesn't strip the volume (e.g. /^c:/) before 142# Perl v5.8.0 on Win32. This function fixes this bug. 143# 144# Make sure to call this function as DocSet::Util::abs2rel, especially 145# in the code that already uses File::Spec functions. 146sub abs2rel { 147 my $res = File::Spec->abs2rel(@_); 148 $res =~ s/^[a-zA-Z]:// if IS_WIN32 && PERL_LT_580 && defined $res; 149 $res; 150} 151 152 153sub get_date { 154 sprintf "%s %d, %d", (split /\s+/, scalar localtime)[1,2,4]; 155} 156 157sub get_timestamp { 158 my ($mon,$day,$year) = (localtime ( time ) )[4,3,5]; 159 return scalar gmtime() . ' GMT'; 160} 161 162my %require_seen = (); 163# convert Foo::Bar into Foo/Bar.pm and require 164sub require_package { 165 my $package = shift; 166 die "no package passed" unless $package; 167 return if $require_seen{$package}; 168 $require_seen{$package} = 1; 169 $package =~ s|::|/|g; 170 $package .= '.pm'; 171 require $package; 172} 173 174# convert the template into the release version 175# $tmpl_root: a ref to an array of tmpl base dirs 176# tmpl_file: which template file to process 177# mode : in what mode (html, ps, ...) 178# vars : ref to a hash with vars to path to the template 179# 180# returns the processed template 181################### 182sub proc_tmpl { 183 my ($tmpl_root, $tmpl_file, $mode, $vars) = @_; 184 185 # append the specific rendering mode, so the correct template will 186 # be picked (e.g. in 'ps' mode, the ps sub-dir(s) will be searched 187 # first) 188 my $search_path = join ':', 189 map { ("$_/$mode", "$_/common", "$_") } 190 (ref $tmpl_root ? @$tmpl_root : $tmpl_root); 191 192 my $template = Template->new 193 ({ 194 INCLUDE_PATH => $search_path, 195 RECURSION => 1, 196 PLUGINS => { 197 cnavigator => 'DocSet::Template::Plugin::NavigateCache', 198 }, 199 }) || die $Template::ERROR, "\n"; 200 201 # use Data::Dumper; 202 # print Dumper \@search_path; 203 204 my $output; 205 $template->process($tmpl_file, $vars, \$output) 206 || die "error: ", $template->error(), "\n"; 207 208 return $output; 209 210} 211 212 213sub banner { 214 my ($string) = @_; 215 216 my $len = length($string) + 8; 217 note( 218 "#" x $len, 219 "### $string ###", 220 "#" x $len, 221 ); 222 223} 224 225# see DocSet::Config::files_to_copy() for usage 226######################### 227sub build_matchmany_sub { 228 my $ra_regex = shift; 229 my $expr = join '||', map { "\$_[0] =~ m/$_/o" } @$ra_regex; 230 # note $expr; 231 my $matchsub = eval "sub { ($expr) ? 1 : 0}"; 232 die "Failed in building regex [@$ra_regex]: $@" if $@; 233 $matchsub; 234} 235 236use constant KBYTE => 1024; 237use constant MBYTE => 1048576; 238use constant GBYTE => 1073741824; 239 240# compacts numbers like 1200234 => 1.2M, so they always fit into 4 chars. 241################# 242sub format_bytes { 243 my $bytes = shift || 0; 244 245 if ($bytes < KBYTE) { 246 return sprintf "%5dB", $bytes; 247 } 248 elsif (KBYTE <= $bytes and $bytes < MBYTE) { 249 return sprintf "%4.@{[int($bytes/KBYTE) < 10 ? 1 : 0]}fKiB", $bytes/KBYTE; 250 } 251 elsif (MBYTE <= $bytes and $bytes < GBYTE) { 252 return sprintf "%4.@{[int($bytes/MBYTE) < 10 ? 1 : 0]}fMiB", $bytes/MBYTE; 253 } 254 elsif (GBYTE <= $bytes) { 255 return sprintf "%4.@{[int($bytes/GBYTE) < 10 ? 1 : 0]}fGiB", $bytes/GBYTE; 256 } 257 else { 258 # shouldn't happen 259 die "cannot handle formatting of $bytes" 260 } 261} 262 263 264sub expand_dir { 265 my @files = (); 266 if ($] >= 5.006) { 267 File::Find::find(sub {push @files, $File::Find::name}, $_[0]); 268 } 269 else { 270 # perl 5.005_03 on FreeBSD doesn't set the dir it chdir'ed to 271 # need to move this to compat level? 272 require Cwd; 273 File::Find::find(sub {push @files, catfile(Cwd::cwd(), $_)}, $_[0]); 274 } 275 276 return \@files; 277} 278 279my @path_ext = (''); 280if (IS_WIN32) { 281 if ($ENV{PATHEXT}) { 282 push @path_ext, split ';', $ENV{PATHEXT}; 283 } 284 else { 285 push @path_ext, map { ".$_" } qw(com exe bat); # Win9X 286 } 287} 288sub which { 289 for my $base (map { catfile $_, $_[0] } File::Spec->path()) { 290 for my $ext (@path_ext) { 291 return $base.$ext if -x $base.$ext; 292 } 293 } 294 return ''; 295} 296 297sub dumper { 298 print Dumper @_; 299} 300 301 302#sub sub_trace { 303## my ($package) = (caller(0))[0]; 304# my ($sub) = (caller(1))[3]; 305# print "=> $sub: @_\n"; 306#} 307 308*confess = \*Carp::confess; 309*cluck = \*Carp::cluck; 310*carp = \*Carp::carp; 311 312sub note { 313 return unless DocSet::RunTime::get_opts('verbose'); 314 print join("\n", @_), "\n"; 315} 316 317 318#sub error { 319# return unless DocSet::RunTime::get_opts('verbose'); 320# cluck(join("\n", @_), "\n"); 321#} 322 323 3241; 325__END__ 326 327=head1 NAME 328 329C<DocSet::Util> - Commonly used functions 330 331=head1 SYNOPSIS 332 333 use DocSet::Util; 334 335 copy_file($src, $dst); 336 write_file($filename, $content); 337 create_dir($path); 338 339 read_file($filename, $r_content); 340 read_file_paras($filename, $ra_content); 341 342 my $ext = filename_ext($filename); 343 my $date = get_date(); 344 my $timestamp = get_timestamp(); 345 my $uri = path2uri($os_path); 346 347 require_package($package); 348 my $output = proc_tmpl($tmpl_root, $tmpl_file, $mode, $vars); 349 350 banner($string); 351 352 my $sub_ref = build_matchmany_sub($ra_regex); 353 dumper($ref); 354 confess($string); 355 note($string); 356 357 my $exec_path = which('perldoc'); 358 359=head1 DESCRIPTION 360 361All the functions are exported by default. 362 363=head2 METHODS 364 365META: to be completed (see SYNOPSIS meanwhile) 366 367=over 368 369=item * copy_file 370 371=item * write_file 372 373=item * create_dir 374 375=item * read_file 376 377=item * read_file_paras 378 379=item * filename_ext 380 381=item * path2uri 382 383=item * get_date 384 385=item * get_timestamp 386 387=item * require_package 388 389=item * proc_tmpl 390 391=item * banner 392 393=item * build_matchmany_sub 394 395Since the patterns are compiled by insertion into m//, make sure that 396any C</> are escaped. Be careful with using quotemeta() for this, 397since you don't want to espace special regex char, e.g. C<^>, C<$>, 398etc. 399 400=item * which 401 402 my $exec_path = which('perldoc'); 403 404a portable function to search for executables on the system. 405 406Accepts a single argument which is the name of the executable to 407search for. Returns the full path to the executable if found, an empty 408string otherwise. 409 410Parts of the implementation are borrowed from 411I<modperl-2.0/lib/Apache/Build.pm> and modified to take into an 412account Win32's C<PATHEXT> environment variable or the hardcoded list 413of known executable extensions for Win9x which doesn't have this 414variable. 415 416=item * dumper 417 418=item * confess 419 420=item * cluck 421 422=item * carp 423 424=item * note 425 426 427=back 428 429=head1 AUTHORS 430 431Stas Bekman E<lt>stas (at) stason.orgE<gt> 432 433 434=cut 435 436