MacWorld 1999 March - Disc 1/Macworld (1999-03) (Disk 1).dmg/Shareware World/Utilities/Text Processing/Alpha/Tcl/Modes/Perl Mode/perlMode.tcl

Text File | 1998-08-13 | 10.2 KB | 383 lines | [TEXT/ALFA]

#############################################################################
# perlMode.tcl
# -----------
#
# This is a set of routines that allow Alpha to act as a front end for the
# standalone MacPerl application and that allow Perl scripts to be used as
# text filters in Alpha.  These functions are accessed through a special
# MacPerl menu.
#
# The features of this package are explained in the file "MacPerl Help",
# accessible from the Help menu. Version history is found in
# perlVersionHistory.tcl.
#
#  Author: Tom Pollard
#  E-mail: <[e-mail]>
#
# Contributors: Dan Herron     <[e-mail]>
#               David Schooley <[e-mail]>
#               Vince Darley   <[e-mail]>
#               Tom Fetherston <[e-mail]>
#               Martijn Koster <[e-mail]>
#
#############################################################################
# ◊◊◊◊ mode mini-load ◊◊◊◊ #
alpha::mode Perl 3.3.2 perlMenu {*.pl *.ph *.pm} {
    perlMenu electricBraces electricReturn electricSemicolon electricTab} {
    addMenu perlMenu "•132"
    set modeCreator(McPL) Perl
#     set perlFilterMenu "textFilters"
} help {file "MacPerl Help"} uninstall {this-directory}

# ◊◊◊◊ perl dummy proc's ◊◊◊◊ #
proc dummyPerl {} {}

# Define the dummy proc that will be called when the perl menu
# is first inserted into the menubar
#
proc perlMenu {} {
    # had to move this from perlMenu.tcl to here to ensure newPrefs are
    # loaded before we build the menu -trf
    alpha::tryToLoad "Initializing Perl menu"  perlMenu.tcl {}
    #but only once
    ;proc perlMenu {} {}
}

#############################################################################
# ◊◊◊◊ preferences ◊◊◊◊ #
#  Default settings for the Perl menu flags

newPref f perluseDebugger 0 Perl shadowPerl
newPref f perlretrieveOutput 1 Perl shadowPerl
newPref f perlautoSwitch 1 Perl shadowPerl
newPref f perloverwriteSelection 0 Perl shadowPerl
newPref f perlapplyToBuffer 1 Perl shadowPerl
newPref f perlpromptForArgs 0 Perl shadowPerl
newPref f perlRecycleOutput 0 Perl
newPref v perlPrevScript {*startup*} Perl
newPref v perlCmdlineArgs {} Perl
newPref v perlVersion {5} Perl shadowPerl [list 4 5]

