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