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
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
|
program testxmlchan
implicit none
include 'SAE_PAR'
include 'AST_PAR'
include 'testxmlchan_com'
integer status, obj, i, ifmt, nfmt
character fmt(2)*30
logical ok
data nfmt /2/,
: fmt / 'native', 'quoted' /
status = sai__ok
call ast_begin( status )
*
* Create an AST object.
*
call makeobject( obj, status )
*
* Create a normal Channel and write the object out to file1
*
call chanwrite( obj, 1, status )
*
* Test each XML format in turn.
do ifmt = 1, nfmt
*
* Create an XmlChan and write the object out to file2 using the current
* format.
*
call xmlwrite( obj, 2, fmt( ifmt ), status )
*
* Use a new XmlChan to read an object from file2
*
call xmlread( 2, obj, status )
*
* Write this object out to file 3 using a simple Channel.
*
call chanwrite( obj, 3, status )
*
* Report an error if the contents of files 1 and 3 differ.
*
ok = .true.
if( filelen( 1 ) .ne. filelen( 3 ) ) then
write(*,*) 'TestXmlChan: files 1 and 3 have different '//
: 'lengths (',filelen( 1 ),',',filelen( 3 ),').'
ok =.false.
else
do i = 1, filelen( 1 )
if( files( 1, i ) .ne. files( 3, i ) ) then
write(*,*) 'TestXmlChan: Line ',i,' differs in '//
: 'files 1 and 3:'
write(*,*) files( 1, i )
write(*,*) files( 3, i )
ok = .false.
go to 10
end if
end do
end if
10 continue
if( .not. ok ) then
write(*,*) 'TestXmlChan: Test failed on XmlFormat ''',
: fmt(ifmt),'''.'
go to 20
end if
end do
20 continue
call ast_end( status )
if( ok ) then
write(*,*) 'All XmlChan tests passed'
else
write(*,*) 'XmlChan tests failed'
end if
end
*
* Reads line "iline" from internal file "ifile" and returns it to AST using
* the AST_PULINE routine. Then increments "iline" ready for next time.
*
subroutine source( status )
implicit none
include 'testxmlchan_com'
integer status, l, chr_len
if( iline .le. filelen( ifile ) ) then
l = chr_len( files(ifile,iline) )
call ast_putline( files(ifile,iline), l, status )
iline = iline + 1
else
call ast_putline( ' ', -1, status )
end if
end
*
* Append a line obtained using ast_getline function to the end of the
* internal file indicated by "ifile", and increment the file length.
*
subroutine sink( status )
implicit none
include 'testxmlchan_com'
integer status, l
character line*(linelen)
call ast_getline( line, l, status )
if( l .gt. 0 ) then
if( filelen( ifile ) .ge. mxline ) then
stop 'TestXmlChan: Too many lines sent to sink function'
else if( l .gt. linelen ) then
stop 'TestXmlChan: Text truncated in sink function'
else
filelen( ifile ) = filelen( ifile ) + 1
files( ifile, filelen( ifile ) ) = line(:l)
end if
end if
end
*
* Create an AST object to be used as the test object.
*
subroutine makeobject( obj, status )
implicit none
include 'SAE_PAR'
include 'AST_PAR'
integer obj, sf, f, m, status
obj = ast__null
if( status .ne. sai__ok ) return
sf = Ast_SkyFrame( ' ', status )
f = Ast_Frame( 2, ' ', status )
call ast_setc( f, 'title', 'A new title', status )
m = ast_UnitMap( 2, ' ', status )
obj = ast_FrameSet( f, ' ', status )
call ast_addFrame( obj, 1, m, sf, status )
end
*
* Write the supplied object out to the specified internal file using a
* basic Channel.
*
subroutine chanwrite( obj, ifil, status )
implicit none
include 'SAE_PAR'
include 'AST_PAR'
include 'testxmlchan_com'
external sink
integer obj, ifil, status, ch
if( status .ne. sai__ok ) return
ifile = ifil
filelen( ifil ) = 0
ch = ast_channel( ast_null, sink, ' ', status )
if( ast_write( ch, obj, status ) .ne. 1 ) then
stop 'TestXmlChan: Failed to write object to Channel.'
end if
call ast_annul( ch, status )
end
*
* Write the supplied object out to the specified internal file using an
* XmlChan.
*
subroutine xmlwrite( obj, ifil, fmt, status )
implicit none
include 'SAE_PAR'
include 'AST_PAR'
include 'testxmlchan_com'
external sink
integer obj, ifil, status, ch
character fmt*(*)
if( status .ne. sai__ok ) return
ifile = ifil
filelen( ifil ) = 0
ch = ast_xmlchan( ast_null, sink, 'indent=1,comment=1',
: status )
call ast_seti( ch, 'xmllength', linelen, status )
call ast_setc( ch, 'xmlformat', fmt, status )
if( ast_write( ch, obj, status ) .ne. 1 ) then
stop 'TestXmlChan: Failed to write object to XmlChan.'
end if
call ast_annul( ch, status )
end
*
* Read an object out of the specified internal file using an XmlChan.
*
subroutine xmlread( ifil, obj, status )
implicit none
include 'SAE_PAR'
include 'AST_PAR'
include 'testxmlchan_com'
external source
integer obj, ifil, status, ch
if( status .ne. sai__ok ) return
ifile = ifil
iline = 1
ch = ast_xmlchan( source, ast_null, ' ', status )
obj = ast_read( ch, status )
if( obj .eq. ast__null ) then
stop 'TestXmlChan: Failed to read object from XmlChan.'
end if
call ast_annul( ch, status )
end
|
