1# -*-Perl-*- 2################################################################ 3### 4### Util.pm 5### 6### Author: Internet Message Group <img@mew.org> 7### Created: Apr 23, 1997 8### Revised: Apr 23, 2007 9### 10 11my $PM_VERSION = "IM::Util.pm version 20161010(IM153)"; 12 13package IM::Util; 14require 5.003; 15require Exporter; 16 17use integer; 18use strict; 19use vars qw(@ISA @EXPORT 20 $SUCCESS $ERROR $EXIT_SUCCESS $EXIT_ERROR 21 $old); # why not my($old)? 22 23@ISA = qw(Exporter); 24@EXPORT = qw($SUCCESS $ERROR $EXIT_SUCCESS $EXIT_ERROR 25 unixp win95p wntp os2p 26 progname 27 im_getlogin 28 im_msg im_info im_debug im_notice im_warn im_err im_die im_die2 29 im_save_error im_saved_errors im_open im_sysopen 30 debug_option set_debug debug set_verbose verbose 31 flush); 32 33use vars qw($OS $SavedMsg %Debug); 34 35### 36### Constant 37### 38 39$SUCCESS = 1; 40$ERROR = 0; 41 42$EXIT_SUCCESS = 0; 43$EXIT_ERROR = 1; 44 45### 46### get OS name 47### 48 49my $osname = $^O; 50 51if ($osname =~ /win/i && $osname !~ /darwin/i) { 52 eval { 53 if (Win32::IsWinNT()) { 54 $OS = 'WNT'; 55 } elsif (Win32::IsWin95()) { 56 $OS = 'WIN95'; 57 } else { 58 $OS = 'WIN95'; # xxx 59 } 60 }; 61 if ($@) { 62 $OS = 'UNIX'; 63 } 64} elsif ($osname =~ /os2/i) { 65 $OS = 'OS/2'; 66} else { 67 $OS = 'UNIX'; 68} 69 70sub unixp { 71 if ($OS eq 'UNIX') { 72 return 1; 73 } else { 74 return 0; 75 } 76} 77 78sub win95p { 79 if (($OS eq 'WIN95') || ($OS eq 'WNT')) { 80 return 1; 81 } else { 82 return 0; 83 } 84} 85 86sub wntp { 87 if ($OS eq 'WNT') { 88 return 1; 89 } else { 90 return 0; 91 } 92} 93 94sub os2p { 95 if ($OS eq 'OS/2') { 96 return 1; 97 } else { 98 return 0; 99 } 100} 101 102sub progname() { 103 return $main::Prog; 104} 105 106### 107### get login name 108### 109sub im_getlogin() { 110 if (&unixp()) { 111 my $login = getlogin(); 112 if ($login ne '' && $login ne 'root') { 113 return $login; 114 } else { 115 return (getpwuid($<))[0] || undef; 116 } 117 } elsif (&os2p()) { 118 return getlogin() || undef; 119 } elsif (&win95p()) { 120 return Win32::LoginName(); 121 } 122} 123 124### 125### message 126### 127 128# im_msg - display desired information 129# im_debug - display debugging information (with --debug or something) 130# im_info - display informational messages (hidden with --quiet) 131# im_notice - display process tracing information (shown with --verbose) 132# im_warn - display problem report -- the problem may be ignored 133# im_err - display critical error messages -- process will be aborted 134# im_die - display critical error messages and exit 135 136sub im_msg($) { 137 my $msg = shift; 138 print progname(), ': ', $msg; 139} 140 141sub im_info($) { 142 my $info = shift; 143 return if $main::opt_quiet; 144 print progname(), ': ', $info; 145} 146 147sub im_debug($) { 148 my $dbg = shift; 149 print STDERR progname(), ':DEBUG: ', $dbg; 150} 151 152sub im_notice($) { 153 return unless &verbose; 154 my $warn = progname() . ': '. shift; 155 $SavedMsg .= $warn; 156 print STDERR $warn; 157} 158 159sub im_warn($) { 160 my $warn = progname() . ': '. shift; 161 $SavedMsg .= $warn; 162 print STDERR $warn; 163} 164 165sub im_err($) { 166 my $err = progname() . ': ERROR: ' . shift; 167 $SavedMsg .= $err; 168 print STDERR $err; 169} 170 171sub im_die($) { 172 my $die = shift; 173 print STDERR progname(), ': ERROR: ', $die; 174 exit $EXIT_ERROR; 175} 176 177sub im_die2($) { 178 my $die = shift; 179 print STDERR progname(), ': ', $die; 180 exit $EXIT_ERROR; 181} 182 183sub im_save_error(;$) { 184 my $string = shift; 185 if ($string eq '') { 186 $SavedMsg = ''; # reset 187 } else { 188 $SavedMsg .= $string; 189 } 190} 191 192sub im_saved_errors() { 193 return $SavedMsg; 194} 195 196### 197### Debug 198### 199 200sub print_hash(\%) { 201 my $hashref = shift; 202 203 foreach (keys(%{$hashref})) { 204 print "$_ -> $hashref->{$_}\n"; 205 } 206} 207 208sub set_debug($$) { 209 my $category = shift; 210 211 $Debug{$category} = shift; 212} 213 214sub debug($) { 215 my $category = shift; 216 217 if ($Debug{'all'}) { 218 return $Debug{'all'}; 219 } else { 220 return $Debug{$category}; 221 } 222} 223 224sub set_verbose($) { 225 $main::opt_verbose = shift; 226} 227 228sub verbose() { 229 return $main::opt_verbose; 230} 231 232##### SET DEBUG OPTION ##### 233# 234# debug_option() 235# 236sub debug_option($) { 237 my $DebugFlag = shift; 238 239 if ($DebugFlag && ($DebugFlag !~ /^(off|no|false|0)$/)) { 240 foreach (split(',', $DebugFlag)) { 241 im_warn("setting debug level $_=1\n"); 242 &set_debug($_, 1); 243 } 244 &set_verbose(1); 245 } 246} 247 248# 249# flush buffer 250# 251 252sub flush(*) { 253 local($old) = select(shift); 254 $| = 1; 255 print ''; 256 $| = 0; 257 select($old); 258} 259 260# 261# open file 262# 263 264sub im_open($$) { 265 my($d, $f) = @_; 266 my($r); 267 if ($> != 0) { 268 $f =~ /(.+)/; # may be tainted 269 $f = $1; # clean up 270 } 271 if ($r = open($d, $f)) { 272 binmode($d); 273 } 274 return $r; 275} 276 277sub im_sysopen($$$) { 278 my($d, $f, $a) = @_; 279 my($r); 280 if ($> != 0) { 281 $f =~ /(.+)/; # may be tainted 282 $f = $1; # clean up 283 } 284 if ($r = sysopen($d, $f, $a)) { 285 binmode($d); 286 } 287 return $r; 288} 289 2901; 291 292__END__ 293 294=head1 NAME 295 296IM::Util - utility functions for IM 297 298=head1 SYNOPSIS 299 300 use IM::Util; 301 302Constant variables: 303$SUCCESS 304$ERROR 305$EXIT_SUCCESS 306$EXIT_ERROR 307 308Subroutines: 309unixp win95p wntp os2p 310progname 311im_getlogin 312im_msg im_info im_debug im_notice im_warn im_err im_die im_die2 313im_save_error im_saved_errors im_open im_sysopen 314debug_option set_debug debug set_verbose verbose 315flush 316 317=head1 DESCRIPTION 318 319The I<IM::Util> module provides utility functions for IM. 320 321This modules is provided by IM (Internet Message). 322 323=head1 COPYRIGHT 324 325IM (Internet Message) is copyrighted by IM developing team. 326You can redistribute it and/or modify it under the modified BSD 327license. See the copyright file for more details. 328 329=cut 330 331### Copyright (C) 1997, 1998, 1999 IM developing team 332### All rights reserved. 333### 334### Redistribution and use in source and binary forms, with or without 335### modification, are permitted provided that the following conditions 336### are met: 337### 338### 1. Redistributions of source code must retain the above copyright 339### notice, this list of conditions and the following disclaimer. 340### 2. Redistributions in binary form must reproduce the above copyright 341### notice, this list of conditions and the following disclaimer in the 342### documentation and/or other materials provided with the distribution. 343### 3. Neither the name of the team nor the names of its contributors 344### may be used to endorse or promote products derived from this software 345### without specific prior written permission. 346### 347### THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND 348### ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 349### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 350### PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE 351### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 352### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 353### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 354### BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 355### WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 356### OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 357### IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 358