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