newPref v perlFilterPath [file join $HOME Tcl Packages "Text Filters"] Perl rebuildFilterMenu
newPref v perlLibFolder "" Perl buildPerlSearchPath
set Perl::commentRegexp {^[ \t]*#}

#############################################################################
# Other Perl-mode variable definitions

newPref f autoMark    1    Perl
newPref f wordWrap        {0} Perl
newPref v funcExpr        {^[ \t]*sub\s+[_\w:]+(\s+\([$@%*;\]+\))?\s*\{} Perl
newPref v prefixString    {# } Perl
newPref v wordBreak        {(([$%@*]?[_\w]+)|(\$?[][&_`'+*./|,\\";#%=\~^:?!@\$<>()-])|((\$\^)\w))}
newPref v wordBreakPreface        {([^a-zA-Z0-9%_@*\$^]|.\$)} Perl
newPref v stringColor    green    Perl

# ALL THE ABOVE VARS ARE NOW GLOBAL AND MODE-VARS
#
# unsetting old prefs variables

catch {unset PerlmodeVars(elecLBrace)}
catch {unset PerlmodeVars(elecRBrace)}
catch {unset PerlmodeVars(electricReturn)}
catch {unset PerlmodeVars(electricSemi)}
catch {unset PerlmodeVars(electricTab)}

#############################################################################
# ◊◊◊◊ paths to standard files ◊◊◊◊ #
#  Return paths to standard files, based on the path to MacPerl:
#
proc macperlFolder {} {
    return [file dirname [nameFromAppl McPL]]
}

proc stdinPath {} {
   return [file join [macperlFolder] STDIN]
}

proc scriptPath {} {
   return [file join [macperlFolder] SCRIPT]
}

# ◊◊◊◊ dividers (code sectioning) ◊◊◊◊ #

##
 # -------------------------------------------------------------------------
 #
 # "Perl::insertDivider" --
 #
 #  Modified from Vince's original to allow you to just select part of
 #  an already written comment and turn it into a Divider. -trf
 # -------------------------------------------------------------------------
 ##
proc Perl::insertDivider {} {
    if {[isSelection]} {
        set enfoldThis [getSelect]
        beginningOfLine
        killLine
        insertText "##### $enfoldThis #####"
        return
    }
    elec::Insertion "##### •• #####"
}
Bind 0x14 <z> Perl::insertDivider Perl


#############################################################################
# ◊◊◊◊ Marking ◊◊◊◊ #

##############################################################################
# Automatic indexing of Perl subs
#
# called by the "M" button     Modified -trf
proc Perl::parseFuncs {} {
    set end [maxPos]
    set pos [minPos]
    set l {}
    set markExpr {^[ \t]*sub\s+[_\w:]+(\s+\([$@%*;\]+\))?\s*\{}
    set appearanceList {}
    while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
        set start [lindex $res 0]
        set end [lindex $res 1]
        set t [eval getText $res]

        switch -regexp $t {
            "sub" {
                regexp {^([ \t]*)sub\s+([_\w:]+)(\s+\(([$@%*;\]+)\))?\s*\{} $t all indent subName argTypes
                set word $subName
            }
        }
        if {$argTypes != {}} {
            set argLabel "$word$argTypes"
        } else {
            set argLabel $word
        }
        if {[info exists cnts($word)]} {
            # This section handles duplicate. i.e., overloaded names
            set cnts($word) [expr $cnts($word) + 1]
            set tailOfTag($word) " (1 of $cnts($word))"
        } else {
            #SO do: remember the following
            set cnts($word) 1
            # if this is the only occurence of this proc, remember where it starts
            set indx($word) [lineStart [expr $start - 1]]
        }
        #associate name and tag
        set tag($word) $argLabel

        #advance pos to where we want to start the next search from
        set pos $end
    }

    set rtnRes {}

    if {[info exists indx]} {
        foreach hn [lsort -ignore [array names indx]] {
            set next [nextLineStart $indx($hn)]
            set completeTag [set tag($hn)]
            if {[info exists tailOfTag($hn)]} {
                append completeTag [ set tailOfTag($hn) ]
            }

            lappend rtnRes $completeTag $next
        }
    }
    return $rtnRes
}


proc Perl::MarkFile {} {
    global PerlmodeVars

    # this is a global var in tcl where this was taken from
    set structuralMarks 1
    set pos [minPos] ;#pos to start/continue search
    set l {}
    set asEncountered {}

    #With this regex we scan for
    # a package followed by a block with indented sub's
    # a package statement with just normal, non-indented sub's
    # {
    #     (
    #     ^
    #     (
#              package\s+[_\w:]+\s*;\s*\{
#              |package\s+[_\w:]+\s*;
#              |BEGIN
#              |END
#              |sub\s+[_\w:]+(\s+\([$@%*;\]+\))?\s*\{
#              |[ \t]+sub\s+[_\w:]+(\s+\([$@%*;\]+\))?\s*\{
#              |=head1
#              |=head2(.*)Section
#              |=pod
#              |__END__
#              |__DATA__
    #     )
    #     )
    # }
    #
    # #
#     set markExpr {(^(package\s+[_\w:]+\s*;\s*\{|BEGIN|END|sub\s+[_\w:]+(\s+\([$@%*;\]+\))?\s*\{|=head1|=pod|__END__|__DATA__)(\s+[^\s;\{])*)}
    set markExpr {^(package\s+[_\w:]+\s*;\s*\{*|BEGIN|END|[ \t]*sub\s+[_\w:]+(\s+\([$@%*;\]+\))?\s*\{|=head1|=pod|__END__|__DATA__)}
    set pos 0
    set l {}
    if $structuralMarks {
        append markExpr {|(^ *###+ ([^#]+) ###+)}
    }

    set hasMarkers 0
    set inPackageSep  {}
    set allowIndentedSubs 0
    set pkgBlockEndPos 0

    while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
        set start [lindex $res 0]
        set end [lindex $res 1]
        set t [eval getText $res]

        switch -regexp $t {
            "^package" {
                regexp {^package\s+([_\w:]+)\s*;\s*(\{)*} $t all text blockBeg
                if {[set blockBeg] !=  {} } {
#                     #we have seen a "block-like package"
#                     set allowIndentedSubs 1
                    #determine where "package block" ends
                    set pkgBlockEndPos [matchIt "\{" [expr $end + 1]]
                    #
                }
                if {$structuralMarks} {
                    set text "$text •pkg"
                    set inPackageSep "::"
                } else {
                    set pos $end
                    continue
                }
            }
            "BEGIN" {
                set text " BEGIN"
            }
            "^END" {
                set text " END"
            }
            {sub\s+[_\w:]+;} {
                 set pos $end
                continue
            }
            {^[ \t]+sub} {
                if {[set start] >= [set pkgBlockEndPos]} {
                     set pos $end
                    continue
                }
                regexp {^(([ \t]*)sub\s+)([\w_:]+)} $t all preNameText indent text
                if {$structuralMarks} {
                    set text " $inPackageSep$text"
                    set start [lineStart [expr $start + [string length $preNameText] + 1]]
                }
            }
            "^sub" {
                regexp {^(sub\s+)([\w_:]+)} $t all preNameText text
                if {$structuralMarks} {
                    set text " $inPackageSep$text"
                    set start [lineStart [expr $start + [string length $preNameText] + 1]]
                }
            }
            "###+" {
                regexp {###+ ([^#]+) ###+} $t all text
                if {[regexp "^(    )|(    )###+" $t]} {
                    set text " •$text"
                } else {
                    set text "•$text"
                }
                set hasMarkers 1
            }
            "=head1" -
            "=pod" {
                set pos $end
                if {![catch {search -s -f 1 -r 1 -m 0 -i 0 "^=cut" $pos} res]} {
                    set start [lindex $res 0]
                    set end [nextLineStart $start]
                    continue
                } else {
                    message "*warning* - embeded pod with no cut encountered"
                    break
                }
            }
            "__END__" -
            "__DATA__" {
                break
            }
            "default" {
                set text ""
                continue
            }
        }
        set pos $end

        if {$structuralMarks} {
            while { [lsearch -exact $asEncountered $text] != -1 } {
                set text "$text "
            }
            lappend asEncountered $text
            set arr inds
        }
        set ${arr}($text) $start
    }

    set already ""
    foreach arr {inds} {
        if {[info exists $arr]} {
            if $structuralMarks {
                set order $asEncountered
            }
            foreach f $order {
                set el [set ${arr}($f)]
                set ff $f
                while { [lsearch -exact $already $ff] != -1 } {
                    set ff "$ff "
                }
                lappend already $ff
                if {$hasMarkers && ![string match "•*" $ff] } {
                    set ff " $ff"
                }
                setNamedMark $ff $el $el $el
            }
        }
    }
}


# ◊◊◊◊ electric behaviour ◊◊◊◊ #
proc Perl::electricLeft {} {
    set prevChar [lookAt [pos::math [getPos] - 1]]
    if {$prevChar == " " || $prevChar == "\)"} {
    ::electricLeft
    return
    }
    deleteText [getPos] [selEnd]
    insertText "\{"
}

proc Perl::electricRight {} {
    set prevChar [lookAt [pos::math [getPos] - 1]]
    if {$prevChar == " " || $prevChar == ";" || $prevChar == "\t" || $prevChar == "\}"} {
    ::electricRight
    return
    }
    deleteText [getPos] [selEnd]
    insertText "\}"
    catch {blink [matchIt "\}" [pos::math [getPos] - 2]]}
    return
}

# ◊◊◊◊ Inintialize Perl mode ◊◊◊◊ #
if ![alpha::tryToLoad "Initializing Perl" \
  "perl$PerlmodeVars(perlVersion).tcl" {}\
  perlEngine.tcl {}\
  perlFilters&Misc.tcl {}] {
    alertnote "Error: Not all of the mode files loaded"
}