1# 2# -*- Perl -*- 3# $Id: util.pl,v 1.22.4.15 2009-02-17 08:53:35 opengl2772 Exp $ 4# Copyright (C) 1997-1999 Satoru Takabayashi All rights reserved. 5# Copyright (C) 2000-2009 Namazu Project All rights reserved. 6# This is free software with ABSOLUTELY NO WARRANTY. 7# 8# This program is free software; you can redistribute it and/or modify 9# it under the terms of the GNU General Public License as published by 10# the Free Software Foundation; either versions 2, or (at your option) 11# any later version. 12# 13# This program is distributed in the hope that it will be useful 14# but WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16# GNU General Public License for more details. 17# 18# You should have received a copy of the GNU General Public License 19# along with this program; if not, write to the Free Software 20# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 21# 02111-1307, USA 22# 23# This file must be encoded in EUC-JP encoding 24# 25 26package util; 27use strict; 28use English; 29use IO::File; 30require 'time.pl'; 31 32use vars qw($LANG_MSG $LANG); 33$LANG_MSG = "C"; # language of messages 34$LANG = "C"; # language of text processing 35 36# rename() with consideration for OS/2 37sub Rename($$) { 38 my ($from, $to) = @_; 39 40 return unless -e $from; 41 unlink $to if (-f $from) && (-f $to); # some systems require this 42 if (0 == rename($from, $to)) { 43 cdie("rename($from, $to): $!\n"); 44 } 45 dprint(_("Renamed: ")."$from, $to\n"); 46} 47 48sub efopen ($) { 49 my ($fname) = @_; 50 51 my $fh = fopen($fname) || cdie("$fname: $!\n"); 52 53 return $fh; 54} 55 56sub fopen ($) { 57 my ($fname) = @_; 58 my $fh = new IO::File; 59 60 if ($fh->open($fname)) { 61 binmode($fh); 62 } else { 63 $fh = undef; 64 } 65 66 return $fh; 67} 68 69sub fclose ($) { 70 my ($arg) = @_; 71 72 if (ref $arg) { 73 if ($arg =~ /^(IO::File|FileHandle)/) { 74 my $fh = $arg; 75 $fh->flush; 76 cdie("write error: $!\n") if ($fh->error); 77 $fh->close(); 78 return undef; 79 } 80 } 81 82 warn "$arg: " . _("not an IO::File/FileHandle object!\n"); 83 return undef; 84} 85 86sub dprint (@) { 87 if ($var::Opt{'debug'}) { 88 for my $str (@_) { 89 map {print STDERR '// ', $_, "\n"} split "\n", $str; 90 } 91 } 92} 93 94sub vprint (@) { 95 if ($var::Opt{'verbose'} || $var::Opt{'debug'}) { 96 for my $str (@_) { 97 map {print STDERR '@@ ', $_, "\n"} split "\n", $str; 98 } 99 } 100} 101 102sub commas ($) { 103 my ($num) = @_; 104 105 $num = "0" if ($num eq ""); 106# 1 while $num =~ s/(.*\d)(\d\d\d)/$1,$2/; 107 # from Mastering Regular Expressions 108 $num =~ s<\G((?:^-)?\d{1,3})(?=(?:\d\d\d)+(?!\d))><$1,>g; 109 $num; 110} 111 112# RFC 822 format 113sub rfc822time ($) 114{ 115 my ($time) = @_; 116 117 my @week_names = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"); 118 my @month_names = ("Jan", "Feb", "Mar", "Apr", "May", "Jun", 119 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"); 120 my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) 121 = localtime($time); 122 123 return sprintf("%s, %.2d %s %d %.2d:%.2d:%.2d %s", 124 $week_names[$wday], 125 $mday, $month_names[$mon], $year + 1900, 126 $hour, $min, $sec, time::gettimezone()); 127} 128 129sub readfile ($) { 130 my ($arg) = @_; 131 132 my $fh; 133 if (ref $arg) { 134 if ($arg =~ /^(IO::File|FileHandle)/) { 135 $fh = $arg; 136 } else { 137 warn "$arg: " . _("not an IO::File/FileHandle object!\n"); 138 return ''; 139 } 140 } else { 141 $fh = efopen($arg); 142 } 143 144 my $cont = ""; 145 my $size = -s $fh; 146# if ($size > $conf::FILE_SIZE_LIMIT) { 147# warn "$arg: too large!\n"; 148# return ''; 149# } 150 read $fh, $cont, $size; 151 152 unless (ref $arg) { 153 fclose($fh); 154 } 155 return $cont; 156} 157 158sub writefile ($$) { 159 my ($arg, $cont) = @_; 160 161 my $fh; 162 if (ref $arg) { 163 if ($arg =~ /^(IO::File|FileHandle)/) { 164 $fh = $arg; 165 } else { 166 warn "$arg: " . _("not an IO::File/FileHandle object!\n"); 167 return undef; 168 } 169 } else { 170 $fh = efopen("> $arg"); 171 } 172 173 print $fh $$cont; 174 175 unless (ref $arg) { 176 fclose($fh); 177 } 178 return undef; 179} 180 181sub filesize($) { 182 my ($arg) = @_; 183 my $fh; 184 if (ref $arg) { 185 if ($arg =~ /^(IO::File|FileHandle)/) { 186 $fh = $arg; 187 } else { 188 warn "$arg: " . _("not an IO::File/FileHandle object!\n"); 189 return ''; 190 } 191 } else { 192 $fh = fopen($arg) || return 0; # in case file is removed after find_file 193 # 2.0.7 had problem 194 } 195 my $size = -s $fh; 196 unless (ref $arg) { 197 fclose($fh); 198 } 199 return $size; 200} 201 202# checklib ... check existence of library file 203sub checklib ($) { 204 my $libfile = shift; 205 for my $path (@INC) { 206 my $cpath = "$path/$libfile"; 207 return 1 if -e $cpath; 208 } 209 return 0; 210} 211 212# checkcmd ... check command path 213sub checkcmd ($) { 214 my $cmd = shift; 215 my $pd = ':'; 216 $pd = ';' if (($English::OSNAME eq "MSWin32") || ($English::OSNAME eq "os2")); 217 218 for my $dir (split(/$pd/, $ENV{'PATH'})) { 219 next if ($dir eq ''); 220 win32_yen_to_slash(\$dir); 221 return "$dir/$cmd" if (-x "$dir/$cmd" && ! -d "$dir/$cmd"); 222 return "$dir/$cmd.com" if (-x "$dir/$cmd.com" && 223 (($English::OSNAME eq "MSWin32") || ($English::OSNAME eq "os2"))); 224 return "$dir/$cmd.exe" if (-x "$dir/$cmd.exe" && 225 (($English::OSNAME eq "MSWin32") || ($English::OSNAME eq "os2"))); 226 return "$dir/$cmd.bat" if (-x "$dir/$cmd.bat" && 227 ($English::OSNAME eq "MSWin32")); 228 return "$dir/$cmd.cmd" if (-x "$dir/$cmd.cmd" && 229 ($English::OSNAME eq "os2")); 230 } 231 return undef; 232} 233 234# tmpnam ... make temporary file name 235sub tmpnam ($) { 236 my ($base) = @_; 237 cdie("util::tmpnam: Set \$var::OUTPUT_DIR first!\n") 238 if $var::OUTPUT_DIR eq ""; 239 my $tmpnam = "$var::OUTPUT_DIR/$base.tmp"; 240 dprint("tmpnam: $tmpnam\n"); 241 return $tmpnam; 242} 243 244# cdie ... clean files before die 245sub cdie (@) { 246 my (@msgs) = @_; 247 248 remove_tmpfiles(); 249 print STDERR "mknmz: ", @msgs; 250 print STDERR "\n" unless $msgs[$#msgs] =~ /\n$/; 251 exit 2; 252} 253 254# remove_tmpfiles ... remove temporary files which mknmz would make 255sub remove_tmpfiles () { 256 return unless defined $var::OUTPUT_DIR; 257 258 my @list = glob "$var::OUTPUT_DIR/NMZ.*.tmp"; 259 push @list, $var::NMZ{'err'} if -z $var::NMZ{'err'}; # if size == 0 260 push @list, $var::NMZ{'lock'} if -f $var::NMZ{'lock'}; 261 push @list, $var::NMZ{'lock2'} if -f $var::NMZ{'lock2'}; 262 dprint(_("Remove temporary files:"), @list); 263 unlink @list; 264} 265 266sub set_lang () { 267 for my $cand (("LANGUAGE", "LC_ALL", "LC_MESSAGES", "LANG")) { 268 if (defined($ENV{$cand})) { 269 $util::LANG_MSG = $ENV{$cand}; 270 last; 271 } 272 } 273 for my $cand (("LC_ALL", "LC_CTYPE", "LANG")) { 274 if (defined($ENV{$cand})) { 275 $util::LANG = $ENV{$cand}; 276 last; 277 } 278 } 279 # print "LANG: $util::LANG\n"; 280} 281 282sub islang_msg($) { 283 my ($lang) = @_; 284 285 if ($util::LANG_MSG =~ /^$lang/) { # prefix matching 286 return 1; 287 } else { 288 return 0; 289 } 290} 291 292sub islang($) { 293 my ($lang) = @_; 294 295 if ($util::LANG =~ /^$lang/) { # prefix matching 296 return 1; 297 } else { 298 return 0; 299 } 300} 301 302sub assert($$) { 303 my ($bool, $msg) = @_; 304 305 if (!$bool) { 306 die _("ASSERTION ERROR!: ")."$msg"; 307 } 308} 309 310# Since it is an old subroutine, it is prohibition of use. 311# It exists only for back compatibility. 312sub systemcmd { 313 if ($English::OSNAME eq "MSWin32" || $English::OSNAME eq "os2") { 314 my @args = (); 315 foreach my $tmp (@_) { 316 $tmp =~ s!/!\\!g; 317 push @args, $tmp; 318 } 319 system(@args); 320 } else { 321 system(@_); 322 } 323} 324 325sub syscmd(%) 326{ 327 my $status = undef; 328 my %arg = @_; 329 my @args = @{$arg{command}} if (defined $arg{command}); 330 my %option = %{$arg{option}} if (defined $arg{option}); 331 my %env = %{$arg{env}} if (defined $arg{env}); 332 333 dprint(_("Invoked: ") . join(' ', @args)); 334 335 # default option 336 $option{stdout} = '/dev/null' unless(defined $option{stdout}); 337 $option{stderr} = '/dev/null' unless(defined $option{stderr}); 338 $option{mode_stdout} = 'wt' unless(defined $option{mode_stdout}); 339 $option{mode_stderr} = 'wt' unless(defined $option{mode_stderr}); 340 $option{maxsize} = -1 unless(defined $option{maxsize}); 341 342 my $handle_out = undef; 343 my $handle_err = undef; 344 if (ref $option{stdout}) { 345 if ($option{stdout} =~ /^(IO::File|FileHandle)/) { 346 $handle_out = $option{stdout}; 347 } 348 } 349 if (ref $option{stderr}) { 350 if ($option{stderr} =~ /^(IO::File|FileHandle)/) { 351 $handle_err = $option{stderr}; 352 } 353 } 354 355 my $same = 0; 356 if ($option{stdout} eq $option{stderr}) { 357 $same = 1; 358 } 359 360 my $mode_stdout; 361 my $mode_stderr; 362 if ($option{mode_stdout} =~ /^w/i) { 363 $mode_stdout = '>'; 364 } elsif ($option{mode_stdout} =~ /^a/i) { 365 $mode_stdout = '>>'; 366 } else { 367 warn "unknown mode. : " . quotemeta($option{mode_stdout}); 368 $mode_stdout = '>>'; 369 } 370 if ($option{mode_stderr} =~ /^w/i) { 371 $mode_stderr = '>'; 372 } elsif ($option{mode_stderr} =~ /^a/i) { 373 $mode_stderr = '>>'; 374 } else { 375 warn "unknown mode. : " . quotemeta($option{mode_stderr}); 376 $mode_stderr = '>>'; 377 } 378 379 my $text_stdout = undef; 380 my $text_stderr = undef; 381 if ($option{mode_stdout} =~ /^.t/i) { 382 $text_stdout = 1; 383 } 384 if ($option{mode_stderr} =~ /^.t/i) { 385 $text_stderr = 1; 386 } 387 388 if ($English::OSNAME eq "MSWin32" || $English::OSNAME eq "os2") { 389 foreach my $arg (@args) { 390 $arg =~ s!/!\\!g; 391 } 392 if ($args[0] =~ m/\.bat$/i) { 393 my $conts = util::readfile($args[0]); 394 codeconv::normalize_document(\$conts); 395 if ($conts =~ m/^\@rem\s=\s'--\*-Perl-\*--/i) { 396 @args = ("perl", @args); 397 } else { 398 my $comspec = "cmd"; 399 $comspec = $ENV{'COMSPEC'} if (defined $ENV{'COMSPEC'}); 400 if ($comspec =~ m/command\.com$/i) { 401 $comspec = pltests::checkcmd('win95cmd.exe'); 402 unless (defined $comspec) { 403 cdie 'win95cmd.exe not found.'; 404 } 405 $ENV{'COMSPEC'} = $comspec; 406 } 407 @args = ($comspec, "/d", "/x", "/c", @args); 408 } 409 } 410 } 411 412 my $fh_out = undef; 413 my $fh_err = undef; 414 415 if (defined $handle_out) { 416 $fh_out = $handle_out; 417 } else { 418 $fh_out= IO::File->new_tmpfile(); 419 } 420 if ($same) { 421 $fh_err = $fh_out; 422 } else { 423 if (defined $handle_err) { 424 $fh_err = $handle_err; 425 } else { 426 $fh_err = IO::File->new_tmpfile(); 427 } 428 } 429 430 { 431 my $saveout = new IO::File (">&" . STDOUT->fileno()) or cdie "Can't dup STDOUT: $!"; 432 my $saveerr = new IO::File (">&" . STDERR->fileno()) or cdie "Can't dup STDERR: $!"; 433 STDOUT->fdopen($fh_out->fileno(), 'w') or cdie "Can't open fh_out: $!"; 434 STDERR->fdopen($fh_err->fileno(), 'w') or cdie "Can't open fh_out: $!"; 435 436 # backup $ENV{} 437 my %backup; 438 my ($key, $value); 439 while(($key, $value) = each %env) { 440 $backup{$key} = $ENV{$key}; 441 if (defined $value) { 442 $ENV{$key} = $value; 443 } else { 444 delete $ENV{$key}; 445 } 446 } 447 448 dprint(_("Invoked: ") . join(' ', @args)); 449 450 # Use an indirect object: see Perl Cookbook Recipe 16.2 in detail. 451 $status = system { $args[0] } @args; 452 453 # restore $ENV{} 454 while(($key, $value) = each %env) { 455 if (defined $backup{$key}) { 456 $ENV{$key} = $backup{$key}; 457 } else { 458 delete $ENV{$key}; 459 } 460 } 461 462 STDOUT->fdopen($saveout->fileno(), 'w') or cdie "Can't restore saveout: $!"; 463 STDERR->fdopen($saveerr->fileno(), 'w') or cdie "Can't restore saveerr: $!"; 464 } 465 466 # Note that the file position of filehandles must be rewinded. 467 $fh_out->seek(0, SEEK_SET) or cdie "seek: $!"; 468 $fh_err->seek(0, SEEK_SET) or cdie "seek: $!"; 469 470 if (!defined $handle_out) { 471 if (ref($option{stdout}) ne 'SCALAR') { 472 if ($option{stdout} eq '/dev/null') { 473 $fh_out->close(); 474 } else { 475 my $conts_out = ""; 476 my $size = -s $fh_out; 477 read $fh_out, $conts_out, $size; 478 $fh_out->close(); 479 codeconv::normalize_nl(\$conts_out) if (defined $text_stdout); 480 481 my $file = $option{stdout}; 482 if ($English::OSNAME eq "MSWin32" || $English::OSNAME eq "os2") { 483 $file =~ s!/!\\!g; 484 } 485 if (!open(OUT, "$mode_stdout$file")) { 486 warn "Can not open file. : $file"; 487 return (1); 488 } 489 print OUT $conts_out; 490 close(OUT); 491 } 492 } else { 493 my $conts_out = $option{stdout}; 494 my $size = -s $fh_out; 495 read $fh_out, $$conts_out, $size; 496 $fh_out->close(); 497 codeconv::normalize_nl($conts_out) if (defined $text_stdout); 498 } 499 } 500 501 if (!(defined $handle_err || $same)) { 502 if (ref($option{stderr}) ne 'SCALAR') { 503 if ($option{stderr} eq '/dev/null') { 504 $fh_err->close(); 505 } else { 506 my $conts_err = ""; 507 my $size = -s $fh_err; 508 read $fh_err, $conts_err, $size; 509 $fh_err->close(); 510 codeconv::normalize_nl(\$conts_err) if (defined $text_stderr); 511 512 my $file = $option{stderr}; 513 if ($English::OSNAME eq "MSWin32" || $English::OSNAME eq "os2") { 514 $file =~ s!/!\\!g; 515 } 516 if (!open(OUT, "$mode_stderr$file")) { 517 warn "Can not open file. : $file"; 518 return (1); 519 } 520 print OUT $conts_err; 521 close(OUT); 522 } 523 } else { 524 my $conts_err = $option{stderr}; 525 my $size = -s $fh_err; 526 read $fh_err, $$conts_err, $size; 527 $fh_err->close(); 528 codeconv::normalize_nl($conts_err) if (defined $text_stderr); 529 } 530 } 531 532 return ($status); 533} 534 535# Returns a string representation of the null device. 536# We can use File::Spec->devnull() on Perl-5.6, instead. 537sub devnull { 538 if ($English::OSNAME eq "MSWin32") { 539 return "nul"; 540 } elsif ($English::OSNAME eq "os2") { 541 return "/dev/nul"; 542 } elsif ($English::OSNAME eq "MacOS") { 543 return "Dev:Null"; 544 } elsif ($English::OSNAME eq "VMS") { 545 return "_NLA0:"; 546 } else { # Unix 547 return "/dev/null"; 548 } 549} 550 551# convert \ to / with consideration for Shift_JIS Kanji code 552sub win32_yen_to_slash ($) { 553 my ($filenameref) = @_; 554 if (($English::OSNAME eq "MSWin32") || ($English::OSNAME eq "os2")) { 555 $$filenameref =~ 556 s!([\x81-\x9f\xe0-\xef][\x40-\x7e\x80-\xfc]|[\x01-\x7f])! 557 $1 eq "\\" ? "/" : $1!gex; 558 } 559} 560 561# Substitution of "-r" that doesn't correspond to ACL of NTFS 562sub canopen($) 563{ 564 my ($file) = @_; 565 566 my $fh; 567 568 return (-r $file) if ($English::OSNAME ne "MSWin32"); 569 570 $fh = new IO::File $file, "r"; 571 572 return 0 if (!defined $fh); 573 574 $fh->close(); 575 576 return 1; 577} 578 5791; 580