1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
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
166
167
168
169
170
171
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
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
package SGMLS::Output;
use Carp;
use Exporter;
@ISA = Exporter;
@EXPORT = qw(output push_output pop_output);
$version = '$Id: Output.pm,v 1.6 1995/12/05 12:21:51 david Exp $';
=head1 NAME
SGMLS::Output - Stack-based Output Procedures
=head1 SYNOPSIS
use SGMLS::Output;
To print a string to the current output destination:
output($data);
To push a new output level to the filehandle DATA:
push_output('handle',DATA);
To push a new output level to the file "foo.data" (which will be
opened and closed automatically):
push_output('file','foo.data');
To push a new output level to a pipe to the shell command "sort":
push_output('pipe','sort');
To push a new output level I<appending> to the file "foo.data":
push_output('append','foo.data');
To push a new output level to an empty string:
push_output('string');
To push a new output level appending to the string "David is ":
push_output('string',"David is ");
To push a new output level to The Great Beyond:
push_output('nul');
To revert to the previous output level:
pop_output();
To revert to the previous output level, returning the contents of an
output string:
$data = pop_output();
=head1 DESCRIPTION
This library allows redirectable, stack-based output to files, pipes,
handles, strings, or nul. It is especially useful for packages like
L<SGMLS>, since handlers for individual B<SGML> elements can
temporarily change and restore the default output destination. It is
also particularly useful for capturing the contents of an element (and
its sub-elements) in a string.
Example:
sgmls('<title>', sub{ push_output('string'); });
sgmls('</title>', sub{ $title = pop_output(); });
In between, anything sent to B<output> (such as CDATA) will be
accumulated in the string returned from B<pop_output()>.
Example:
sgmls('<tei.header>', sub { push_output('nul'); });
sgmls('</tei.header>', sub { pop_output(); });
All output will be ignored until the header has finished.
=head1 AUTHOR AND COPYRIGHT
Copyright 1994 and 1995 by David Megginson,
C<dmeggins@aix1.uottawa.ca>. Distributed under the terms of the Gnu
General Public License (version 2, 1991) -- see the file C<COPYING>
which is included in the B<SGMLS.pm> distribution.
=head1 SEE ALSO:
L<SGMLS>.
=cut
#
# Anonymous subroutines for handling different types of references.
#
$output_handle_sub = sub {
print $current_output_data @_;
};
$output_file_sub = sub {
print $current_output_data @_;
};
$output_string_sub = sub {
$current_output_data .= shift;
foreach (@_) {
$current_output_data .= $, . $_;
}
$current_output_data .= $\;
};
$output_nul_sub = sub {};
#
# Status variables
#
$current_output_type = 'handle';
$current_output_data = STDOUT;
$current_output_sub = $output_handle_sub;
@output_stack = qw();
#
# Externally-visible functions
#
# Send data to the output.
sub output {
&{$current_output_sub}(@_);
}
# Push a new output destination.
sub push_output {
my ($type,$data) = @_;
push @output_stack, [$current_output_type,$current_output_data,
$current_output_sub];
SWITCH: {
$type eq 'handle' && do {
# Force unqualified filehandles into caller's package
my ($package) = caller;
$data =~ s/^[^':]+$/$package\:\:$&/;
$current_output_sub = $output_handle_sub;
$current_output_type = 'handle';
$current_output_data = $data;
last SWITCH;
};
$type eq 'file' && do {
$current_output_sub = $output_file_sub;
my $handle = new_handle();
open($handle,">$data") || croak "Cannot create file $data.\n";
$current_output_type = 'file';
$current_output_data = $handle;
last SWITCH;
};
$type eq 'pipe' && do {
$current_output_sub = $output_file_sub;
my $handle = new_handle();
open($handle,"|$data") || croak "Cannot open pipe to $data.\n";
$current_output_type = 'file';
$current_output_data = $handle;
last SWITCH;
};
$type eq 'append' && do {
$current_output_sub = $output_file_sub;
my $handle = new_handle();
open($handle,">>$data") || croak "Cannot append to file $data.\n";
$current_output_type = 'file';
$current_output_data = $handle;
last SWITCH;
};
$type eq 'string' && do {
$current_output_sub = $output_string_sub;
$current_output_type = 'string';
$current_output_data = $data;
last SWITCH;
};
$type eq 'nul' && do {
$current_output_sub = $output_nul_sub;
$current_output_type = 'nul';
$current_output_data = '';
last SWITCH;
};
croak "Unknown output type: $type.\n";
}
}
# Pop the current output destination.
sub pop_output {
my ($old_type,$old_data) = ($current_output_type,$current_output_data);
($current_output_type,$current_output_data,$current_output_sub) =
@{pop @output_stack};
SWITCH: {
$old_type eq 'handle' && do {
return $old_data;
};
$old_type eq 'file' && do {
close($old_data);
return '';
};
$old_type eq 'string' && do {
return $old_data;
};
$old_type eq 'nul' && do {
return '';
};
croak "Unknown output type: $type.\n";
}
}
#
# Local Utility functions.
#
$new_handle_counter = 1;
sub new_handle {
return "IOHandle" . $new_handle_counter++;
}
1;
|
