source: trunk/src/netlabs/macros/callrexx.e@ 2417

Last change on this file since 2417 was 2417, checked in by Andreas Schnellbacher, 14 years ago
  • Added svn keywords.
  • Property svn:keywords set to Date Revision Author HeadURL Id
File size: 17.8 KB
Line 
1/****************************** Module Header *******************************
2*
3* Module Name: callrexx.e
4*
5* Copyright (c) Netlabs EPM Distribution Project 2002
6*
7* $Id: callrexx.e 2417 2011-05-15 23:32:51Z aschn $
8*
9* ===========================================================================
10*
11* This file is part of the Netlabs EPM Distribution package and is free
12* software. You can redistribute it and/or modify it under the terms of the
13* GNU General Public License as published by the Free Software
14* Foundation, in version 2 as it comes in the "COPYING" file of the
15* Netlabs EPM Distribution. This library is distributed in the hope that it
16* will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
17* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18* General Public License for more details.
19*
20****************************************************************************/
21/*
22Todo:
23- Part 2 contains defprocs, defined as defcs to use them in REXX.
24 Move them to where they belong to.
25*/
26
27/*
28 * Name CallRexx
29 *
30 * Author Ralph E. Yozzo & Larry Margolis
31 *
32 * Function Call a Rexx Macro from EPM
33 *
34 * The steps that are followed are:
35 *
36 * - We set up the default environment to point to EPM
37 * - We register our subcommand DLL.
38 * - We call the EPM-REXX macro.
39 */
40
41const
42 RXCOMMAND = '0'
43 RXSUBROUTINE = '1' -- Program called as Subroutine
44 RXFUNCTION = '2'
45 RXFUNC_DYNALINK = '1' -- Function Available in DLL
46 RXFUNC_CALLENTRY = '2' -- Registered as mem entry pt.
47
48compile if not defined(ERES_DLL) -- Being compiled separately? (For debug use...)
49 include 'STDCONST.E'
50 include 'ENGLISH.E'
51compile endif
52
53; ---------------------------------------------------------------------------
54defproc RxResult
55 universal rexxresult
56 parse arg RxMacro
57 'rx 'RxMacro
58 return rexxresult
59
60; ---------------------------------------------------------------------------
61; Universal vars can be used to check the result:
62; rc = 0: success
63; rc < 0: E error
64; rc > 0: REXX error
65; rexxresult: return value of the REXX function
66defc epmrexx, rx
67 universal rexxresult
68 -- Reset universal var
69 rexxresult = ''
70
71 parse value arg(1) with Macro Args
72 if Macro = '' then
73 sayerror RX_PROMPT__MSG
74 return
75 endif
76 call parse_filename( Macro, .filename)
77 if not pos( '.', substr( Macro, lastpos( '\', Macro) + 1)) then
78 Macro = Macro'.erx' -- add the default extention
79 endif
80
81 -- Try to register the subcommand interface
82 rc = rexxsubcomregister()
83 if rc then
84 sayerror RX_SUBCOM_FAIL__MSG rc
85 return
86 endif
87 rc = rexxfunctionregister()
88 if rc then
89 sayerror RX_FUNC_FAIL__MSG rc
90 return
91 endif
92
93; string=atol(length(getall))||offset(getall)||selector(getall)
94 -- Call the macro named by the macro variable
95 -- The default environment is "ERXSUBCOM".
96 -- The EPM subcommand DLL is "ERXSBCOM.DLL".
97; sayerror 'EPM REXX macro "'macro'" running...'
98 Functionname =macro\0
99; saveautoshell = .autoshell
100; .autoshell = 0
101
102 -- Allocate buffer for string, functionname, envname, rcresult, and resultstring.
103 -- 'ENV'\0 2 bytes 8 bytes
104; len = length(string) + length(functionname) + length(envname) + 2 + 8
105; string_ofs = 0
106 func_ofs = 8 -- length(string)
107 env_ofs = func_ofs + length( Functionname)
108 rc_ofs = env_ofs + 4
109 res_ofs = rc_ofs + 4 -- return code is a long
110 parm_ofs = res_ofs + 8
111 len = parm_ofs + length( Args)
112 bufhndl = substr( atol( dynalink32( E_DLL,
113 'mymalloc',
114 atol( len), 2)), 3, 2)
115 bufhndla = ltoa( bufhndl\0\0, 10)
116 r = -270 * (bufhndla = 0)
117
118 if r | not bufhndla then sayerror 'Error 'r' allocating memory segment; command halted.'; stop; endif
119; poke bufhndla, 0, string -- assume string_ofs = 0
120 poke bufhndla, 0, atol( length( Args))||atoi( parm_ofs)||bufhndl
121 poke bufhndla, func_ofs, Functionname
122 poke bufhndla, env_ofs, 'EPM'\0
123 poke bufhndla, parm_ofs, Args
124
125 result = dynalink32( 'REXX', -- dynamic link library name
126 '#1', -- 'RexxStart', -- Rexx input function
127 atol(1) || -- Num of args passed to rexx
128 \0\0 || -- offset of Arglist
129 bufhndl || -- selector of "
130 atoi(func_ofs) || -- offset of program name
131 bufhndl || -- selector of "
132 atol(0) || -- Loc of rexx proc in memory
133 atoi(env_ofs) || -- offset of env.
134 bufhndl || -- sel. ASCIIZ initial environment.
135 atol(RXCOMMAND) || -- type (command,subrtn,funct)
136 atol(0) || -- SysExit env. names & codes
137 atoi(rc_ofs) || -- offset Ret code from if numeric
138 bufhndl || -- sel. Ret code from if numeric
139 atoi(res_ofs) || -- offset Retvalue from the rexx proc
140 bufhndl) -- selector of "
141
142; .autoshell = saveautoshell
143 rc = rexxsubcomdrop()
144 if rc & rc <> 30 then -- rc = 30, when 'rx' is executed from another .erx file
145 sayerror RX_SUBCOM_FAIL__MSG rc
146;; return
147 endif
148 if result then
149 if result = -3 | result = 65533 then
150 rc = result
151 result = result': 'FILE_NOT_FOUND__MSG '('Macro')'
152 sayerror FILE_NOT_FOUND__MSG '('Macro')'
153 elseif result < 0 then
154 rc = result
155 else
156 rc = 65536 - result
157 -- This error msg is only written if the REXX syntax error was not
158 -- catched by the macro itself. Using the ERX file can be much more
159 -- comfortable, because also the REXX error line is saved in the
160 -- sigl var. With the error line, the erranous file can be loaded
161 -- and EPM can jump to that line.
162 -- The ERX code for that looks like that:
163 -- signal on syntax name Error
164 -- parse source . . ThisFile
165 -- ...
166 -- Error:
167 -- 'sayerror REX'right( rc, 4, 0)': Error 'rc' running 'ThisFile', line 'sigl ||,
168 -- ': 'errortext( rc)
169 -- "e "ThisFile" 'postme "sigl"'"
170 -- exit( 31)
171 saved_rc = rc
172 Msg = GetHelpMsg( rc)
173 rc = saved_rc
174 sayerror 'REX'rightstr( rc, 4, 0)': Error 'rc' running 'Macro': 'Msg
175 endif
176 else
177 -- Set universal RC for use by callers.
178 --rc = ltoa( peek( bufhndla, rc_ofs, 4), 10)
179 -- Better use rexxresult for return value from REXX proc
180 rc = 0
181 endif
182 Saved_rc = rc
183
184 if rc = 0 then
185 rcresult = peek( bufhndla, rc_ofs, 2)
186 resultstring = peek( bufhndla, res_ofs, 8)
187 peekseg = itoa( substr( resultstring, 7, 2), 10)
188 peekoff = itoa( substr( resultstring, 5, 2), 10)
189 peeklen = ltoa( substr( resultstring, 1, 4), 10)
190 -- Set universal var
191 rexxresult = peek( peekseg, peekoff, peeklen)
192 --dprintf( 'result='result'; Input <'Args'> and the result from REXX is <'rexxresult'>; rc='rc)
193 endif
194
195 call dynalink32( E_DLL, -- dynamic link library name
196 'myfree', -- DosFreeSeg
197 atoi(0) || -- add an offset to make the selector an address
198 bufhndl)
199 rc = Saved_rc
200
201; ---------------------------------------------------------------------------
202defproc GetHelpMsg( rex_rc)
203 universal vTEMP_FILENAME
204 Msg = ''
205
206 quietshell 'helpmsg REX'rex_rc' 1>'vTEMP_FILENAME' 2>&1'
207 'xcom e /D /Q' vTEMP_FILENAME
208 if not rc then
209 parse value textline(2) with . '***'Msg'***'
210 endif
211 'xcom q'
212 call erasetemp( vTEMP_FILENAME)
213 return Msg
214
215; ---------------------------------------------------------------------------
216; Invoke current file as a Rexx macro, passing it the arguments specified (if any).
217defc rxme =
218 if .modify then
219 result = winmessagebox( "RxMe", MODIFIED_PROMPT__MSG, MB_YESNOCANCEL + MB_ICONQUESTION + MB_MOVEABLE)
220 if result = MBID_YES then
221 'save'
222 elseif result = MBID_NO then
223 -- nop
224 else
225 return
226 endif
227 endif
228
229 if not exist(.filename) then
230 sayerror '"'.filename'"' NOT_ON_DISK__MSG
231 return
232 endif
233
234 'rx' .filename arg(1)
235
236; ---------------------------------------------------------------------------
237; Register the EPM subcommand DLL.
238; Store the EPM window handle in the Rexx subcommand user area.
239defproc rexxsubcomregister()
240 pib = 1234
241 tid = 1234
242
243 call dynalink32( 'DOSCALLS', /* dynamic link library name */
244 '#312', /* ordinal value for DOS32GETINFOBLOCKS */
245 address(tid) ||
246 address(pib), 2)
247
248 pid = peek32( ltoa( pib, 10), 0, 4)
249
250 SubcomName = 'EPM'\0
251 SubcomDLL = ERES_DLL\0
252 SubcomProc = 'ERESREXX'\0
253 UserArea = atol(getpminfo(EPMINFO_EDITCLIENT)) || pid
254
255 result = dynalink32( 'REXXAPI',
256 '#6', -- 'RexxRegisterSubcomDll',
257 address(SubcomName) ||
258 address(SubcomDll) ||
259 address(SubcomProc) ||
260 address(UserArea) ||
261 atol(0))
262
263 if result & result <> 10 then -- 10 = RXSUBCOM_DUP; registration was successful.
264 result = dynalink32( 'REXXAPI',
265 '#9', -- 'RexxDeregisterSubcom',
266 address(SubcomName) ||
267 address(SubcomDll))
268 if result & result <> 30 then -- 30 = RXSUBCOM_NOTREG
269 return result
270 endif
271
272 result = dynalink32( 'REXXAPI',
273 '#6', -- 'RexxRegisterSubcomDll',
274 address(SubcomName) ||
275 address(SubcomDll) ||
276 address(SubcomProc) ||
277 address(UserArea) ||
278 atol(0))
279 if result = 10 then -- 10 = RXSUBCOM_DUP; registration was successful.
280 result=0
281 endif
282 return result
283 endif
284 return 0
285
286; ---------------------------------------------------------------------------
287defproc rexxsubcomdrop()
288 scbname = 'EPM'\0
289 scbdll_name = ERES_DLL\0
290 result = dynalink32( 'REXXAPI',
291 'RexxDeregisterSubcom',
292 address(scbname) ||
293 address(scbdll_name))
294 return result
295
296; ---------------------------------------------------------------------------
297; Call the PIPEDLL dynamic link library.
298; This function will start a window and allows
299; interaction with the standard input and standard output of EPM.
300defc rxshell=
301 if arg(1) = '' then
302 string = 'PMMORE.EXE'\0
303 else
304 string = arg(1)\0
305 endif
306 result = dynalink32( ERES_DLL, /* dynamic link library name */
307 'PipeStartExecution', /* input function */
308 address(string)) /* command to execute */
309
310
311; ---------------------------------------------------------------------------
312; Register the EPM functions.
313defproc rexxfunctionregister()
314 functionname = 'all'\0
315 result = dynalink32( ERES_DLL, /* dynamic link library name */
316 'EtkRexxFunctionRegister', /* Rexx input function */
317 address(functionname))
318 if result then
319 call messagenwait( ERES_DLL': ETKREXXFUNCTIONREGISTER: rc='result);
320 endif
321 return result
322
323
324; ---------------------------------------------------------------------------
325; PART 2
326; ---------------------------------------------------------------------------
327; Define some procedures as commands to make them usable in REXX
328; ---------------------------------------------------------------------------
329defc buildsubmenu
330 parse arg menuname submenuid submenutext attrib helppanel e_command
331 buildsubmenu menuname, submenuid, submenutext, e_command, attrib, helppanel
332
333; ---------------------------------------------------------------------------
334defc buildmenuitem
335 parse arg menuname submenuid menuitemid submenutext attrib helppanel e_command
336 buildmenuitem menuname, submenuid, menuitemid, submenutext, e_command, attrib, helppanel
337
338; ---------------------------------------------------------------------------
339defc showmenu
340 universal activemenu, defaultmenu
341 activemenu = arg(1)
342 if activemenu = defaultmenu then
343 call showmenu_activemenu() -- This handles the posting of cascademenu cmds, if necessary.
344 else
345 showmenu activemenu -- Just show the updated EPM menu
346 endif
347
348; ---------------------------------------------------------------------------
349defc deletemenu
350 parse arg menuname submenuid menuitemid itemonly
351 deletemenu menuname, submenuid, menuitemid, itemonly
352
353; ---------------------------------------------------------------------------
354defc showlist
355 if arg(1) <> '' then
356 return listbox( 'List', arg(1))
357 endif
358
359; ---------------------------------------------------------------------------
360defc sayerror = sayerror arg(1)
361
362; ---------------------------------------------------------------------------
363defc buildaccel
364 universal activeaccel
365 parse arg table flags key index command
366 if table = '*' then
367 table = activeaccel
368 endif
369 buildacceltable table, command, flags, key, index
370
371; ---------------------------------------------------------------------------
372defc activateaccel
373 universal activeaccel
374 parse arg newtable .
375 if newtable <> '' then
376 activeaccel = newtable
377 endif
378 activateacceltable activeaccel
379
380; ---------------------------------------------------------------------------
381defc register_mouse
382 parse arg which button action shifts command
383 call register_mousehandler( which, button action shifts, command)
384
385; ---------------------------------------------------------------------------
386defc display
387 display arg(1)
388
389; ---------------------------------------------------------------------------
390defc refresh
391 refresh
392
393; ---------------------------------------------------------------------------
394defc universal
395 universal default_search_options, default_edit_options, default_save_options
396 universal defload_profile_name
397 parse arg varname varvalue
398 varname = upcase(varname)
399 if varname='DEFAULT_SEARCH_OPTIONS' then
400; if varvalue='' then -- Removed this; want to give the user the ability to set to null.
401; sayerror varname '=' default_search_options
402; else
403 default_search_options = varvalue
404; endif
405 elseif varname='DEFAULT_EDIT_OPTIONS' then
406 default_edit_options = varvalue
407 elseif varname='DEFAULT_SAVE_OPTIONS' then
408 default_save_options = varvalue
409 elseif varname='DEFLOAD_PROFILE_NAME' then
410 defload_profile_name = varvalue
411 else
412 sayerror -263 -- Invalid argument
413 endif
414
415; ---------------------------------------------------------------------------
416defc Insert_attr_val_Pair
417 parse arg class attr_val fstline lstline fstcol lstcol fid
418 if attr_val = '' | (fstline <> '' & lstcol = '') then
419 sayerror -263 -- Invalid argument
420 return
421 endif
422 mt = marktype()
423 if fstline = '' then -- assume mark
424 if mt = '' then
425 sayerror NO_MARK__MSG
426 return
427 endif
428 getmark fstline, lstline, fstcol, lstcol, fid
429 else
430 mt = 'CHAR'
431 endif
432 if fid = '' then -- default to current file
433 getfileid fid
434 endif
435 if leftstr( mt, 5) = 'BLOCK' then
436 do i = fstline to lstline
437 Insert_Attribute_Pair( class, attr_val, i, i, fstcol, lstcol, fid)
438 enddo
439 else
440 if mt = 'LINE' then
441 getline line, lstline, mkfileid
442 lstcol = length(line)
443 endif
444 Insert_Attribute_Pair( class, attr_val, fstline, lstline, fstcol, lstcol, fid)
445 endif
446
447; ---------------------------------------------------------------------------
448defc Insert_attribute
449 parse arg class attr_val IsPush offst col line fid junk
450 if offst = '' | junk <> '' then
451 sayerror -263 -- Invalid argument
452 return
453 endif
454 if fid = '' then -- default to current file
455 getfileid fid
456 if line = '' then -- default to current file
457 line = .line
458 if col = '' then -- default to current file
459 col = .col
460 endif
461 endif
462 endif
463 insert_attribute class, attr_val, IsPush, offst, col, line, fid
464
465; ---------------------------------------------------------------------------
466defc attribute_on
467 if isnum(arg(1)) then
468 call attribute_on(arg(1))
469 else
470 sayerror -263 -- Invalid argument
471 endif
472
473; ---------------------------------------------------------------------------
474; .userstring commands
475; see getmode.erx for an example and descriptions
476; ---------------------------------------------------------------------------
477defc saveuserstring
478 universal saveduserstring
479 saveduserstring = .userstring
480
481; ---------------------------------------------------------------------------
482defc restoreuserstring
483 universal saveduserstring
484 .userstring = saveduserstring
485
486; ---------------------------------------------------------------------------
487defc FileAVar2Userstring, field2userstring
488 universal EPM_utility_array_id
489 AVarName = arg(1)
490 getfileid fid
491 rc = get_array_value( EPM_utility_array_id, AVarName'.'fid, CurValue)
492 .userstring = CurValue
493
494; ---------------------------------------------------------------------------
495defc AVar2Userstring
496 universal EPM_utility_array_id
497 AVarName = arg(1)
498 rc = get_array_value( EPM_utility_array_id, AVarName, CurValue)
499 .userstring = CurValue
500
501
Note: See TracBrowser for help on using the repository browser.