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 %page;
32 cv_dmcf:
33 procedure () options (variable);
34
35
36
37
38
39 dcl argp pointer;
40 dcl argl fixed bin (21);
41 dcl code fixed bin (35);
42 dcl dirname char (168);
43 dcl input_entryname char (32);
44 dcl output_entryname char (32);
45 dcl table_segment_was_created
46 bit (1) aligned init ("0"b);
47 dcl bc fixed bin (24);
48 dcl filep pointer init (null ());
49 dcl my_area area;
50 dcl tablep pointer init (null ());
51
52
53
54 dcl (
55 error_table_$translation_failed,
56 error_table_$sameseg,
57 error_table_$unimplemented_version
58 ) fixed bin (35) ext static;
59
60
61
62 dcl ME char (32) internal static options (constant) init ("cv_dmcf");
63 dcl (
64 INPUT_SUFFIX init ("dmcf"),
65 OUTPUT_SUFFIX init ("dmct")
66 ) char (4) internal static options (constant);
67
68 dcl LONG_ERRORS bit (1) aligned internal static options (constant) init ("1"b);
69 dcl (
70 FORCE_DELETE init ("1"b),
71 NO_QUERY init ("0"b),
72 NO_DIR init ("0"b),
73 SEG init ("1"b),
74 NO_LINK init ("0"b),
75 CHASE init ("1"b)
76 ) unaligned bit (1) internal static options (constant);
77 dcl (NO_PAD, NO_NL) init ("0"b) bit (1) aligned
78 internal static options (constant);
79
80
81
82 dcl arg char (argl) based (argp);
83
84
85
86 dcl com_err_ entry () options (variable);
87 dcl cu_$arg_list_ptr entry (ptr);
88 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
89 dcl delete_$ptr entry (ptr, bit (36) aligned, char (*), fixed bin (35));
90 dcl dm_translate_system_config_
91 entry (ptr, fixed bin (21), bit (1) aligned, ptr, ptr, fixed bin (35));
92 dcl expand_pathname_$add_suffix
93 entry (char (*), char (*), char (*), char (*), fixed bin (35));
94 dcl get_wdir_ entry () returns (char (168));
95 dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
96 dcl initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24),
97 fixed bin (35));
98 dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char(*), fixed bin(21), bit(1) aligned, bit(1) aligned);
99 dcl pathname_ entry (char (*), char (*)) returns (char (168));
100 dcl suffixed_name_$new_suffix
101 entry (char (*), char (*), char (*), char (32), fixed bin (35));
102 dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
103
104
105
106 dcl (addr, divide, empty, size, null)
107 builtin;
108
109
110
111 dcl cleanup condition;
112
113
114 ^L
115
116 on cleanup call ERROR_FINISH ();
117
118 call cu_$arg_ptr (1, argp, argl, code);
119 if code ^= 0
120 then
121 call ERROR_RETURN (code, "^/Usage is: cv_dmcf <config_file_path>");
122
123 call expand_pathname_$add_suffix (arg, INPUT_SUFFIX, dirname, input_entryname, code);
124 if code ^= 0
125 then
126 call ERROR_RETURN (code, "Supplied pathname was: ^a.", arg);
127
128
129
130 call initiate_file_ (dirname, input_entryname, R_ACCESS, filep, bc, code);
131 if filep = null ()
132 then
133 call ERROR_RETURN (code, "Error occurred while referencing ^a.", pathname_ (dirname, input_entryname));
134
135
136
137 call
138 dm_translate_system_config_ (filep, divide (bc, 9, 21, 0), LONG_ERRORS, addr (my_area), dm_system_config_ptr,
139 code);
140 if code ^= 0
141 then
142 call ERROR_RETURN (error_table_$translation_failed);
143
144 if dm_system_config.version ^= DM_CONFIG_VERSION_2
145 then
146 call ERROR_RETURN (error_table_$unimplemented_version,
147 "^/The dm_translate_system_config_ module did not produce the expected
148 version of the dm_system_config structure.
149 The expected version was ""^a"" and the received version was ""^a"".", dm_system_config.version, DM_CONFIG_VERSION_2);
150
151
152 call suffixed_name_$new_suffix (input_entryname, INPUT_SUFFIX, OUTPUT_SUFFIX, output_entryname, code);
153 if code ^= 0
154 then
155 call ERROR_RETURN (code, "^/Unable to make the output file name from the input file name.");
156
157 call
158 initiate_file_$create (get_wdir_ (), output_entryname, RW_ACCESS, tablep, table_segment_was_created, (0), code);
159
160 if tablep = null () then
161 call ERROR_RETURN (code, "Unable to create output segment.");
162 else if tablep = filep
163 then
164 call ERROR_RETURN (error_table_$sameseg, "Using the configuration file to store the configuration table.");
165 else
166 tablep -> dm_system_config = dm_system_config_ptr -> dm_system_config;
167
168 call FINISH ();
169 MAIN_RETURN:
170 return;
171
172 FINISH:
173 proc ();
174 if filep ^= null ()
175 then call terminate_file_ (filep, 0, TERM_FILE_TERM, code);
176
177 if tablep ^= null ()
178 then call terminate_file_ (tablep, size (dm_system_config) * 36, TERM_FILE_TRUNC_BC_TERM, code);
179 end FINISH;
180
181 ERROR_FINISH:
182 proc ();
183 if tablep ^= null ()
184 then
185 do;
186 if table_segment_was_created
187 then call delete_$ptr (tablep, FORCE_DELETE || NO_QUERY || NO_DIR || SEG || NO_LINK || CHASE, ME, code);
188 else call terminate_file_ (tablep, 0, TERM_FILE_TERM, code);
189 tablep = null ();
190 end;
191 call FINISH;
192
193 end ERROR_FINISH;
194
195 ERROR_RETURN:
196 proc () options (variable);
197 dcl er_arg_count fixed bin;
198 dcl er_arg_list_ptr ptr;
199 dcl er_based_error_code fixed bin (35) based;
200 dcl er_code fixed bin (35);
201 dcl 1 er_err_msg_struc,
202 2 length fixed bin (21),
203 2 string char (1024);
204 dcl er_err_msg varying char (1024)
205 based (addr (er_err_msg_struc));
206
207 call ERROR_FINISH ();
208 call cu_$arg_list_ptr (er_arg_list_ptr);
209 if er_arg_list_ptr -> arg_list.arg_count > 0 then
210 do;
211 if er_arg_list_ptr -> arg_list.arg_count > 2 then
212 call ioa_$general_rs (er_arg_list_ptr, 3, 4,
213 er_err_msg_struc.string, er_err_msg_struc.length,
214 NO_PAD, NO_NL);
215 else
216 er_err_msg = "";
217 call com_err_ (er_arg_list_ptr -> arg_list.arg_ptrs (1) -> er_based_error_code, ME, er_err_msg);
218 end;
219 goto MAIN_RETURN;
220 end ERROR_RETURN;
221 %page;
222
223 %page;
224 %include access_mode_values;
225 %page;
226 %include arg_list;
227 %page;
228 %include dm_system_config;
229 %page;
230 %include terminate_file;
231 end cv_dmcf;