1package main;
2
3# Copyright (c) 2009  Openismus GmbH  <http://www.openismus.com/>
4#
5# This file is part of mm-common.
6#
7# mm-common is free software: you can redistribute it and/or modify
8# it under the terms of the GNU General Public License as published
9# by the Free Software Foundation, either version 2 of the License,
10# or (at your option) any later version.
11#
12# mm-common is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15# GNU General Public License for more details.
16#
17# You should have received a copy of the GNU General Public License
18# along with mm-common.  If not, see <http://www.gnu.org/licenses/>.
19
20use strict;
21use warnings;
22use bytes;
23use File::Glob qw(:glob);
24use File::Spec;
25use Getopt::Long qw(:config no_getopt_compat no_ignore_case require_order bundling);
26
27# Globals
28my $message_prefix;
29my %tags_hash;
30my $book_base;
31my $perm_mode;
32my $target_dir;
33my $target_nodir = '';
34my $expand_glob  = '';
35my $verbose      = '';
36
37sub path_basename ($)
38{
39  my ($path) = @_;
40  my $basename = File::Spec->splitpath($path);
41
42  return $basename;
43}
44
45sub exit_help ()
46{
47  my $script_name = path_basename($0) || 'doc-install.pl';
48
49  print <<"EOF";
50Usage: perl $script_name [OPTION]... [-T] SOURCE DEST
51  or:  perl $script_name [OPTION]... SOURCE... DIRECTORY
52  or:  perl $script_name [OPTION]... -t DIRECTORY SOURCE...
53
54Copy SOURCE to DEST or multiple SOURCE files to the existing DIRECTORY,
55while setting permission modes.  For HTML files, translate references to
56external documentation.
57
58Mandatory arguments to long options are mandatory for short options, too.
59      --book-base=BASEPATH          use reference BASEPATH for Devhelp book
60  -l, --tag-base=TAGFILE\@BASEPATH   use BASEPATH for references from TAGFILE
61  -m, --mode=MODE                   override file permission MODE (octal)
62  -t, --target-directory=DIRECTORY  copy all SOURCE arguments into DIRECTORY
63  -T, --no-target-directory         treat DEST as normal file
64      --glob                        expand SOURCE as filename glob pattern
65  -v, --verbose                     enable informational messages
66  -?, --help                        display this help and exit
67EOF
68  exit;
69}
70
71sub notice (@)
72{
73  print($message_prefix, @_, "\n") if ($verbose);
74}
75
76sub warning (@)
77{
78  print STDERR ($message_prefix, @_, "\n");
79}
80
81sub error (@)
82{
83  warning(@_);
84  exit 1;
85}
86
87# Copy file to destination while translating references on the fly.
88# Sniff the content for the file type, as it is always read in anyway.
89sub install_file ($$$)
90{
91  my ($in_name, $out_name, $basename) = @_;
92  my ($in, $out, $buf);
93  {
94    local $/; # slurp mode: read entire file into buffer
95
96    open($in, '<', $in_name) and binmode($in) and defined($buf = <$in>) and close($in)
97      or error('Failed to read ', $basename, ': ', $!);
98  }
99
100  if (%tags_hash and $buf =~ m/\A(?> \s*)(?> (?> <[?!][^<]+ )* )<html[>\s]/sx)
101  {
102    my $count = 0;
103    my $total = $buf =~
104      s!(?<= \s) doxygen="((?> [^:"]+)):((?> [^"]*))" # doxygen="(TAGFILE):(BASEPATH)"
105        (?> \s+) ((?> href|src) =") \2 ((?> [^"]*)")  # (href|src=")BASEPATH(RELPATH")
106       ! $3 . ((exists $tags_hash{$1}) ? (++$count, $tags_hash{$1}) : $2) . $4
107       !egsx;
108    my $change = $total ? "rewrote $count of $total"
109                        : 'no';
110    notice('Translating ', $basename, ' (', $change, ' references)');
111  }
112  elsif (defined($book_base) and $buf =~ m/\A(?> \s*)(?> (?> <[?!][^<]+ )* )<book\s/sx)
113  {
114    # Substitute new value for attribute "base" of element <book>
115    my $change = $buf =~ s/(<book \s [^<>]*? \b base=") (?> [^"]*) (?= ")/$1$book_base/sx
116                 ? 'rewrote base path'
117                 : 'base path not set';
118    notice('Translating ', $basename, ' (', $change, ')');
119  }
120  else
121  {
122    notice('Copying ', $basename);
123  }
124
125  # Avoid inheriting permissions of existing file
126  unlink($out_name);
127
128  open($out, '>', $out_name) and binmode($out) and print $out ($buf) and close($out)
129    or error('Failed to write ', $basename, ': ', $!);
130
131  chmod($perm_mode, $out_name)
132    or warning('Failed to set ', $basename, ' permissions: ', $!);
133}
134
135# Split TAGFILE@BASEPATH argument into key/value pair
136sub split_key_value ($)
137{
138  my ($mapping) = @_;
139  my ($name, $path) = split(m'@', $mapping, 2);
140
141  error('Invalid base path mapping: ', $mapping) unless (defined($name) and $name ne '');
142
143  if (defined $path)
144  {
145    notice('Using base path ', $path, ' for tag file ', $name);
146    return ($name, $path);
147  }
148  notice('Not changing base path for tag file ', $name);
149  return ();
150}
151
152# Define line leader of log messages
153$message_prefix = path_basename($0);
154$message_prefix =~ s/\.[^.]*$//s if (defined $message_prefix);
155$message_prefix = ($message_prefix || 'doc-install') . ': ';
156
157# Process command-line options
158{
159  my @tags = ();
160  my $mode = '0644';
161
162  GetOptions('book-base=s'           => \$book_base,
163             'tag-base|l=s'          => \@tags,
164             'mode|m=s'              => \$mode,
165             'target-directory|t=s'  => \$target_dir,
166             'no-target-directory|T' => \$target_nodir,
167             'glob'                  => \$expand_glob,
168             'verbose|v'             => \$verbose,
169             'help|?'                => \&exit_help)
170    or exit 2;
171
172  error('Invalid permission mode: ', $mode) unless ($mode =~ m/^[0-7]+$/s);
173
174  $perm_mode = oct($mode);
175  %tags_hash = map(split_key_value($_), @tags);
176}
177notice('Using base path ', $book_base, ' for Devhelp book') if (defined $book_base);
178
179if ($target_nodir)
180{
181  error('Conflicting target directory options') if (defined $target_dir);
182  error('Source and destination filenames expected') unless ($#ARGV == 1);
183  error('Filename globbing requires target directory') if ($expand_glob);
184
185  install_file($ARGV[0], $ARGV[1], path_basename($ARGV[1]));
186  exit;
187}
188
189unless (defined $target_dir)
190{
191  if (!$expand_glob and $#ARGV == 1)
192  {
193    my $basename = path_basename($ARGV[1]);
194
195    if (defined($basename) and $basename ne '')
196    {
197      install_file($ARGV[0], $ARGV[1], $basename);
198      exit;
199    }
200  }
201  $target_dir = pop(@ARGV);
202}
203error('No target directory specified') unless (defined($target_dir) and $target_dir ne '');
204
205@ARGV = map(bsd_glob($_, GLOB_NOSORT), @ARGV) if ($expand_glob);
206my %basename_hash = ();
207
208foreach my $in_name (@ARGV)
209{
210  my $basename = path_basename($in_name);
211
212  # If there are multiple files with the same base name in the list, only
213  # the first one will be installed.  This behavior makes it very easy to
214  # implement a VPATH search for each individual file.
215  unless (exists $basename_hash{$basename})
216  {
217    $basename_hash{$basename} = undef;
218    my $out_name = File::Spec->catfile($target_dir, $basename);
219    install_file($in_name, $out_name, $basename);
220  }
221}
222exit;
223