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