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