home *** CD-ROM | disk | FTP | other *** search
/ Internet File Formats / InternetFileFormatsCD.bin / text / latex / mac / alpha60.hqx / Tcl / SystemCode / MacPerl.tcl < prev    next >
Encoding:
Text File  |  1995-07-16  |  49.4 KB  |  1,706 lines
  1. #############################################################################
  2. # MacPerl.tcl
  3. # -----------
  4. #
  5. # This is a set of routines that allow Alpha to act as a front end for the
  6. # standalone MacPerl application and that allow Perl scripts to be used as 
  7. # text filters in Alpha.  These functions are accessed through a special 
  8. # MacPerl menu.
  9. #
  10. # The features of this package are explained in the file "MacPerl Help",
  11. # accessible from the Help menu.
  12. #
  13. #############################################################################
  14. #
  15. # If you don't already have MacPerl, it's available by anonymous ftp from
  16. # the umich site
  17. #
  18. #   mac.archive.umich.edu    [141.211.165.34]    mac/development/languages
  19. #
  20. # and its mirrors.  Also, MacPerl's home site is 
  21. #
  22. #   ftp.switch.ch            [130.59.1.40]        software/mac/src/mpw_c
  23. #
  24. # MacPerl was written (ported to the Mac) by 
  25. #        Matthias Neeracher <neeri@iis.ee.ethz.ch> , and
  26. #        Tim Endres <time@ice.com>.
  27. #
  28. #############################################################################
  29. # Author: W. Thomas Pollard <pollard@chem.columbia.edu>
  30. #
  31. # Version History:
  32. #
  33. # 2.3  7/95  -  Minor tweaks and code rearrangement.
  34. # 2.2  6/95  -  Text filters act only on current line if "Apply to Buffer" is
  35. #                  false and no text has been selected.
  36. #               Bug fix in error-marking for scripts sent as AppleEvent params.
  37. #               Cmd-dbl-clicking a function call jumps to function, if
  38. #                  defined in the same file.
  39. # 2.1  6/95  -  Cmd-dbl-clicking a 'require'd filename opens the file.
  40. # 2.0  6/95  -  Minor bug fixes (incl. keyword decapitalization)
  41. #               Alpha 6.0b17 compatibility updates.
  42. #               Text Filters folder is settable from the App Paths menu now.
  43. # 1.9  5/95  -  Cmd-dbl-clicking Perl keywords and special variables displays
  44. #                  the man page info.
  45. # 1.81 4/95  -  one very minor Alpha compatibility update (winInfo->getWinInfo).
  46. # 1.8  4/95  -  Menu reorganized somewhat.
  47. #               Text Filters folder can now be anywhere.
  48. #               "ApplyToBuffer" flag ignored if text has been selected.
  49. #               Bug fixes.
  50. # 1.7  1/95  -  Updated to take advantage of MacPerl 4.1.4 AppleEvent features:
  51. #                1) Text filters use 'batch' doScript (.: STDOUT file obsolete)
  52. #                2) Filter scripts sent as doScript params (.: SCRIPT file obsolete)
  53. #                3) "Save As Droplet" and "Save as Runtime" commands added.
  54. #               Errors generated in 'require'd files are now displayed correctly
  55. # 1.6 10/94  -  "UseDebugger" flag added (forces scripts to run under debugger).
  56. #               Key bindings added for some menu commands.
  57. #               "perlDoScript{,2,3}" procs consolidated into a single proc.
  58. #               "saveAndRun" option added.
  59. #               Command-line args now parsed into units more correctly, in
  60. #                   particular, quoted file names aren't broken up.
  61. #               "Close Output Window" added to "Tell MacPerl" menu.
  62. #               Updated for Alpha 5.98 to load when menu is inserted.
  63. #               The error messages window is now recycled.
  64. #               "perlRecycleOutput" recycles output window.
  65. #               Minor bug fixes.
  66. # 1.5  9/94  -  MacPerl menu rearranged somewhat.
  67. #               Explicit "Get Output Window" command added to menu.
  68. #               Reading "#!" line for args is incompatible w/ standard,
  69. #                   so it's been dropped.
  70. #               Only scan the first 40 output lines for error messages (faster)
  71. #                "wrapFilterScript" no longer opens STDIN
  72. #               Text filters may now use command-line args
  73. #               STDIN for text filters passed as explicit cmd-line arg 
  74. # 1.4  9/94  -  The "#!" line of every script is read for command-line args,
  75. #                    which are passed explicitly to MacPerl with the script.
  76. #                "PromptForArgs" menu flag added.
  77. #                "perlCmdlineArgs" modeVar holds default command-line args.
  78. #                Scripts are sent using custom "perlDoScript2" proc, which
  79. #                    allows passing of explicit command-line args.
  80. # 1.3  9/94  -  When any script generates a compilation error, the file 
  81. #                    containing the script is brought up with the offending 
  82. #                    line highlighted; all error output is also written to
  83. #                    a "Perl Error Messages" window.
  84. #                'repeatLastFilter' runs again the last text-filter script used.
  85. #                'perlLastFilter' modeVar holds pathname of last filter.
  86. #                Menu flags now mirrored as modeVars, so they can be saved and
  87. #                    restored between sessions.
  88. #                Minor bug fixes.
  89. # 1.2  8/94  -  'retrieveOutput' and 'autoSwitch' flags added.
  90. #                'openInMacperl' added.
  91. #                MacPerl output window now closed before new scripts are sent.
  92. #                Filters now abort if there are compilation errors, and
  93. #                MacPerl diagnostic output retrieved and displayed in Alpha.
  94. # 1.1  8/94  -  'quitMacperl' added.
  95. #               perl-mode file-marking updated for Alpha 5.90
  96. #               Simplified installation via 'loadMacperl'(Pete Keleher). 
  97. # 1.0  7/94  -  perl-mode setup updated for Alpha 5.85:
  98. #                    keyword colorization supported
  99. #                    custom file-marking added
  100. #               #! lines in filter scripts now handled correctly 
  101. #               Workarounds installed for AppleEvent bug in MacPerl 4.1.3
  102. # 0.9  3/94  -  perl-mode stuff added, and
  103. #               highlighted 'Perl commands' file (man page) prepared
  104. #               minor bug fixes, too
  105. # 0.8  3/94  -  flags are now check-marked
  106. # 0.7  3/94  -  nested Text Filters folder now supported
  107. #               menu format modified somewhat
  108. # 0.6  3/94  -  'applyToBuffer' flag added
  109. #               scripts in Alpha buffers can now be used as filters 
  110. # 0.5  2/94  -  'filters', 'open special' submenu added
  111. #               'overwrite' flag added
  112. # 0.2  1/94  -  menu support added (Martijn Koster <m.koster@nexor.co.uk>)
  113. #               'execute selection', 'execute buffer' commands added
  114. # 0.1  9/93  -  text filter functionality created
  115. #                  
  116. ##############################################################################
  117. #
  118. proc dummyPerl {} {
  119. }
  120.  
  121. #############################################################################
  122. #  Default settings for the Perl menu flags  
  123. #
  124. set perlDefault(perlUseDebug) 0
  125. set perlDefault(perlGetOutput) 1
  126. set perlDefault(perlAutoSwitch) 1
  127. set perlDefault(perlOverwrite) 0
  128. set perlDefault(perlUsebuffer) 1
  129. set perlDefault(perlPromptArgs) 0
  130. set perlDefault(perlRecycleOutput) 0
  131. set perlDefault(perlPrevScript) {*startup*}
  132. set perlDefault(perlCmdlineArgs) {}
  133.  
  134. if {![info exists perlFilterPath]} {
  135.     set perlFilterPath "$HOME:Tcl:UserCode:Text Filters:"
  136. }
  137.  
  138. foreach var [array names perlDefault] {
  139.     if (![info exists PerlmodeVars($var)]) { 
  140.         set $var $perlDefault($var) 
  141.     } else {
  142.         set $var $PerlmodeVars($var) 
  143.     }
  144. }
  145. unset perlDefault
  146.  
  147. ##############################################################################
  148. # Make duplicate copies of these variables as modeVars, taking responsibility
  149. # for keeping the two sets consistent (argh!)
  150. #
  151. # (Maybe it's OK now to let them _just_ be modeVars, and not also ordinary
  152. # variables?)
  153. #
  154.  
  155. newModeVar Perl perlUseDebug $perlUseDebug 1
  156. newModeVar Perl perlGetOutput $perlGetOutput 1
  157. newModeVar Perl perlAutoSwitch $perlAutoSwitch 1
  158. newModeVar Perl perlOverwrite $perlOverwrite 1
  159. newModeVar Perl perlUsebuffer $perlUsebuffer 1
  160. newModeVar Perl perlPromptArgs $perlPromptArgs 1
  161. newModeVar Perl perlRecycleOutput $perlRecycleOutput 1
  162.  
  163. newModeVar Perl perlLastFilter $perlPrevScript 0
  164. newModeVar Perl perlCmdlineArgs $perlCmdlineArgs 0
  165.  
  166. ##############################################################################
  167. # Other Perl-mode variable definitions
  168. #
  169. newModeVar Perl elecRBrace    {0} 1
  170. newModeVar Perl elecLBrace    {1} 1
  171. newModeVar Perl electricSemi    {0} 1
  172. newModeVar Perl electricTab    {1} 1
  173. newModeVar Perl wordBreak        {(\$)?[a-zA-Z0-9_]+} 0
  174. newModeVar Perl prefixString    {# } 0
  175. newModeVar Perl wordWrap        {0} 1
  176. newModeVar Perl funcExpr        {^sub *([+-a-zA-Z0-9]+)} 0
  177. newModeVar Perl wordBreakPreface        {[^a-zA-Z0-9_\$]} 0
  178. newModeVar Perl optionIsMeta    {1} 1
  179. newModeVar Perl autoMark    1    1
  180.  
  181. ##############################################################################
  182. # Miscellaneous definitions
  183. #
  184. set perlErrorWindow {* Perl Error Messages *}
  185. set perlOutputWindow {* Perl Output *}
  186.  
  187. set perlFilterMenu "textFilters"
  188.  
  189.  
  190. ##############################################################################
  191. # Colorization setup
  192. #
  193. # Keywords are separated here according to their location in "Perl Commands",
  194. # for the convenience of the cmd-double-click mechanism.
  195. #
  196. # Expression words are described in the "Compound Statements" section
  197. #
  198. set perlExprWords {  
  199. else elsif for foreach if return unless until while eq ne cmp lt gt le ge
  200. }
  201.  
  202. # Special variables are described in their own section (and are not 
  203. # individually marked, so we have to search for them.)
  204. #
  205. # This group can safely be colorized...
  206. #
  207. set perlNameWords {
  208. @_ $_ $.  $/ $, $" $\\ $\# $% $= $- $~ $^ $| $$ $? $& $` $' $+ $* 
  209. $0 $1 $2 $3 $4 $5 $6 $7 $8 $9 $[ $] $; $! $@ $< $> $( $) $:
  210. }
  211.  
  212. #... while this group is forced lower-case by the current colorization scheme
  213. #
  214. set perlSpecialVars [concat $perlNameWords {
  215. $^D $^F $^I $^P $^T $^W $^X 
  216. $ARGV @ARGV @INC %INC @INC %ENV $SIG $ENV %SIG
  217. }]
  218.  
  219. # Perl operators and functions are indexed via the Marks menu
  220. #
  221. set perlKeyWords {
  222.     accept alarm atan2 bind binmode caller chdir chmod chop chown chroot 
  223.     close closedir connect continue cos crypt dbmclose dbmopen defined 
  224.     delete die do dump each   eof eval exec exit exp fcntl fileno 
  225.     flock  fork getc getlogin getpeername getpgrp getppid 
  226.     getpriority getgrnam gethostbyname getnetbyname getprotobyname getpwuid 
  227.     getgrgid getservbyname gethostbyaddr getnetbyaddr getprotobynumber 
  228.     getservbyport getpwent getgrent gethostent getnetent getprotoent 
  229.     getservent setpwent setgrent sethostent setnetent setprotoent setservent 
  230.     endpwent endgrent endhostent endnetent endprotoent endservent 
  231.     getsockname getsockopt gmtime goto grep hex  index int ioctl join keys 
  232.     kill last  length link listen local localtime log lstat lstat mkdir 
  233.     msgctl msgget msgsnd msgrcv next oct open opendir ord pack pipe pop 
  234.     print  printf  push q qq qx rand read readdir readlink recv redo
  235.      rename require reset  reverse rewinddir rindex rindex rmdir 
  236.     scalar seek seekdir select semctl semget semop send setpgrp setpriority 
  237.     setsockopt shift shmctl shmget shmread shmwrite shutdown sin sleep 
  238.     socket socketpair sort splice split sprintf sqrt srand stat study sub 
  239.     substr symlink syscall sysread system syswrite tell telldir time times 
  240.     tr truncate umask undef  unlink unpack unshift  utime values 
  241.     vec wait waitpid wantarray warn  write 
  242. }
  243. set perlWords [concat $perlKeyWords $perlNameWords $perlExprWords]
  244. regModeKeywords -e {#} -c red -k blue Perl $perlWords
  245. unset perlWords
  246.  
  247. #############################################################################
  248. #  Return paths to standard files, based on the path to MacPerl:
  249. #
  250. proc macperlFolder {} {
  251.    global macperlPath
  252.    regexp {(.*):([^:]*)} $macperlPath pathname dirname filename
  253.    return ${dirname}:
  254. }
  255.  
  256. proc stdinPath {} {
  257.    return [macperlFolder]STDIN
  258. }
  259.  
  260. proc scriptPath {} {
  261.    return [macperlFolder]SCRIPT
  262. }
  263.  
  264. #############################################################################
  265. # Define the dummy proc that will be called when the perl menu
  266. # is first inserted into the menubar
  267. #
  268. proc perlMenu {} {}
  269.  
  270. #############################################################################
  271. #  Build the perl menu
  272. #            
  273. set perlMenu "Ñ132"
  274. set perlOptsMenu "generalOptions"
  275. set filtOptsMenu "filterOptions"
  276.  
  277. menu -n $perlMenu [ concat {
  278.         "/'<Umacperl"
  279.         {menu -m -n "tellMacperl..." -p perlTellProc {
  280.            "/O<UOpen This File"
  281.            "Save As Droplet"
  282.            "Save As Runtime"
  283.            "Save As CGI"
  284.             "(-"
  285.            "Get Output Window"
  286.            "Close Output Window"
  287.            "Quit"
  288.            }
  289.         } 
  290.         "(-"
  291.         "runTheSelection"
  292.         "/R<UrunTheBuffer"
  293.         "/R<B<OsaveAndRun"
  294.         "runAFile"
  295.         "(-"
  296.     } [list [list menu -n $perlFilterMenu {}]] {
  297.        "selectBufferAsFilter"
  298.        "selectFileAsFilter"
  299.        "/F<UrepeatLastFilter"
  300.        "(-" 
  301.     } [list [list menu -n $perlOptsMenu {}]] {
  302.     } [list [list menu -n $filtOptsMenu {}]] {
  303.     } ]
  304.  
  305. enableMenuItem $perlMenu perlDebugWindow 0
  306. enableMenuItem "tellMacperl..." "Save As CGI" 0
  307.  
  308. if {$perlPrevScript == {} || $perlPrevScript == {*startup*}} {
  309.     enableMenuItem $perlMenu repeatLastFilter 0
  310. }
  311.  
  312. # General Perl-menu options menu
  313. #
  314. menu -n $perlOptsMenu {
  315.     "retrieveOutput"
  316.     "autoSwitch"
  317.     "promptForArgs"
  318.     "useDebugger"
  319.     }    
  320. markMenuItem $perlOptsMenu useDebugger $perlUseDebug
  321. markMenuItem $perlOptsMenu retrieveOutput $perlGetOutput
  322. markMenuItem $perlOptsMenu autoSwitch $perlAutoSwitch
  323. markMenuItem $perlOptsMenu promptForArgs $perlPromptArgs
  324.  
  325. # Text Filter options menu
  326. #
  327. menu -n $filtOptsMenu {
  328.     "applyToBuffer"
  329.     "overwriteSelection"
  330.     "(-"
  331.     "textFiltersFolder"
  332.     "rebuildFilterMenu"
  333.     }    
  334. markMenuItem $filtOptsMenu overwriteSelection $perlOverwrite
  335. markMenuItem $filtOptsMenu applyToBuffer $perlUsebuffer
  336.  
  337. # if ([info exists macperlPath]) {
  338. #     rebuildPerlMenu
  339. # }
  340.  
  341. #############################################################################
  342. #  Build a submenu of "preattached" Perl filters using the names of the 
  343. #  scripts in the Text Filters directory.  Called whenever Text Filters
  344. # folder is reassigned.
  345. #
  346. proc rebuildFilterMenu {{args}} {
  347.     global perlFilters perlFilterMenu perlFilterPath
  348.     global $perlFilterMenu
  349.     
  350.     eval [buildSubMenu $perlFilterPath $perlFilterMenu textFiltersProc perlFilters]
  351. }
  352.  
  353. rebuildFilterMenu
  354.  
  355. #############################################################################
  356. # Use variable tracing to keep global vars and modeVars consistent.
  357. #
  358. trace variable PerlmodeVars(perlUseDebug) w shadowPerl
  359. trace variable PerlmodeVars(perlOverwrite) w shadowPerl
  360. trace variable PerlmodeVars(perlUsebuffer) w shadowPerl
  361. trace variable PerlmodeVars(perlGetOutput) w shadowPerl
  362. trace variable PerlmodeVars(perlAutoSwitch) w shadowPerl
  363. trace variable PerlmodeVars(perlPromptArgs) w shadowPerl
  364. trace variable PerlmodeVars(perlLastFilter) w shadowPerl
  365. trace variable PerlmodeVars(perlCmdlineArgs) w shadowPerl
  366. trace variable PerlmodeVars(perlRecycleOutput) w shadowPerl
  367.  
  368. # perlFilterPath is now just a regular variable, set from the App Paths submenu
  369. trace variable perlFilterPath w rebuildFilterMenu
  370.  
  371. # ShadowPerl sets the global vars when the mode vars are modified and
  372. # keeps the menu checkmarked correctly.
  373. #
  374. proc shadowPerl {name1 name2 op} {
  375.     global perlMenu perlOptsMenu filtOptsMenu
  376.     global perlOverwrite perlUsebuffer perlGetOutput perlAutoSwitch
  377.     global perlPromptArgs perlPrevScript perlCmdlineArgs perlUseDebug
  378.     global PerlmodeVars
  379.     if {$name1 == "PerlmodeVars" && $op == "w"} {
  380.         switch $name2 {
  381.             "perlUseDebug"    {
  382.                 set perlUseDebug $PerlmodeVars(perlUseDebug)
  383.                 markMenuItem $perlOptsMenu useDebugger $perlUseDebug
  384.              }
  385.             "perlOverwrite"    {
  386.                 set perlOverwrite $PerlmodeVars(perlOverwrite)
  387.                 markMenuItem $filtOptsMenu overwriteSelection $perlOverwrite
  388.              }
  389.             "perlUsebuffer"    {
  390.                 set perlUsebuffer $PerlmodeVars(perlUsebuffer)
  391.                 markMenuItem $filtOptsMenu applyToBuffer $perlUsebuffer
  392.              }
  393.             "perlGetOutput"    {
  394.                 set perlGetOutput $PerlmodeVars(perlGetOutput)
  395.                 markMenuItem $perlOptsMenu retrieveOutput $perlGetOutput 
  396.             }
  397.             "perlAutoSwitch" {    
  398.                 set perlAutoSwitch $PerlmodeVars(perlAutoSwitch)
  399.                 markMenuItem $perlOptsMenu autoSwitch $perlAutoSwitch 
  400.             }
  401.             "perlPromptArgs" {    
  402.                 set perlPromptArgs $PerlmodeVars(perlPromptArgs)
  403.                 markMenuItem $perlOptsMenu promptForArgs $perlPromptArgs 
  404.             }
  405.             "perlCmdlineArgs" {    
  406.                 set perlCmdlineArgs $PerlmodeVars(perlCmdlineArgs)
  407.             }
  408.             "perlRecycleOutput" {    
  409.                 set perlRecycleOutput $PerlmodeVars(perlRecycleOutput)
  410.             }
  411.             "perlLastFilter" {    
  412.                 # Don't allow perlPrevScript to be changed from the flags menu
  413.                 if {$perlPrevScript == "*startup*"} {
  414.                     set perlPrevScript $PerlmodeVars(perlLastFilter)
  415.                     enableMenuItem $perlMenu repeatLastFilter 1
  416.                 } else {
  417.                     set PerlmodeVars(perlLastFilter) $perlPrevScript 
  418.                 }
  419.             }
  420.             default {
  421.                 return
  422.             }
  423.         }
  424.     }
  425. }
  426.  
  427. #############################################################################
  428. # Menu commands
  429. #############################################################################
  430.  
  431. ############################################################################
  432. # Toggle the perl menu flags
  433. #
  434. proc retrieveOutput {} {
  435.     global perlMenu PerlmodeVars perlGetOutput modifiedModeVars
  436.     lappend modifiedModeVars [list perlGetOutput PerlmodeVars]
  437.     if {$perlGetOutput} then {
  438.         set PerlmodeVars(perlGetOutput) 0
  439.     } else {
  440.         set PerlmodeVars(perlGetOutput) 1
  441.     }
  442. }
  443.  
  444. proc useDebugger {} {
  445.     global perlMenu PerlmodeVars perlUseDebug modifiedModeVars
  446.     lappend modifiedModeVars [list  perlUseDebug PerlmodeVars]
  447.     if {$perlUseDebug} then {
  448.         set PerlmodeVars(perlUseDebug) 0
  449.     } else {
  450.         set PerlmodeVars(perlUseDebug) 1
  451.     }
  452. }
  453.  
  454. proc autoSwitch {} {
  455.     global perlMenu PerlmodeVars perlAutoSwitch modifiedModeVars
  456.     lappend modifiedModeVars [list  perlAutoSwitch PerlmodeVars]
  457.     if {$perlAutoSwitch} then {
  458.         set PerlmodeVars(perlAutoSwitch) 0
  459.     } else {
  460.         set PerlmodeVars(perlAutoSwitch) 1
  461.     }
  462. }
  463.  
  464. proc overwriteSelection {} {
  465.     global perlMenu perlOverwrite PerlmodeVars modifiedModeVars
  466.     lappend modifiedModeVars [list  perlOverwrite PerlmodeVars]
  467.     if {$perlOverwrite} then {
  468.         set PerlmodeVars(perlOverwrite) 0
  469.     } else {
  470.         set PerlmodeVars(perlOverwrite) 1
  471.     }
  472. }
  473.  
  474. proc applyToBuffer {} {
  475.     global perlMenu perlUsebuffer PerlmodeVars modifiedModeVars
  476.     lappend modifiedModeVars [list  perlUsebuffer PerlmodeVars]
  477.     if {$perlUsebuffer} then {
  478.            set PerlmodeVars(perlUsebuffer) 0
  479.     } else {
  480.            set PerlmodeVars(perlUsebuffer) 1
  481.     }
  482. }
  483.  
  484. proc promptForArgs {} {
  485.     global perlMenu perlPromptArgs PerlmodeVars modifiedModeVars
  486.     lappend modifiedModeVars [list perlPromptArgs PerlmodeVars]
  487.     if {$perlPromptArgs} then {
  488.            set PerlmodeVars(perlPromptArgs) 0
  489.     } else {
  490.            set PerlmodeVars(perlPromptArgs) 1
  491.     }
  492. }
  493.  
  494. proc textFiltersFolder {} {
  495.     global perlMenu perlFilterPath PerlmodeVars modifiedModeVars pathComments
  496.     
  497.     pathProc {} $pathComments(perlFilterPath)
  498. }
  499.  
  500. #############################################################################
  501. # Switch to MacPerl:
  502. # 
  503. proc macperl {} {
  504.     global macperlPath
  505.     set name [checkRunning MacPerl McPL macperlPath 0]
  506.     if {[string length $name]} {
  507.         switchTo "MacPerl"
  508.     } else {
  509.         alertnote "Couldn't run MacPerl"
  510.     }
  511. }
  512.  
  513. #############################################################################
  514. # Interact with MacPerl in some other way besides executing a script
  515. #
  516. proc perlTellProc {menu name} {
  517.     switch -exact $name {
  518.     "Open This File"        openInMacperl
  519.     
  520.     "Save As Droplet"        saveThruMacperl "droplet"
  521.     
  522.     "Save As Runtime"        saveThruMacperl "runtime"
  523.     
  524.     "Save As CGI"            saveThruMacperl "cgi"
  525.     
  526.     "Save As CGI-not"        saveThruMacperl "cgi-not"
  527.     
  528.     "Get Output Window"        openPerlOutput
  529.     
  530.     "Close Output Window"    { sendCloseWinName MacPerl MacPerl
  531.                               sendCloseWinName MacPerl "Perl Debug" }
  532.                             
  533.     "Quit"                    quitMacperl
  534.     }
  535. }
  536.  
  537. #############################################################################
  538. # Open the current file under MacPerl.  This used to useful for saving files 
  539. # as droplets or runtime scripts.  Maybe it's still useful for something...?
  540. #
  541. proc openInMacperl {} {
  542.     global macperlPath
  543.     set name [checkRunning MacPerl McPL macperlPath 0]
  544.     if {![string length $name]} {
  545.         alertnote "Couldn't run MacPerl"
  546.     }
  547.  
  548.     if {[winDirty]} {
  549.         case [askyesno -c "Save '[lindex [winNames] 0]'?"] in {
  550.             "yes" {save}
  551.             "no" {}
  552.             "cancel" {return}
  553.         }
  554.     }
  555.     switchTo $name
  556.     sendOpenEvent -n $name [lindex [winNames -f] 0]
  557. }
  558.  
  559. #############################################################################
  560. # Save the script in the current window as a MacPerl droplet or 
  561. # runtime script.  
  562. #
  563. proc saveThruMacperl {type} {
  564.     global macperlPath ALPHA
  565.     set name [checkRunning MacPerl McPL macperlPath 0]
  566.     if {![string length $name]} {
  567.         alertnote "Couldn't run MacPerl"
  568.     }
  569.     
  570.     getWinInfo arr
  571.     if {$arr(dirty) == 1} {
  572.         case [askyesno -c "Save '[lindex [winNames] 0]' source file also?"] in {
  573.             "yes" {save}
  574.             "no" {}
  575.             "cancel" {return}
  576.         }
  577.     }
  578.  
  579.     set destfile [AEFilename [putfile {Save droplet as} [lindex [winNames] 0]]]
  580.  
  581.     set script [curlyq [getText 0 [maxPos]]]
  582.  
  583.     if {$type == "droplet"} {
  584.         set saveType "SCPT"
  585.     } elseif {$type == "runtime"} {
  586.         set saveType "MrP7"
  587. #     } elseif {$type == "cgi"} {
  588. #         set saveType "WWW╜"
  589. #     } elseif {$type == "cgi-not"} {
  590. #         set saveType "WWWO"
  591.     } elseif {$type == "text"} {
  592.         set saveType "TEXT"
  593.     }
  594.     
  595.     set err [catch {eval "AEBuild -t 36000 -r \"$name\"" core save {----} [list $script] {dest:} [list $destfile] {fltp:} $saveType } reply ]
  596.  
  597. #     perlDisplayReply $reply
  598. #     message "AEBuild error code $err in saveThruMacperl"
  599.     
  600. # The following lines could be used to tell MacPerl to take the script file 
  601. # from an existing disk file and then re-save it in the desired form.
  602. #
  603. #    set srcfile "\[ [AEFilename [lindex [winNames -f] 0]] \]"
  604. #    set reply [eval "AEBuild -t 36000 -r \"$name\"" core save {----} [list $srcfile] {dest:} [list $destfile] {fltp:} $saveType ]
  605. #
  606. }
  607.  
  608. #############################################################################
  609. # Quit a running MacPerl app:
  610. # 
  611. proc quitMacperl {} {
  612.     foreach proc [processes] {
  613.         set sig [lindex $proc 1]
  614.         if {$sig == "McPL"} {
  615.             sendQuitEvent [lindex $proc 0]
  616.             # switchTo is necessary to keep MacPerl from blinking
  617.             switchTo [lindex $proc 0]    
  618.         }
  619.     }
  620. }
  621.  
  622. #############################################################################
  623. # Run the selection as a MacPerl script:
  624. # (No special arrangements are made to provide input or capture the output)
  625. # 
  626. proc runTheSelection {} {
  627.     global scriptFile scriptStart
  628.     set scriptFile [lindex [winNames -f] 0]
  629.     set scriptStart [lindex [posToRowCol [getPos]] 0]
  630.     perlExecuteScript [getSelect]
  631. }
  632.  
  633. proc runTheBuffer {} {
  634.     global scriptFile scriptStart
  635.     set scriptFile [lindex [winNames -f] 0]
  636.     set scriptStart 1
  637.     perlExecuteScript [getText 0 [maxPos]]
  638. }
  639.  
  640. proc runAFile {} {
  641.     global scriptFile scriptStart
  642.     if {! [catch {getfile "Select a Perl script"} path]} {
  643.         set scriptFile $path
  644.         set scriptStart 1
  645.         perlExecuteFile $path
  646.     }
  647. }
  648.  
  649. proc saveAndRun {} {
  650.     global scriptFile scriptStart
  651.     save
  652.     set path [lindex [winNames -f] 0]   
  653.     set scriptFile $path
  654.     set scriptStart 1
  655.     perlExecuteFile $path
  656. }
  657.  
  658. #############################################################################
  659. # Run a preattached Perl text-filter script selected from the menu:
  660. #
  661. proc textFiltersProc {menu name} {
  662.     global perlFilters scriptFile scriptStart
  663.     
  664.     perlFileAsFilter $perlFilters($menu:$name)
  665. }
  666.  
  667. #############################################################################
  668. # Reuse the previous (buffer or file) filter:
  669. #
  670. proc repeatLastFilter {} {
  671.     global scriptFile scriptStart perlPrevScript perlMenu PerlmodeVars
  672.     if {$perlPrevScript != {}} {
  673.         set stype [lindex $perlPrevScript 0]
  674.         set name [lindex $perlPrevScript 1]
  675.         if {$stype == "file"} {
  676.             perlFileAsFilter $name
  677.         } elseif {$stype == "buffer"} {
  678.             perlBufferAsFilter $name
  679.         } else {
  680.             message "Bogus filter name : \"$perlPrevScript\""
  681.             set perlPrevScript {}
  682.             set PerlmodeVars(perlLastFilter) $perlPrevScript 
  683.             enableMenuItem $perlMenu repeatLastFilter 0
  684.         }
  685.     }
  686. }
  687.  
  688. #############################################################################
  689. # Ask for a file containing a Perl script to use as a filter:
  690. #
  691. proc selectFileAsFilter {} {
  692.     global scriptFile scriptStart perlPrevScript
  693.     if {! [catch {getfile "Select a MacPerl script"} path]} {
  694.         perlFileAsFilter $path
  695.     }
  696. }
  697.  
  698. #############################################################################
  699. # Ask for an Alpha buffer containing a Perl script to use as a filter:
  700. #
  701. proc selectBufferAsFilter {} {
  702.     global scriptFile scriptStart perlPrevScript
  703.     
  704.     set windows [winNames]
  705.     set current [lindex $windows 0]
  706.     if {[llength $windows] > 1} {
  707.         set name [listpick [lsort $windows]]
  708.         if {[string length $name]} {
  709.             # get the full name of the chosen window
  710.             set wname [lindex [winNames -f] [lsearch -exact $windows $name]]
  711.             perlBufferAsFilter $wname
  712.            }
  713.     }
  714. }
  715.  
  716. #############################################################################
  717. # Open a file from the MacPerl application folder - used by "Open Special"
  718. #
  719. proc perlOpenFile {menu name} {
  720.     set filename [macperlFolder]$name
  721.     if {[file exists $filename]} {
  722.         edit $filename
  723.     } else {
  724.         alertnote "That file doesn't exist yet"
  725.     }
  726. }
  727.  
  728. #############################################################################
  729. # Support procs
  730. #############################################################################
  731.  
  732. #############################################################################
  733. # Prompt the user to enter a string containing command-line args.
  734. #
  735. proc getCmdlineArgs {} {
  736.     global PerlmodeVars
  737.     set oldargs $PerlmodeVars(perlCmdlineArgs)
  738.     if {![catch {prompt "Command-line arguments (if any):" $oldargs} args]} {
  739.         set PerlmodeVars(perlCmdlineArgs) $args
  740.     } else {
  741.         error "getCmdlineArgs: User cancelled"
  742.     }
  743.     return $args
  744. }
  745.  
  746. #############################################################################
  747. # Tell MacPerl to run a script file:
  748. #
  749. proc perlExecuteFile {path {args {}} {flags {}}} {
  750.     global ALPHA macperlPath
  751.     global perlGetOutput perlAutoSwitch perlPromptArgs perlUseDebug
  752.     global scriptFile scriptStart filterHeadLen
  753.     
  754.     if {[string length $path]} {
  755.         set name [checkRunning MacPerl McPL macperlPath 0]
  756.         if {[string length $name]} {
  757.                 
  758.             set ok [regexp {(.*):([^:]*)} $path pathname dirname filename]
  759.             if {!$ok} {    set name $wname    }
  760.  
  761.             if {$path != [scriptPath]} {    
  762.                 set filterHeadLen 0    
  763.             }
  764.             
  765.             if {$perlUseDebug} {
  766.                 append flags "debug"
  767.             }
  768.             if {$perlPromptArgs} { 
  769.                 append args " [getCmdlineArgs]"
  770.             }
  771.             
  772.             sendCloseWinName MacPerl MacPerl
  773.             sendCloseWinName MacPerl "Perl Debug"
  774.             if {$perlAutoSwitch || $perlUseDebug} then {
  775.                 switchTo $name
  776.             } else {
  777.                 message "Running file \"$filename\" as Perl script"
  778.                 watchCursor
  779.             }
  780.             
  781.             perlDoScript "MacPerl" $path $args {} $flags
  782.             
  783. # (not sure which choice is better...)
  784. #            if {!$perlAutoSwitch} then {switchTo $ALPHA}
  785.             switchTo $ALPHA
  786. #
  787.             if {![getMacPerlError]} {
  788.                 if {$perlGetOutput} then {openPerlOutput}
  789.             }
  790.         } else {
  791.             alertnote "Couldn't run MacPerl"
  792.         }
  793.     } else {
  794.         alertnote "No file specified to execute"
  795.     }
  796. }
  797.  
  798. #############################################################################
  799. # Run a MacPerl script, passed explicitly as a string:
  800. #
  801. # If no "#!/bin/perl" line already exists, one is preprended to the script
  802. # by wrapSelectScript, which also sets $filterHeadLen for use by 
  803. # getMacPerlError.
  804. # 
  805. proc perlExecuteScript {script {args ""} {flags {}} } {
  806.     global macperlPath perlGetOutput perlAutoSwitch perlPromptArgs
  807.     global scriptFile scriptStart filterHeadLen perlUseDebug ALPHA
  808.     
  809.     if {$script != ""} {
  810.         set script [wrapSelectScript $script]
  811.         incr scriptStart -$filterHeadLen
  812.         
  813.         set ok [regexp {(.*):([^:]*)} $scriptFile pathname dirname filename]
  814.         if {!$ok} {    set name $wname    }
  815.  
  816. #        perlExecuteFile [scriptPath] $args $flags
  817.  
  818.         set name [checkRunning MacPerl McPL macperlPath 0]
  819.         if {[string length $name]} {
  820.         
  821.             if {$perlUseDebug} {
  822.                 append flags "debug"
  823.             }
  824.             if {$perlPromptArgs} { 
  825.                 append args " [getCmdlineArgs]"
  826.             }
  827.             
  828.             sendCloseWinName MacPerl MacPerl
  829.             sendCloseWinName MacPerl "Perl Debug"
  830.             if {$perlAutoSwitch || $perlUseDebug} then {
  831.                 switchTo $name
  832.             } else {
  833.                 message "Running buffer \"$filename\" as Perl script"
  834.                 watchCursor
  835.             }
  836.             
  837.             perlDoScript "MacPerl" $script $args {} $flags
  838.             
  839.             switchTo $ALPHA
  840.  
  841.             if {![getMacPerlError]} {
  842.                 if {$perlGetOutput} then {openPerlOutput}
  843.             }
  844.         }
  845.         
  846.     } else {
  847.             alertnote "Can't run an empty script"
  848.     }
  849. }
  850.  
  851. #############################################################################
  852. # Prepare the contents of a disk file for use as a text-filter script. 
  853. # (calls perlTextFilter to actually run the script)
  854. # 
  855. proc perlFileAsFilter {path} {
  856.     global scriptFile scriptStart perlPrevScript perlMenu PerlmodeVars
  857.     
  858.     regexp {(.*):([^:]*)} $path pathname dirname name
  859.     
  860.     if {![catch {readFile $path} coreScript]} {
  861.         set script [wrapFilterScript $coreScript]
  862.         set scriptFile $path
  863.         set scriptStart 1
  864.         set perlPrevScript [list "file" $path]
  865.         set PerlmodeVars(perlLastFilter) $perlPrevScript 
  866.         enableMenuItem $perlMenu repeatLastFilter 1
  867.         message "Running file \"$name\" as text filter ..."
  868.         
  869.         perlTextFilter $script
  870.     } else {
  871.         set perlPrevScript {}
  872.         set PerlmodeVars(perlLastFilter) $perlPrevScript 
  873.         enableMenuItem $perlMenu repeatLastFilter 0
  874.         
  875.         alertnote "Couldn't read the script file : $path"
  876.         return
  877.     }
  878. }
  879.  
  880. #############################################################################
  881. # Prepare the contents of a text window for use as a text-filter script. 
  882. # (calls perlTextFilter to actually run the script)
  883. # 
  884. proc perlBufferAsFilter {wname} {
  885.     global scriptFile scriptStart perlPrevScript perlMenu PerlmodeVars
  886.  
  887.     set ok [regexp {(.*):([^:]*)} $wname pathname dirname name]
  888.     if {!$ok} {    set name $wname    }
  889.     
  890.     if {[lsearch [winNames -f] $wname] >= 0} {
  891.         set coreScript [getText -w $wname 0 [maxPos -w $wname]]
  892.         
  893.         # Does it have any text in it?
  894.         if {[string length $coreScript]} {
  895.             set scriptFile $wname
  896.             set scriptStart 1
  897.             set script [wrapFilterScript $coreScript]
  898.             set perlPrevScript [list "buffer" $wname]
  899.             set PerlmodeVars(perlLastFilter) $perlPrevScript 
  900.             enableMenuItem $perlMenu repeatLastFilter 1
  901.             message "Running buffer \"$name\" as text filter ..."
  902.             
  903.             perlTextFilter $script
  904.         }
  905.     } else {
  906.         set perlPrevScript {}
  907.         set PerlmodeVars(perlLastFilter) $perlPrevScript 
  908.         enableMenuItem $perlMenu repeatLastFilter 0
  909.  
  910.         alertnote "Couldn't find buffer : $name"
  911.     }
  912. }
  913.  
  914. #############################################################################
  915. # Run a Perl script as a command-line text filter, arranging for a text
  916. # buffer to be attached as standard input.  The calling routine should already
  917. # have processed the script with wrapFilterScript.  This routine actually
  918. # send the script and takes care of writing the input and reading the output 
  919. # files.
  920. # 
  921. proc perlTextFilter {script {args {}} {flags {}}} {
  922.     global macperlPath perlOverwrite perlUsebuffer perlPromptArgs
  923.     global filterHeadLen scriptFile scriptStart perlUseDebug ALPHA
  924.     global perlOutputWindow perlRecycleOutput
  925.  
  926.     set name [checkRunning MacPerl McPL macperlPath 0]
  927.     if {![string length $name]} {
  928.         alertnote "Couldn't run MacPerl"
  929.         error "Couldn't run MacPerl"
  930.     }
  931.     writeStdin
  932.  
  933.     if {$perlUseDebug} {
  934.         append flags "debug"
  935.     }
  936.     if {$perlPromptArgs} { 
  937.         append args " [getCmdlineArgs]"
  938.     }
  939.     
  940.     sendCloseWinName MacPerl MacPerl
  941.     sendCloseWinName MacPerl "Perl Debug"
  942.     
  943.     if {$perlUseDebug} then {
  944.         switchTo $name
  945.         perlDoScript "MacPerl" [scriptPath] $args [list [stdinPath]] $flags
  946.         set err [getMacPerlError]
  947.  
  948.     } else {
  949.         watchCursor
  950.         set reply [perlDoScriptBatch "MacPerl" [scriptPath] $args [list [stdinPath]]]
  951.         set err [getBatchError $reply]
  952.     }
  953.     
  954.     switchTo $ALPHA
  955.     
  956.     if {$err == 0} {
  957.         if {$perlUseDebug} {
  958.             set outp [sendGetText MacPerl MacPerl]
  959.         } else {
  960. #            set outp [parseReplyOutp $reply]
  961.             set outp [parseReplyResult $reply]
  962.         }
  963.         pasteFilterResult $outp
  964.     }
  965. }
  966.  
  967.  
  968. #############################################################################
  969. # Check the MacPerl output window for error messages.
  970. #
  971. proc getMacPerlError {} {
  972.     
  973.     set diag [getPerlDiag 40]
  974.     set srcs [parseDiagSrcs $diag]
  975.     set errf [parseDiagErrf $diag]
  976.     set mesg [parseDiagMesg $diag]
  977.  
  978.     if {[string length $errf]} {
  979.         showPerlDiag $diag [string length $diag] $mesg $errf $srcs
  980.         gotoPerlError $errf $srcs $mesg
  981.         return 1
  982.         
  983.     } else {
  984.         return 0
  985.     }
  986. }
  987.  
  988. #############################################################################
  989. # Check the MacPerl batch reply for error messages.
  990. #
  991. proc getBatchError {reply} {
  992.     global perlErrorWindow
  993.     
  994.     set fatalError 0
  995.     set diag [parseReplyDiag $reply]
  996.     set errf [parseDiagErrf  $diag ]
  997.     set srcs [parseReplySrcs $reply]
  998.     set mesg [parseDiagMesg  $diag ]
  999.     set errn [parseReplyErrn $reply]
  1000.  
  1001.     if {$errn} {        
  1002.         showPerlDiag $diag $errn $mesg $errf $srcs
  1003.         gotoPerlError $errf $srcs $mesg
  1004.         set fatalError 1
  1005.         
  1006.     } elseif {[string length $diag] > 0} {
  1007.         showPerlDiag $diag $errn $mesg $errf $srcs
  1008.     }
  1009.     
  1010.     return $fatalError
  1011. }
  1012.  
  1013. #############################################################################
  1014. # Display the Perl diagnostic output in its own window.
  1015. #
  1016. proc showPerlDiag {diag {errn 1} {mesg {}} {errf {}} {srcs {}}} {
  1017.         global perlErrorWindow    
  1018.         
  1019.         set currWin [lindex [winNames] 0]
  1020.         if {[lsearch [winNames] $perlErrorWindow] >= 0} {
  1021.             bringToFront $perlErrorWindow
  1022.             setWinInfo read-only 0
  1023.             deleteText 0 [maxPos] 
  1024.             insertText $diag
  1025.         } else {
  1026.             new -n $perlErrorWindow 
  1027.              insertText $diag
  1028.         }
  1029.         
  1030.         goto 0
  1031.         catch {shrinkWindow 1}
  1032.         setWinInfo dirty 0
  1033.         setWinInfo read-only 1
  1034.         bringToFront $currWin
  1035. }
  1036.  
  1037. #############################################################################
  1038. # Bring up a window containing the bug-ridden Perl code and highlight the
  1039. # line at which the error was found.
  1040. #
  1041. proc gotoPerlError {errf srcs {mesg {}}} {
  1042.     global scriptFile scriptStart filterHeadLen
  1043.  
  1044.     if {$errf == [scriptPath] || $errf == "<AppleEvent>"} {
  1045.         set errf $scriptFile
  1046.         # Convert it to the line number in the original file
  1047.         set srcs [expr $srcs + $scriptStart - $filterHeadLen - 1]
  1048.     }
  1049.     # ... and leave an informative error message
  1050.     #
  1051.     if {[string length $mesg]} {
  1052.         set mesg "$mesg at Line $srcs"            
  1053.     } else {
  1054.         set mesg "MacPerl flagged an error at Line $srcs"    
  1055.     }
  1056.     
  1057.     # Bring up the script file and highlight the flagged line
  1058.     #
  1059.     catch {gotoFileLine $errf $srcs $mesg} fname    
  1060. }
  1061.  
  1062. #############################################################################
  1063. # Read the first block of lines (up to a maximum number) from the MacPerl
  1064. # output window.
  1065. #
  1066. proc getPerlDiag {maxlines} {
  1067.     set pat0 {^[ \t]*$}
  1068.  
  1069.     set lines {}    
  1070.  
  1071.     # read first $maxlines of output to the MacPerl window
  1072.     # (faster, but assumes error message won't appear at 
  1073.     # the end of a lot of output).
  1074.     #
  1075.     set nlines [sendCountLines MacPerl MacPerl]
  1076.     set nlines [expr ($nlines > $maxlines)?$maxlines:$nlines]
  1077.     if {$nlines > 0} {
  1078.         set output [sendGetText MacPerl MacPerl 1 $nlines]
  1079.         
  1080.         foreach line [split $output "\r"] {
  1081.             if  {[regexp $pat0 $line mtch]} {
  1082.                 break
  1083.             } else {
  1084.                 append lines "$line\n"
  1085.             }
  1086.         }
  1087.     }
  1088.     return $lines
  1089. }
  1090.  
  1091. #############################################################################
  1092. # Extract various items out of the MacPerl diagnostic output
  1093. #
  1094.  
  1095. # Name of the file in which the error was found
  1096. #
  1097. proc parseDiagErrf {diag}    {
  1098.     if {![regexp {File '([^']+)'; Line} $diag allofit errf]} { 
  1099.         set errf {}
  1100.     }
  1101.     return $errf
  1102. }
  1103.  
  1104. # The line number on which the error was found
  1105. #
  1106. proc parseDiagSrcs {diag}    {
  1107.     if {![regexp {File '[^']+'; Line ([0-9]+)} $diag allofit srcs]} { 
  1108.         set srcs 0 
  1109.     }
  1110.     return $srcs
  1111. }
  1112.  
  1113. # The error message associated with error
  1114. #
  1115. proc parseDiagMesg {diag} {
  1116.     set pat1 {^#(.*)$}
  1117.     set pat2 {File '([^']+)'; Line ([0-9]+)}
  1118.     
  1119.     set errMessage {}
  1120.     set errFound 0
  1121.     
  1122.     foreach line [split $diag "\n"] {
  1123.         if {[regexp $pat2 $line mtch num]} {
  1124.             set errFound 1
  1125.         } elseif {[regexp $pat1 $line mtch err]} {
  1126.             if {$errFound == 0} {
  1127.                 set errMessage $err
  1128.             }
  1129.         }
  1130.     }
  1131.     return $errMessage
  1132. }
  1133.  
  1134. #############################################################################
  1135. # Extract various return parameters out of a MacPerl DoScript reply
  1136. #
  1137.  
  1138. # Result from batch script
  1139. #
  1140. proc parseReplyResult {reply} {
  1141.     if {![regexp {'?\-\-\-\-'?:╥([^╙]*)╙} $reply allofit result]} { 
  1142.         set result {}
  1143.     }
  1144.     return $result
  1145. }
  1146.  
  1147. # Standard output of batch script
  1148. #
  1149. proc parseReplyOutp {reply} {
  1150.     if {![regexp {OUTP:╥([^╙]*)╙} $reply allofit outp]} { 
  1151.         set outp {}
  1152.     }
  1153.     return $outp
  1154. }
  1155.  
  1156. # Diagnostic output of the batch script
  1157. #
  1158. proc parseReplyDiag {reply}    {
  1159.     if {[regexp {diag:╥([^╙]*)╙} $reply allofit diag]}  {
  1160.     } else { 
  1161.         set diag {}
  1162.     }
  1163.     return $diag
  1164. }
  1165.  
  1166. # File alias of the script file in which the error was found
  1167. #
  1168. proc parseReplyErob {reply}    {
  1169.     if {![regexp {erob:alis\(╟(.*)╚\)} $reply allofit erob]} {
  1170.         set erob {} 
  1171.     }
  1172.     return $erob
  1173. }
  1174.  
  1175. # First line flagged in error
  1176. #
  1177. proc parseReplySrcs {reply}    {
  1178.     if {![regexp {erng:{srcs:([0-9]+)[^\}]*}} $reply allofit srcs]} { 
  1179.         set srcs 0 
  1180.     }
  1181.     return $srcs
  1182. }
  1183.  
  1184. # Last line flagged in error
  1185. #
  1186. proc parseReplySrce {reply}    {
  1187.     if {![regexp {erng:{[^\}]*srce:([0-9]+)}} $reply allofit srce]} { 
  1188.         set srce 0
  1189.     }
  1190.     return $srce
  1191. }
  1192.  
  1193. # Error number
  1194. #
  1195. proc parseReplyErrn {reply}    {
  1196.     if {![regexp {errn:([0-9]+)} $reply allofit errn]} {
  1197.         set errn 0
  1198.     }
  1199.     return $errn
  1200. }
  1201.  
  1202. #############################################################################
  1203. #  Take a Perl script and add commands to take the file STDIN as standard
  1204. #  input and STDOUT as standard output.  This allows scripts written as
  1205. #  Unix command-line filters to be used in the (non-MPW) Mac environment as
  1206. #  text filters.
  1207. #
  1208. #  If there's already a #! line in the script, then the new commands
  1209. #  are added after that line.  If there was no #! line in the first place,
  1210. #  one is added, in case MacPerl is set up to require it (can't hurt...) 
  1211. #
  1212. #  $filterHeadLen counts the number of lines we add to the top of the
  1213. #  original script, so that we can allow for it in interpreting error
  1214. #  messages issued by MacPerl.
  1215. #
  1216. #  *** As of MacPerl 4.1.4, this business is pretty much obsolete ***
  1217. #
  1218. proc wrapFilterScript {coreScript} {
  1219.     global filterHeadLen
  1220.  
  1221.     if {[regexp -indices {(#![     !-~]*)} $coreScript allofit cmdln]} {
  1222.         set endPos [lindex $cmdln 1]
  1223.         set filterHead [string range $coreScript 0 [expr $endPos+1]]
  1224.         set coreScript [string range $coreScript [expr $endPos+2] end]
  1225.         set filterHeadLen 0
  1226.     } else {
  1227.         set filterHead "#!/bin/perl\n"
  1228.         set filterHeadLen 1
  1229.     }
  1230.         
  1231.     set script $filterHead
  1232.     append script $coreScript
  1233.     
  1234.     # for debugging purposes, save the script on disk
  1235.     #
  1236.     writeScript $script
  1237.     return $script
  1238. }        
  1239.  
  1240. #############################################################################
  1241. #  Add a #!/bin/perl line to the script if it doesn't contain one already.
  1242. #  (MacPerl puts up dialog if this line is missing when it expects it,
  1243. #  hanging the DoScript and leaving us stuck.)
  1244. #
  1245. proc wrapSelectScript {coreScript} {
  1246.     global filterHeadLen
  1247.  
  1248.     if {![regexp -indices {(#![     !-~]*)} $coreScript allofit cmdln]} {
  1249.         set script "#!/bin/perl\n"
  1250.         append script $coreScript
  1251.         set filterHeadLen 1
  1252.     } else {
  1253.         set script $coreScript
  1254.         set filterHeadLen 0
  1255.     }
  1256.     
  1257.     # for debugging purposes, save the script on disk
  1258.     #
  1259.     writeScript $script
  1260.     return $script
  1261. }        
  1262.  
  1263. #############################################################################
  1264. #  Paste result of the filter operation in place of the input text, or in
  1265. #  a new window (depending on the flag $perlOverwrite
  1266. #
  1267. proc pasteFilterResult {text} {
  1268.     global perlOverwrite perlRecycleOutput perlOutputWindow
  1269.     global perlUsebuffer 
  1270.     
  1271.     if {!$perlOverwrite} {
  1272.         if {$perlRecycleOutput && 
  1273.             [lsearch [winNames] $perlOutputWindow] >= 0} {                
  1274.             bringToFront $perlOutputWindow
  1275.         } else {
  1276.             new -n $perlOutputWindow
  1277.         }
  1278.     }
  1279.     
  1280.     if {$perlUsebuffer || $perlRecycleOutput} {
  1281.         set from 0
  1282.         set to [maxPos]
  1283.     } else {
  1284.         set from [getPos] 
  1285.         set to [selEnd]
  1286.     }    
  1287.     replaceText $from $to $text
  1288.     
  1289.     if {!$perlOverwrite || $perlUseBuffer} {
  1290.         catch {shrinkWindow 1}
  1291.         goto 0
  1292.     } else {
  1293.         catch shrinkWindow
  1294.         goto $from
  1295.     }
  1296.     if {!$perlOverwrite} { setWinInfo dirty 0 }
  1297. }    
  1298.  
  1299. #############################################################################
  1300. #  Extend the current selection to encompass complete lines.  If the 
  1301. #  'applyToBuffer' flag is checked, then the entire buffer is selected.
  1302. #
  1303. proc completeSelection {} {
  1304.     global perlUsebuffer filterInput
  1305.     set filterInput "buffer \"[lindex [winNames] 0]\""
  1306.     if {$perlUsebuffer} {
  1307.         set start 0
  1308.         set end [maxPos]
  1309.     } else {
  1310.         set start [lineStart [getPos]]
  1311.         set end [nextLineStart [expr [selEnd]-1]]
  1312.         if {$end == $start} { set end [nextLineStart [selEnd]] }
  1313.         
  1314.         set startLine [lindex [posToRowCol $start] 0]
  1315.         set endLine [expr [lindex [posToRowCol $end] 0] - 1]
  1316.         if {$endLine > $startLine+1} {
  1317.             set filterInput "lines $startLine to $endLine of $filterInput"
  1318.         } else {
  1319.             set filterInput "line $startLine of $filterInput"
  1320.         }
  1321.    }
  1322.     return [list $start $end]
  1323. }
  1324.  
  1325. #############################################################################
  1326. #  writeStdin: Extend the selection, as appropriate, and write it to the 
  1327. #     STDIN file in the MacPerl directory.
  1328. #
  1329. #  writeScript: Write the SCRIPT file in the MacPerl directory.  MacPerl will
  1330. #     read the script from this file. 
  1331. #
  1332. proc writeStdin {} {
  1333.     set res [completeSelection]
  1334.     set tmpfid [open [stdinPath] "w+"]
  1335.     puts $tmpfid [eval getText $res]
  1336.     close $tmpfid
  1337. }
  1338.  
  1339. # This is unnecessary now, but maybe it'll still useful to save the script
  1340. # file for debugging.
  1341. #
  1342. proc writeScript {script} {
  1343.     set tmpfid [open [scriptPath] "w+"]
  1344.     puts $tmpfid $script 
  1345.     close $tmpfid
  1346. }
  1347.  
  1348. #############################################################################
  1349. # Read the MacPerl output window and load the contents, if any, into
  1350. # a new Alpha window. 
  1351. #
  1352. proc openPerlOutput {} {
  1353.     global perlRecycleOutput perlOutputWindow
  1354.     
  1355.     set output [sendGetText MacPerl MacPerl]
  1356.     if {[string length $output]} {
  1357.         if {$perlRecycleOutput && 
  1358.             [lsearch [winNames] $perlOutputWindow] >= 0} {
  1359.             
  1360.             bringToFront $perlOutputWindow
  1361.             replaceText 0 [maxPos] $output
  1362.         } else {
  1363.             new -n $perlOutputWindow
  1364.             insertText $output
  1365.         }
  1366.         catch {shrinkWindow 1}
  1367.         setWinInfo dirty 0
  1368.         goto 0
  1369.     }
  1370. }
  1371.  
  1372. #############################################################################
  1373. # translate special DoScript flags into flags string $usrf
  1374. #
  1375. proc perlScriptFlags {{flags {}}} {
  1376.      set usrf {}
  1377.  
  1378.     if {[lsearch -exact $flags "extract"] >= 0} {
  1379.         append usrf { "EXTR" 'true'}
  1380.     } elseif {[lsearch -exact $flags "noextract"] >= 0} {
  1381.         append usrf { "EXTR" 'fals'}
  1382.     }        
  1383.     if {[lsearch -exact $flags "debug"] >= 0} {
  1384.         append usrf { "DEBG" 'true'}
  1385.     } elseif {[lsearch -exact $flags "nodebug"] >= 0} {
  1386.         append usrf { "DEBG" 'fals'}
  1387.     }        
  1388.  
  1389.     if {[lsearch -exact $flags "local"] >= 0} {
  1390.         append usrf { "MODE" 'LOCL'}
  1391.     } elseif {[lsearch -exact $flags "batch"] >= 0} {
  1392.         append usrf { "MODE" 'BATC'}
  1393.     } elseif {[lsearch -exact $flags "remote"] >= 0} {
  1394.         append usrf { "MODE" 'RCTL'}
  1395.     }        
  1396.     return $usrf
  1397. } 
  1398.  
  1399. proc perlScriptArgs {{args {}} {fileargs {}}} {
  1400.     set nargs 0
  1401.     set argv {}
  1402.     
  1403.     foreach item [parseWords $args] {
  1404.         set item [string trim $item]
  1405.         if {[string length $item]} {
  1406.             append argv ", [curlyq $item]"
  1407.             incr nargs
  1408.         }
  1409.     }
  1410.     foreach filename $fileargs {
  1411.         set item [string trim $filename]
  1412.         if {[string length $item]} {
  1413.             append argv ", [curlyq $item]"
  1414.             incr nargs
  1415.         }
  1416.     }
  1417.     return $argv
  1418. }
  1419.  
  1420. #############################################################################
  1421. # General Apple Event routines
  1422. # (most of these have been moved to SystemCode:appleEvents.tcl)
  1423. #
  1424. # DoScript for MacPerl 4.1.3
  1425. # (runs in "Local" mode under v4.1.4+)
  1426. #
  1427. proc perlDoScript {appname script {args {}} {fileargs {}} {flags {}} } {
  1428.     # form list of quoted "command-line" args
  1429.     #
  1430.     if {$script != ""} {
  1431.         set argv "\[[curlyq [string trim $script]]"
  1432. #         foreach item [split [join $args " "] " "] {
  1433. #}
  1434.         append argv [perlScriptArgs $args $fileargs]
  1435.         append argv "]"
  1436.         
  1437.         set usrf [perlScriptFlags $flags]
  1438.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc $usrf \"----\" [list $argv] "]
  1439.     #    alertnote $reply
  1440.     }
  1441. }
  1442.  
  1443. # DoScript for MacPerl 4.1.4+
  1444. #
  1445. proc perlDoScriptBatch {appname script {args {}} {fileargs {}}} {
  1446.     
  1447.     # form list of quoted "command-line" args
  1448.     #
  1449.     if {$script != ""} {
  1450.         set argv "\[[curlyq [string trim $script]]"
  1451.         append argv [perlScriptArgs $args $fileargs ] 
  1452.         append argv "]"
  1453.                 
  1454.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc MODE BATC \"----\" [list $argv]"]
  1455.         
  1456. #         perlDisplayReply $reply
  1457.  
  1458.     } else {
  1459.         set reply {}
  1460.     }
  1461.     return $reply
  1462. }
  1463.  
  1464. # For debugging 
  1465. #
  1466. proc perlDisplayReply {reply} {
  1467.     set currWin [lindex [winNames] 0]
  1468.     new -n {*** DoScript Reply **} 
  1469.     insertText $reply
  1470.         
  1471.     goto 0
  1472.     catch {shrinkWindow 1}
  1473.     setWinInfo dirty 0
  1474.     setWinInfo read-only 1
  1475.     bringToFront $currWin
  1476. }
  1477.  
  1478. # DoScript to launch interactive debugger (for MacPerl 4.1.4+)
  1479. #
  1480. proc perlDoScriptDebug {appname script {args {}} {fileargs {}}} {
  1481.     
  1482.     # form list of quoted "command-line" args
  1483.     #
  1484.     if {$script != ""} {
  1485.         set argv "\[[curlyq [string trim $script]]"
  1486.         append argv [perlScriptArgs "$args debug" $fileargs ] 
  1487.         append argv "]"
  1488.                 
  1489.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc MODE RCTL \"----\" [list $argv]"]
  1490.  
  1491.         new -n {** DoScriptDebug Reply **} 
  1492.         insertText $reply
  1493.             
  1494.         goto 0
  1495.         catch {shrinkWindow 1}
  1496.         setWinInfo dirty 0
  1497.         setWinInfo read-only 1
  1498.  
  1499.  
  1500.     } else {
  1501.         set reply {}
  1502.     }
  1503.     return $reply
  1504. }
  1505.  
  1506. ##############################################################################
  1507. # Automatic indexing of Perl subs
  1508. #
  1509. proc PerlMarkFile {} {
  1510.     set end [maxPos]
  1511.     set pos 0
  1512.     set l {}
  1513.     while {![catch {search -f 1 -r 1 -m 0 -i 0 {^sub} $pos} res]} {
  1514.         set start [lindex $res 0]
  1515.         set end [nextLineStart $start]
  1516.         set text [lindex [getText $start $end] 1]
  1517.         set pos $end
  1518.         set inds($text) [lineStart [expr $start - 1]]
  1519.     }
  1520.  
  1521.     if {[info exists inds]} {
  1522.         foreach f [lsort [array names inds]] {
  1523.             set next [nextLineStart $inds($f)]
  1524.             setNamedMark $f $inds($f) $next $next
  1525.         }
  1526.     }
  1527. }
  1528.  
  1529. ##############################################################################
  1530. # Cmd-double-click support for Perl mode. 
  1531. # 
  1532. proc PerlDblClick {from to} {
  1533.     global HOME perlKeyWords perlSpecialVars perlExprWords
  1534.     global perlSearchPath
  1535.     
  1536.     set pc  [lookAt [expr $from - 1]]
  1537.     set ppc [lookAt [expr $from - 2]]
  1538.     set tc  [lookAt $to]
  1539.     
  1540.     # Extend selection to include special characters
  1541.     #
  1542.     if {$pc == {$}} { 
  1543.         if {$from == $to} { incr to }
  1544.         incr from -1
  1545.         if {$tc == {^}} { incr to }
  1546.         
  1547.     } elseif {$pc == {^} && $ppc == {$}} {
  1548.         incr from -2
  1549.         
  1550.     } elseif {$pc == {%} || $pc == {@}} {
  1551.         incr from -1
  1552.     }
  1553.     
  1554.     # Return if there's no selected text
  1555.     if {$to > $from} {
  1556.         select $from $to
  1557.         set text [getSelect]
  1558.         set qtext [quoteExpr $text]
  1559.     } else {
  1560.         return
  1561.     }
  1562.  
  1563.     set perlSearchPath {}
  1564.     
  1565.     # Function call
  1566.     if {$pc == "&"} {
  1567.          if {![catch {search -f 1 -r 1 -m 0 -s "sub *$qtext *\{" 0} mtch]} {
  1568.              pushMark
  1569.              eval select $mtch
  1570.              message "Use Ctl-. to return to original position"
  1571.          } else {
  1572.              message {Sub definition not found}
  1573.          }
  1574.  
  1575.     # Look up keywords in the man page by their file marks
  1576.     } elseif {[lsearch -exact $perlKeyWords $text] >= 0} {
  1577.         editMark "$HOME:Help:Perl Commands" $text
  1578.  
  1579.     # Special vars aren't marked, so search for their definitions
  1580.     } elseif {[lsearch -exact $perlSpecialVars $text] >= 0} {
  1581.         if {[lsearch -exact [winNames] "Perl Commands"] >= 0} {
  1582.             bringToFront "Perl Commands"
  1583.         } else {
  1584.             edit "$HOME:Help:Perl Commands"
  1585.         }
  1586.         if {![catch {search -f 0 -r 0 -m 0 -i 0 -s "     $text  " [maxPos]} mtch]} {
  1587.             goto [lindex $mtch 0]
  1588.         }
  1589.  
  1590.     # Flow control statements don't have separate entries
  1591.     } elseif {[lsearch -exact $perlExprWords $text] >= 0} {
  1592.         editMark "$HOME:Help:Perl Commands" "Compound statements"
  1593.     
  1594.     # If user clicked the arg of a 'require' command, open the file
  1595.     } elseif {![catch {perlFindRequire $from $to} filename]} {
  1596.         openPerlFile $filename
  1597.  
  1598.     # Other
  1599.     } else {
  1600.         select $from $to
  1601.         message {Command-double-click on keywords, special vars, and req'd filenames}
  1602.     }
  1603.  
  1604. }
  1605.  
  1606. # Open a 'require'd Perl file.
  1607. # 
  1608. proc perlFindRequire {from {to 0}} {
  1609.     set reqPat {^[     ]*require[     ]*(\"[^\"]+\"|\'[^\']+\'|[^     ]+)}
  1610.     if {$to == 0} { set to $from }
  1611.     set beg [lineStart $from]
  1612.     set end [nextLineStart $to]
  1613.     set words [parseWords [getText $beg $end]]
  1614.     if {[string tolower [lindex $words 0]] != "require"} {
  1615.         error "Not a require statement"
  1616.     }
  1617.     set root [string trim [lindex $words 1] {'"}]
  1618.     return $root
  1619. }
  1620.  
  1621. proc inlineRequires {} {
  1622.     global lastMatchingLines
  1623.     
  1624.     set reqPat {^[     ]*require[     ]*(\"[^\"]+\"|\'[^\']+\'|[^     ]+)}
  1625.     set pos 0
  1626.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $reqPat $pos} mtch]} {
  1627.          [lindex [posToRowCol [lindex $mtch 0]] 0]] 
  1628.         set name [string [eval getText $mtch]
  1629.         set pos [lindex $mtch 1]
  1630.         incr matches
  1631.     }
  1632. }
  1633.  
  1634. # Open a Perl source file. 
  1635. #
  1636. proc openPerlFile {file {extensions {""}}} {
  1637.     global perlSearchPath
  1638.     # Determine absolute file specification
  1639.     # Ignore $extensions if $file already has an extension
  1640.     if {[string length [file extension $file]] == 0} {
  1641.         set extensions {""}
  1642.     }
  1643.     foreach ext $extensions {
  1644.         set filename [absolutePath $file$ext]
  1645.         if {![catch {openFileQuietly $filename}]} {
  1646.             message $filename
  1647.             return 
  1648.         }
  1649.     }
  1650.     if {[llength $perlSearchPath] == 0} { buildPerlSearchPath }
  1651.     foreach folder $perlSearchPath {
  1652.         foreach ext $extensions {
  1653.             set filename "$folder$file$ext"
  1654.             if {![catch {openFileQuietly $filename}]} {
  1655.                 message $filename
  1656.                 return     
  1657.             }
  1658.         }
  1659.     }
  1660.     beep
  1661.     message "can't find Perl source file \"$file\""
  1662. }
  1663.  
  1664. # Return a list of folders in which to search for Perl library files, 
  1665. # including the lib folder in the Perl application directory and the
  1666. # $perlLib folder (if it exists) .  
  1667. # The current folder is not included in the list.
  1668. #
  1669. # (The $perlLib folder is assigned from the AppPaths submenu.)
  1670. #
  1671. proc buildPerlSearchPath {} {
  1672.     global perlLib macperlPath perlSearchPath
  1673.     message "building Perl search path..."
  1674.     set folders {}
  1675.     
  1676.     # The local lib folder:
  1677.     if {[info exists perlLib] && [string length $perlLib] > 0} { 
  1678.         set folders [concat $folders [list $perlLib]]
  1679.         # Search subfolders one level deep:
  1680.         set folders [concat $folders [listSubfolders $perlLib 1]]
  1681.     }
  1682.  
  1683.     # Any "*lib*" folders in the MacPerl application folder:
  1684.     if {[info exists macperlPath] && [string length $macperlPath] > 0} { 
  1685.         set appDir [file dirname $macperlPath]
  1686.         set folders [concat $folders [list $appDir]]
  1687.         # Bug:  'glob' is case sensitive!
  1688.         foreach folder [glob "$appDir:*\[Ll\]ib*"] {
  1689.             set folders [concat $folders [list $folder]]
  1690.             # Search subfolders one level deep:
  1691.             set folders [concat $folders [listSubfolders $folder 1]]
  1692.         }
  1693.     }
  1694.  
  1695.     # Make sure each folder ends with a colon
  1696.     set perlSearchPath {}
  1697.     foreach folder $folders {
  1698.         set folder "[string trimright $folder {:}]:"
  1699.         set perlSearchPath [concat $perlSearchPath [list $folder]]
  1700.     }
  1701. }
  1702.  
  1703. ###########################################################################
  1704.  
  1705.  
  1706.