Commit | Line | Data |
---|---|---|
a0d0e21e LW |
1 | package Sys::Syslog; |
2 | require 5.000; | |
3 | require Exporter; | |
4 | use Carp; | |
5 | ||
6 | @ISA = qw(Exporter); | |
7 | @EXPORT = qw(openlog closelog setlogmask syslog); | |
8 | ||
9 | # | |
10 | # syslog.pl | |
11 | # | |
12 | # $Log: syslog.pl,v $ | |
13 | # | |
14 | # tom christiansen <tchrist@convex.com> | |
15 | # modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> | |
16 | # NOTE: openlog now takes three arguments, just like openlog(3) | |
17 | # | |
18 | # call syslog() with a string priority and a list of printf() args | |
19 | # like syslog(3) | |
20 | # | |
21 | # usage: use Syslog; | |
22 | # | |
23 | # then (put these all in a script to test function) | |
24 | # | |
25 | # openlog($program,'cons,pid','user'); | |
26 | # syslog('info','this is another test'); | |
27 | # syslog('mail|warning','this is a better test: %d', time); | |
28 | # closelog(); | |
29 | # | |
30 | # syslog('debug','this is the last test'); | |
31 | # openlog("$program $$",'ndelay','user'); | |
32 | # syslog('notice','fooprogram: this is really done'); | |
33 | # | |
34 | # $! = 55; | |
35 | # syslog('info','problem was %m'); # %m == $! in syslog(3) | |
36 | ||
37 | $host = 'localhost' unless $host; # set $Syslog::host to change | |
38 | ||
39 | require 'syslog.ph'; | |
40 | ||
41 | $maskpri = &LOG_UPTO(&LOG_DEBUG); | |
42 | ||
43 | sub openlog { | |
44 | ($ident, $logopt, $facility) = @_; # package vars | |
45 | $lo_pid = $logopt =~ /\bpid\b/; | |
46 | $lo_ndelay = $logopt =~ /\bndelay\b/; | |
47 | $lo_cons = $logopt =~ /\bcons\b/; | |
48 | $lo_nowait = $logopt =~ /\bnowait\b/; | |
49 | &connect if $lo_ndelay; | |
50 | } | |
51 | ||
52 | sub closelog { | |
53 | $facility = $ident = ''; | |
54 | &disconnect; | |
55 | } | |
56 | ||
57 | sub setlogmask { | |
58 | local($oldmask) = $maskpri; | |
59 | $maskpri = shift; | |
60 | $oldmask; | |
61 | } | |
62 | ||
63 | sub syslog { | |
64 | local($priority) = shift; | |
65 | local($mask) = shift; | |
66 | local($message, $whoami); | |
67 | local(@words, $num, $numpri, $numfac, $sum); | |
68 | local($facility) = $facility; # may need to change temporarily. | |
69 | ||
70 | croak "syslog: expected both priority and mask" unless $mask && $priority; | |
71 | ||
72 | @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". | |
73 | undef $numpri; | |
74 | undef $numfac; | |
75 | foreach (@words) { | |
76 | $num = &xlate($_); # Translate word to number. | |
77 | if (/^kern$/ || $num < 0) { | |
78 | croak "syslog: invalid level/facility: $_"; | |
79 | } | |
80 | elsif ($num <= &LOG_PRIMASK) { | |
81 | croak "syslog: too many levels given: $_" if defined($numpri); | |
82 | $numpri = $num; | |
83 | return 0 unless &LOG_MASK($numpri) & $maskpri; | |
84 | } | |
85 | else { | |
86 | croak "syslog: too many facilities given: $_" if defined($numfac); | |
87 | $facility = $_; | |
88 | $numfac = $num; | |
89 | } | |
90 | } | |
91 | ||
92 | croak "syslog: level must be given" unless defined($numpri); | |
93 | ||
94 | if (!defined($numfac)) { # Facility not specified in this call. | |
95 | $facility = 'user' unless $facility; | |
96 | $numfac = &xlate($facility); | |
97 | } | |
98 | ||
99 | &connect unless $connected; | |
100 | ||
101 | $whoami = $ident; | |
102 | ||
103 | if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { | |
104 | $whoami = $1; | |
105 | $mask = $2; | |
106 | } | |
107 | ||
108 | unless ($whoami) { | |
109 | ($whoami = getlogin) || | |
110 | ($whoami = getpwuid($<)) || | |
111 | ($whoami = 'syslog'); | |
112 | } | |
113 | ||
114 | $whoami .= "[$$]" if $lo_pid; | |
115 | ||
116 | $mask =~ s/%m/$!/g; | |
117 | $mask .= "\n" unless $mask =~ /\n$/; | |
118 | $message = sprintf ($mask, @_); | |
119 | ||
120 | $sum = $numpri + $numfac; | |
121 | unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { | |
122 | if ($lo_cons) { | |
123 | if ($pid = fork) { | |
124 | unless ($lo_nowait) { | |
125 | do {$died = wait;} until $died == $pid || $died < 0; | |
126 | } | |
127 | } | |
128 | else { | |
129 | open(CONS,">/dev/console"); | |
130 | print CONS "<$facility.$priority>$whoami: $message\r"; | |
131 | exit if defined $pid; # if fork failed, we're parent | |
132 | close CONS; | |
133 | } | |
134 | } | |
135 | } | |
136 | } | |
137 | ||
138 | sub xlate { | |
139 | local($name) = @_; | |
140 | $name =~ y/a-z/A-Z/; | |
141 | $name = "LOG_$name" unless $name =~ /^LOG_/; | |
748a9306 | 142 | $name = "Sys::Syslog::$name"; |
a0d0e21e LW |
143 | eval(&$name) || -1; |
144 | } | |
145 | ||
146 | sub connect { | |
147 | $pat = 'S n C4 x8'; | |
148 | ||
149 | $af_unix = 1; | |
150 | $af_inet = 2; | |
151 | ||
152 | $stream = 1; | |
153 | $datagram = 2; | |
154 | ||
155 | ($name,$aliases,$proto) = getprotobyname('udp'); | |
156 | $udp = $proto; | |
157 | ||
158 | ($name,$aliase,$port,$proto) = getservbyname('syslog','udp'); | |
159 | $syslog = $port; | |
160 | ||
161 | if (chop($myname = `hostname`)) { | |
162 | ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname); | |
163 | croak "Can't lookup $myname" unless $name; | |
164 | @bytes = unpack("C4",$addrs[0]); | |
165 | } | |
166 | else { | |
167 | @bytes = (0,0,0,0); | |
168 | } | |
169 | $this = pack($pat, $af_inet, 0, @bytes); | |
170 | ||
171 | if ($host =~ /^\d+\./) { | |
172 | @bytes = split(/\./,$host); | |
173 | } | |
174 | else { | |
175 | ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host); | |
176 | croak "Can't lookup $host" unless $name; | |
177 | @bytes = unpack("C4",$addrs[0]); | |
178 | } | |
179 | $that = pack($pat,$af_inet,$syslog,@bytes); | |
180 | ||
181 | socket(SYSLOG,$af_inet,$datagram,$udp) || croak "socket: $!"; | |
182 | bind(SYSLOG,$this) || croak "bind: $!"; | |
183 | connect(SYSLOG,$that) || croak "connect: $!"; | |
184 | ||
185 | local($old) = select(SYSLOG); $| = 1; select($old); | |
186 | $connected = 1; | |
187 | } | |
188 | ||
189 | sub disconnect { | |
190 | close SYSLOG; | |
191 | $connected = 0; | |
192 | } | |
193 | ||
194 | 1; | |
195 |