Commit | Line | Data |
4536f655 |
1 | # File: Stem/Switch.pm |
2 | |
3 | # This file is part of Stem. |
4 | # Copyright (C) 1999, 2000, 2001 Stem Systems, Inc. |
5 | |
6 | # Stem is free software; you can redistribute it and/or modify |
7 | # it under the terms of the GNU General Public License as published by |
8 | # the Free Software Foundation; either version 2 of the License, or |
9 | # (at your option) any later version. |
10 | |
11 | # Stem is distributed in the hope that it will be useful, |
12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
14 | # GNU General Public License for more details. |
15 | |
16 | # You should have received a copy of the GNU General Public License |
17 | # along with Stem; if not, write to the Free Software |
18 | # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
19 | |
20 | # For a license to use the Stem under conditions other than those |
21 | # described here, to purchase support for this software, or to purchase a |
22 | # commercial warranty contract, please contact Stem Systems at: |
23 | |
24 | # Stem Systems, Inc. 781-643-7504 |
25 | # 79 Everett St. info@stemsystems.com |
26 | # Arlington, MA 02474 |
27 | # USA |
28 | |
29 | package Stem::Switch ; |
30 | |
31 | use Stem::Trace 'log' => 'stem_status', 'sub' => 'TraceStatus' ; |
32 | use Stem::Trace 'log' => 'stem_error' , 'sub' => 'TraceError' ; |
33 | |
34 | use strict ; |
35 | |
36 | =head1 Stem::switch |
37 | |
38 | Stem::Switch has several functions: |
39 | |
40 | new |
41 | msg_in |
42 | data_in |
43 | map_cmd |
44 | info_cmd |
45 | status_cmd |
46 | |
47 | =cut |
48 | |
49 | my $this_package = __PACKAGE__ ; |
50 | |
51 | my $attr_spec = [ |
52 | |
53 | { |
54 | 'name' => 'reg_name', |
55 | 'required' => 1, |
56 | 'help' => <<HELP, |
57 | Required field. |
58 | This is a unique name used to register this instance of a Switch. |
59 | HELP |
60 | }, |
61 | |
62 | { |
63 | 'name' => 'in_map', |
64 | 'default' => {}, |
65 | 'type' => 'HoL', |
66 | 'help' => <<HELP, |
67 | This field contains the incoming address map. |
68 | Any message coming in to one of these addresses will be resent out |
69 | to every address in out_map. |
70 | HELP |
71 | }, |
72 | |
73 | { |
74 | 'name' => 'out_map', |
75 | 'default' => {}, |
76 | 'type' => 'HoL', |
77 | 'help' => <<HELP, |
78 | This contains the outgoing addresses for this Switch. |
79 | HELP |
80 | }, |
81 | ] ; |
82 | |
83 | =head2 new |
84 | |
85 | new creates a new Stem::Switch object, parsing $attr_spec and any arguments |
86 | passed to it. |
87 | |
88 | It returns the new object. |
89 | |
90 | =cut |
91 | |
92 | sub new { |
93 | |
94 | my( $class ) = shift ; |
95 | |
96 | my $self = Stem::Class::parse_args( $attr_spec, @_ ) ; |
97 | return $self unless ref $self ; |
98 | |
99 | ########## |
100 | # to be replaced with Stem::Class supporting 'hash' attribute types |
101 | ########## |
102 | |
103 | if ( ref $self->{'in_map'} eq 'ARRAY' ) { |
104 | |
105 | $self->{'in_map'} = { @{$self->{'in_map'}} } ; |
106 | } |
107 | |
108 | if ( ref $self->{'out_map'} eq 'ARRAY' ) { |
109 | |
110 | $self->{'out_map'} = { @{$self->{'out_map'}} } ; |
111 | } |
112 | |
113 | return( $self ) ; |
114 | } |
115 | |
116 | use Data::Dumper ; |
117 | |
118 | |
119 | sub msg_in { |
120 | |
121 | my( $self, $msg ) = @_ ; |
122 | |
123 | my $in_target = $msg->to_target() ; |
124 | |
125 | my $in_map = $self->{'in_map'}{$in_target} ; |
126 | |
127 | return unless $in_map ; |
128 | |
129 | my @out_keys = ref $in_map ? @{$in_map} : ($in_map) ; |
130 | |
131 | # loop over all the output keys for this in_map entry |
132 | |
133 | foreach my $out_key ( @out_keys ) { |
134 | |
135 | my $out_addr = $self->{'out_map'}{$out_key} ; |
136 | |
137 | next unless $out_addr ; |
138 | |
139 | my @out_addrs = ref $out_addr ? @{$out_addr} : ($out_addr) ; |
140 | |
141 | # loop over all the output address for this out_map entry |
142 | |
143 | foreach my $out_addr ( @out_addrs ) { |
144 | |
145 | # now we clone the message with the new address |
146 | |
147 | my $switched_msg = $msg->clone( |
148 | |
149 | 'to' => $out_addr, |
150 | ) ; |
151 | |
152 | $switched_msg->dispatch() ; |
153 | } |
154 | } |
155 | } |
156 | |
157 | |
158 | sub map_cmd { |
159 | |
160 | my( $self, $msg ) = @_ ; |
161 | |
162 | my @tokens = split( ' ', ${$msg->data()} ) ; |
163 | |
164 | my $target = shift @tokens ; |
165 | |
166 | $self->{'in_map'}{$target} = \@tokens ; |
167 | |
168 | return ; |
169 | } |
170 | |
171 | sub out_map_cmd { |
172 | |
173 | my( $self, $msg ) = @_ ; |
174 | |
175 | my @tokens = split( ' ', ${$msg->data()} ) ; |
176 | |
177 | my $key = shift @tokens ; |
178 | |
179 | $self->{'out_map'}{$key} = \@tokens ; |
180 | |
181 | return ; |
182 | } |
183 | |
184 | |
185 | sub info_cmd { |
186 | |
187 | my( $self, $msg ) = @_ ; |
188 | |
189 | return <<INFO ; |
190 | |
191 | Info Response |
192 | Class: $this_package |
193 | Ref: $self |
194 | |
195 | This cell is a message multiplex or switch. Any message addressed to a |
196 | target in the cell, can be resent to any subset of the output map |
197 | addresses. |
198 | |
199 | INFO |
200 | |
201 | } |
202 | |
203 | |
204 | sub status_cmd { |
205 | |
206 | my( $self, $msg ) = @_ ; |
207 | |
208 | my( $status_text ) ; |
209 | |
210 | $status_text = <<TEXT ; |
211 | |
212 | Status of switch: $self->{'reg_name'} |
213 | |
214 | In Map: |
215 | |
216 | TEXT |
217 | |
218 | foreach my $target ( sort keys %{$self->{'in_map'}} ) { |
219 | |
220 | my $targets_ref = $self->{'in_map'}{$target} ; |
221 | my @targets = ref $targets_ref ? |
222 | @{$targets_ref} : ($targets_ref) ; |
223 | |
224 | $status_text .= "\t$target -> @targets\n" ; |
225 | } |
226 | |
227 | $status_text .= "\nOut Map:\n\n" ; |
228 | |
229 | my $out_ref = $self->{'out_map'} ; |
230 | |
231 | foreach my $key ( sort keys %{$out_ref} ) { |
232 | |
233 | my $out_addr = $out_ref->{$key} ; |
234 | |
235 | my @out_addrs = ref $out_addr ? @{$out_addr} : ($out_addr) ; |
236 | |
237 | $status_text .= "\t$key -> @out_addrs\n" ; |
238 | } |
239 | |
240 | return $status_text ; |
241 | } |
242 | |
243 | 1 ; |