home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / Perl Mode / perl5.tcl < prev    next >
Encoding:
Text File  |  1998-05-29  |  7.6 KB  |  228 lines  |  [TEXT/ALFA]
  1. # ◊◊◊◊ dummy to load file ◊◊◊◊ #
  2. proc perl5.tcl {} {}
  3.  
  4. ##############################################################################
  5. # Colorization and cmd-dbl-click support for Perl 5
  6. #
  7. # Author: Tom Pollard <pollard@chem.columbia.edu>
  8. # Last modified: 1/1/96
  9. #
  10. # if {![info exists perlDocs]} {
  11. #     set perlDocs "$HOME:Help:Perl Docs"
  12. # }
  13.  
  14. ##############################################################################
  15. # ◊◊◊◊ Colorization setup ◊◊◊◊ #
  16. #
  17. # Keywords are separated here according to their location in the Perl 5
  18. # documentation for the convenience of the cmd-double-click mechanism.
  19. #
  20. set perlKeyWords {}
  21.  
  22. # These are described in the "Compound statements" section of "perlsyn"
  23. #
  24. set words {  
  25.     continue else elsif for foreach if return unless until while 
  26.     eq ne cmp lt gt le ge
  27. }
  28. foreach wd $words { 
  29.     set perlLookup($wd) [list perlsyn {Compound statements}] 
  30. }
  31. set perlKeyWords [concat $perlKeyWords $words]
  32.  
  33. # These are described in the "SYNOPSIS" section of "perlsub"
  34. #
  35. set words { sub }
  36. foreach wd $words { set perlLookup($wd) [list perlsub {SYNOPSIS}] }
  37. set perlKeyWords [concat $perlKeyWords $words]
  38.  
  39. # These are described in the "Packages" section of "perlmod"
  40. #
  41. set words { package }
  42. foreach wd $words { set perlLookup($wd) [list perlmod {Packages}] }
  43. set perlKeyWords [concat $perlKeyWords $words]
  44.  
  45. # These are described in the "Package Constructors and Destructors" 
  46. # section of "perlmod" and can't be colorized.
  47. #
  48. set words { BEGIN END }
  49. foreach wd $words { 
  50.     set perlLookup($wd) [list perlmod {Package Constructors and Destructors}] 
  51. }
  52.  
  53. # These are described in the "A Class is Simply a Package" 
  54. # section of "perlobj" and can't be colorized.
  55. #
  56. set words { @ISA $ISA }
  57. foreach wd $words { 
  58.     set perlLookup($wd) [list perlobj {A Class is Simply a Package}] 
  59. }
  60.  
  61. # These are described in the "SYNOPSIS" section of "perlovl" and 
  62. # can't be colorized.
  63. #
  64. set words { %OVERLOAD $OVERLOAD }
  65. foreach wd $words { set perlLookup($wd) [list perlovl {SYNOPSIS}] }
  66.  
  67. # Special variables are described in "perlvar" (and are not all
  68. # individually marked, so we have to search for them.)
  69. #
  70. # This group can safely be colorized...
  71. #
  72. set words {
  73.     $_ $1 $2 $3 $4 $5 $6 $7 $8 $9 $& $` $' $+ $* $.  $/ $| $, $\\ $" $; $# $% 
  74.     $= $- $~ $^ $: $?  $!  $@ $$ $< $> $( $) $0 $[ $]
  75. }
  76. foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
  77. set perlKeyWords [concat $perlKeyWords $words]
  78.  
  79. #... while this group is forced lower-case by the current colorization scheme
  80. #
  81. set words {
  82.     $ARG $MATCH $PREMATCH $POSTMATCH $LAST_PAREN_MATCH $MULTILINE_MATCHING 
  83.     $INPUT_LINE_NUMBER $NR $INPUT_RECORD_SEPARATOR $RS $OUTPUT_AUTOFLUSH 
  84.     $OUTPUT_FIELD_SEPARATOR $OFS $OUTPUT_RECORD_SEPARATOR $ORS 
  85.     $LIST_SEPARATOR $SUBSCRIPT_SEPARATOR $SUBSEP $OFMT $FORMAT_PAGE_NUMBER 
  86.     $FORMAT_LINES_PER_PAGE $FORMAT_LINES_LEFT $FORMAT_NAME $FORMAT_TOP_NAME 
  87.     $FORMAT_LINE_BREAK_CHARACTERS $FORMAT_FORMFEED $^L $ACCUMULATOR $^A 
  88.     $CHILD_ERROR $OS_ERROR $ERRNO $EVAL_ERROR $PROCESS_ID $PID $REAL_USER_ID 
  89.     $UID $EFFECTIVE_USER_ID $EUID $REAL_GROUP_ID $GID $EFFECTIVE_GROUP_ID 
  90.     $EGID $PROGRAM_NAME $PERL_VERSION $DEBUGGING $^D $SYSTEM_FD_MAX $^F 
  91.     $INPLACE_EDIT $^I $PERLDB $^P $BASETIME $^T $WARNING $^W 
  92.     $EXECUTABLE_NAME $^X $ARGV @ARGV @INC %INC $INC $ENV $SIG %ENV %SIG
  93. }
  94. foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
  95.  
  96. # These are also described in "perlvar", despite being functions.
  97. #
  98. set words {
  99.     input_line_number input_record_separator autoflush 
  100.     output_field_separator output_record_separator format_page_number 
  101.     format_lines_per_page format_lines_left format_name format_top_name 
  102.     format_line_break_characters format_formfeed
  103. }
  104. foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
  105. set perlKeyWords [concat $perlKeyWords $words]
  106.  
  107.  
  108. # These are described in "perlfunc"
  109. #
  110. set words {
  111.     abs accept alarm atan2 bind binmode bless caller chdir chmod chomp 
  112.     chop chown chr chroot close closedir connect cos crypt dbmclose dbmopen 
  113.     defined delete die do dump each eof eval exec exists exit exp fcntl 
  114.     fileno flock fork formline getc getlogin getpeername getpgrp getppid 
  115.     getpriority getpwnam getgrnam gethostbyname getnetbyname getprotobyname 
  116.     getpwuid getgrgid getservbyname gethostbyaddr getnetbyaddr 
  117.     getprotobynumber getservbyport getpwent getgrent gethostent getnetent 
  118.     getprotoent getservent setpwent setgrent sethostent setnetent 
  119.     setprotoent setservent endpwent endgrent endhostent endnetent 
  120.     endprotoent endservent getsockname getsockopt glob gmtime goto grep hex 
  121.     import index int ioctl join keys kill last lc lcfirst length link listen 
  122.     local localtime log lstat m map mkdir msgctl msgget msgsnd msgrcv my 
  123.     next no oct open opendir ord pack pipe pop pos print printf push q qq qx 
  124.     qw quotemeta rand rand read readdir readlink recv redo ref rename 
  125.     require reset return reverse rewinddir rindex rmdir s scalar seek 
  126.     seekdir select select semctl semget semop send setpgrp setpriority 
  127.     setsockopt shift shmctl shmget shmread shmwrite shutdown sin sleep 
  128.     socket socketpair sort splice split sprintf sqrt srand stat study substr 
  129.     symlink syscall sysread system syswrite tell telldir tie time times tr 
  130.     truncate uc ucfirst umask undef unlink unpack untie unshift use utime 
  131.     values vec wait waitpid wantarray warn write y
  132. }
  133. foreach wd $words { set perlLookup($wd) [list perlfunc $wd] }
  134. set perlKeyWords [concat $perlKeyWords $words]
  135.  
  136. regModeKeywords -e {#} -c red -k blue -s [set PerlmodeVars(stringColor)] Perl $perlKeyWords
  137. unset perlKeyWords
  138.  
  139. set perlKeyWords [array names perlLookup]
  140.  
  141. ##############################################################################
  142. # ◊◊◊◊ Cmd-double-click support ◊◊◊◊ #
  143. # 
  144. proc Perl::DblClick {from to} {
  145.     global HOME perlKeyWords perlLookup perlDocs perlVersion
  146.     global perlSearchPath
  147.     
  148.     set pc  [lookAt [expr $from - 1]]
  149.     set ppc [lookAt [expr $from - 2]]
  150.     set tc  [lookAt $to]
  151.     
  152.     # Extend selection to include special characters
  153.     #
  154.     if {$pc == {$}} { 
  155.         if {$from == $to} { incr to }
  156.         incr from -1
  157.         if {$tc == {^}} { incr to }
  158.         
  159.     } elseif {$pc == {^} && $ppc == {$}} {
  160.         incr from -2
  161.         
  162.     } elseif {$pc == {%} || $pc == {@}} {
  163.         incr from -1
  164.     }
  165.     
  166.     # Return if there's no selected text
  167.     if {$to > $from} {
  168.         select $from $to
  169.         set text [getSelect]
  170.         set qtext [quote::Regfind $text]
  171.     } else {
  172.         return
  173.     }
  174. #     alertnote "\"$text\""
  175.  
  176.     set perlSearchPath {}
  177.  
  178.     # Function call
  179.     if {$pc == "&"} {
  180.          if {![catch {search -f 1 -r 1 -m 0 -s "sub *$qtext *\{" 0} mtch]} {
  181.              pushPosition
  182.              eval select $mtch
  183.              message "Use Ctl-. to return to original position"
  184.          } else {
  185.              message {Sub definition not found}
  186.          }
  187.  
  188.     # Look up keywords in the man page by their file marks
  189.     } elseif {[lsearch -exact $perlKeyWords $text] >= 0} {
  190.         set file [lindex $perlLookup($text) 0]
  191.         set mark [lindex $perlLookup($text) 1]
  192.         openFileQuietly [file join $perlDocs $file]
  193.         podFindMark "$mark"
  194.     
  195.     # If user clicked the arg of a 'require' command, open the file
  196.     } elseif {![catch {perlFindRequire $from $to} filename]} {
  197.         openPerlFile $filename
  198.  
  199.     # Other
  200.     } else {
  201.         select $from $to
  202.         message {Command-double-click on keywords, special vars, and req'd filenames}
  203.     }
  204.  
  205. }
  206.  
  207. #############################################################################
  208. # ◊◊◊◊ pod utilities ◊◊◊◊ #
  209. # These last two procs are duplicated from "pod.tcl", so that that file 
  210. # doesn't have to be loaded in order simply to reference the Perl 5 docs
  211. #
  212. proc podFindMark {mark} {
  213.     global podMarkIndent
  214.     set mark0 $mark
  215.     set marks [getNamedMarks -n]
  216.     regsub -all {[\/\(\)<>^]} $mark { } mark
  217.     set mark [quote::Regfind $mark]
  218.     set item [lsearch -regexp $marks " *${mark}"]
  219.     if {$item >= 0} {
  220.         gotoMark [lindex $marks $item]
  221.     } elseif {![catch {search -f 1 -r 1 -i 0 -m 0 -s " *${mark}" 0} mtch]} {
  222.         goto [lindex $mtch 0]
  223.     } else {
  224.         message "Couldn't locate the section for \"$mark0\""
  225.     } 
  226. }
  227.  
  228.