event.pm.tail 6.33 KB
Newer Older
1
2
3
#
# CODE PAST THIS POINT WAS NOT AUTOMATICALLY GENERATED BY SWIG
#
4
#
5
# Copyright (c) 2000-2018 University of Utah and the Flux Group.
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# 
# {{{EMULAB-LICENSE
# 
# This file is part of the Emulab network testbed software.
# 
# This file is free software: you can redistribute it and/or modify it
# under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
# 
# This file is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General Public
# License for more details.
# 
# You should have received a copy of the GNU Affero General Public License
# along with this file.  If not, see <http://www.gnu.org/licenses/>.
# 
# }}}
25
#
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
# For now, this has to get cat'ed onto the end of event.pm, since it
# doesn't seem possible to get SWIG to just pass it through into the
# output file
#

#
# Stash away the given callback and data, and call the C event_subscribe
# function that uses a stub callback
#
sub event_subscribe($$$;$) {
	my ($handle,$function,$tuple,$data) = @_;
	$event::callback = $function;
	$event::callback_data = $data;
	return stub_event_subscribe($handle,$tuple);
}

#
# Clear $callback_ready, call the C event_poll function, and see if the
# C callback got called (as evidenced by $callback_ready getting set) If it
45
46
# did, call the perl callback function. Handle both blocking and non-blocking
# versions of the call
47
#
48
49
50
51
52
53
54
55
56
sub internal_event_poll($$$) {
	my ($handle, $block, $timeout) = @_;

	my $rv;
	if ($block) {
		$rv = c_event_poll_blocking($handle,$timeout);
	} else {
		$rv = c_event_poll($handle);
	}
57
58

	if ($rv) {
59
		die "Trouble in event_poll - returned $rv\n";
60
61
	}

62
63
	while (my $data = dequeue_callback_data() ) {
		&$event::callback($handle,$data->{callback_notification},
64
				$event::callback_data);
65
66
		event_notification_free($handle,$data->{callback_notification});
		free_callback_data($data);
67
68
69
70
71
	}

	return 0;
}

72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
#
# Wrapper for the internal polling function, non-blocking version
#
sub event_poll($) {
	my $handle = shift;
	return &internal_event_poll($handle,0,0);
}

#
# Same as above, but for the blocking version
#
sub event_poll_blocking($$) {
	my ($handle, $timeout) = @_;
	return &internal_event_poll($handle,1,$timeout);
}

88
89
90
91
92
93
94
#
# NOTE: The following line will only work if this module is included by
# a file that has already done a 'use lib' to get the path to testbed
# libraries in the INC path. But, since they had to do that to get this
# library anyway, shouldn't be a problem. (Didn't want to have to make
# this a .in file.)
#
95
96
use English;
use Carp qw(cluck);
97
98
99
100
101
102
103
104
use libtestbed;

#
# Conveniece functions - Intended to work like DBQuery* from libdb .
# Much of this code shamlessly ripped off from libdb.pm
#

#
105
# Warn after a failed event send. First argument is the error
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
# message to display. The contents of $EventErrorString is also printed.
# 
# usage: EventWarn(char *message)
#
sub EventWarn($) {
	my($message) = $_[0];
	my($text, $progname);

	#
	# Must taint check $PROGRAM_NAME cause it comes from outside. Silly!
	#
	if ($PROGRAM_NAME =~ /^([-\w.\/]+)$/) {
		$progname = $1;
	} else {
		$progname = "Tainted";
	}

123
	$text = "$message - In $progname - $EventErrorString";
124

125
	cluck($text);
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
}

#
# Same as above, but die after the warning.
# 
# usage: EventFatal(char *message);
#
sub EventFatal($) {
	my($message) = $_[0];

	EventWarn($message);

	die("\n");
}


#
# Conveniece function - Intended to work like DBQueryFatal from libdb
#
sub EventSendFatal(@) {
	my @tuple = @_;
    
	my $result = EventSend(@tuple);

	if (!$result) {
		EventFatal("Event Send failed");
	}

	return $result;
}

#
# Conveniece function - Intended to work like DBQueryWarn from libdb
#
sub EventSendWarn(@) {
	my @tuple = @_;
    
	my $result = EventSend(@tuple);

	if (!$result) {
166
		EventWarn("Event Send failed");
167
168
169
170
171
	}

	return $result;
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
#
# Register with the event system. You would use this if you are not
# running on boss. The inline registration below is a convenience for
# testbed software, but is technically bad practice. See the END block
# below where we disconnect at exit.
#
sub EventRegister(;$$) {
        my ($host, $port) = @_;

	if ($event::EventSendHandle) {
	        if (event_unregister($event::EventSendHandle) == 0) {
			warn "Could not unregister with event system";
		}
		$event::EventSendHandle = undef;
	}

	$host = TB_EVENTSERVER()
	    if (!defined($host));

	my $URL = "elvin://$host";
	$URL   .= ":$port"
	    if (defined($port));
	
	$event::EventSendHandle = event_register($URL,0);
	
	if (!$event::EventSendHandle) {
		$EventErrorString = "Unable to register with the event system";
		return undef;
	}

	return 1;
}

205
206
207
sub EventSend(@) {
	my %tuple_values = @_;

208
209
210
211
212
	#
	# Only connect on the first call - thereafter, just use the existing
	# handle. The handle gets disconnected in the END block below
	#
	if (!$event::EventSendHandle) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
213
		EventRegister("localhost", TB_BOSSEVENTPORT());
214
215
216
217
218
219

		if (!$event::EventSendHandle) {
			$EventErrorString =
				"Unable to register with the event system";
			return undef;
		}
220
221
222
223
224
225
226
227
228
229
230
231
232
	}

	my $tuple = address_tuple_alloc();
	if (!$tuple) {
		$EventErrorString = "Unable to allocate an address tuple";
		return undef;
	}

	#
	# Set the values the user requested
	#
	%$tuple = %tuple_values;

233
234
	my $notification = event_notification_alloc($event::EventSendHandle,
		$tuple);
235
236
237
238
239
	if (!$notification) {
		$EventErrorString = "Could not allocate notification";
		return undef;
	}

240
	if (!event_notify($event::EventSendHandle, $notification)) {
241
242
243
244
		$EventErrorString = "Could not send event notification";
		return undef;
	}

245
	event_notification_free($event::EventSendHandle, $notification);
246
247
248
249
250
	address_tuple_free($tuple);

	return 1;
}

251
252
253
254
255
256
257
258
259
#
# After a fork, undef the handle to the event system so that we form a
# a new connection in the child. Do not disconnect from the child; I have
# no idea what that will do to the parent connection.
#
sub EventFork() {
    $event::EventSendHandle = undef;
}

260
261
262
263
264
265
266
267
268
269
#
# When we exit, unregister with the event system if we're connected
#
END {
    	if ($event::EventSendHandle) {
		if (event_unregister($event::EventSendHandle) == 0) {
			warn "Could not unregister with event system";
		}
	}
}
270

271
push @EXPORT, qw(event_subscribe event_poll event_poll_blocking EventSend
Leigh B. Stoller's avatar
Leigh B. Stoller committed
272
	EventSendFatal EventSendWarn EventFork EventRegister);
273
274
1;