Tcl Source Code

2011-07-28  Reinhard Max  <[email protected]>

	* unix/tcl.m4 (SC_TCL_IPV6): Fix AC_DEFINE invocation for
	NEED_FAKE_RFC2553.
	* unix/configure:	autoconf-2.59

2011-07-28  Don Porter  <[email protected]>

## build a cross-reference link if appropriate
##
proc cross-reference {ref} {
    global manual remap_link_target
    global ensemble_commands exclude_refs_map exclude_when_followed_by_map
    set manname $manual(name)
    set mantail $manual(tail)
    if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref] || [string match "Ttk_*" $ref]} {
	regexp {^\w+} $ref lref
	##
	## apply a link remapping if available
	##
	if {[info exists remap_link_target($lref)]} {
	    set lref $remap_link_target($lref)
	}

	puts stderr "multiple cross reference to $ref in $manref from $manual(wing-file)/$mantail"
	return $ref
    }
    ##
    ## exceptions, sigh, to the rule
    ##
    if {[info exists exclude_when_followed_by_map($mantail)]} {
	upvar 1 tail tail
	set following_word [lindex [regexp -inline {\S+} $tail] 0]
	foreach {this that} $exclude_when_followed_by_map($mantail) {
	    # only a ref if $this is not followed by $that
	    if {$lref eq $this && [string match $that* $following_word]} {
		return $ref
	    }
	}

	## find where each item lives - EXPENSIVE - and accumulate a list
	##
	unset -nocomplain offsets
	foreach {name pattern} {
	    anchor     {<A }	end-anchor {</A>}
	    quote      {``}	end-quote  {''}
	    bold       {<B>}	end-bold   {</B>}
	    tcl        {Tcl_}
	    tk         {Tk_}
	    ttk	       {Ttk_}


	    Tcl1       {Tcl manual entry}
	    Tcl2       {Tcl overview manual entry}
	    url	       {http://}
	} {
	    set o [string first $pattern $text]
	    if {[set offset($name) $o] >= 0} {
		set invert($o) $name

		switch -exact -- $invert([lindex $offsets 1]) {
		    end-quote {
			append result [string range $text 0 [expr {$offset(quote)-1}]]
			set body [string range $text [expr {$offset(quote)+2}] \
				      [expr {$offset(end-quote)-1}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-quote)+2}] end]
			set tail $text
			append result `` [cross-reference $body] ''
			continue
		    }
		    bold -
		    anchor {
			append result [string range $text \
				      0 [expr {$offset(end-quote)+1}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-quote)+2}] end]
			continue
		    }
		}

		    url - end-bold {
			append result \
			    [string range $text 0 [expr {$offset(bold)-1}]]
			set body [string range $text [expr {$offset(bold)+3}] \
				      [expr {$offset(end-bold)-1}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-bold)+4}] end]
			set tail $text
			regsub {http://[\w/.]+} $body {<A HREF="&">&</A>} body
			append result <B> [cross-reference $body] </B>
			continue
		    }
		    anchor {
			append result \
			    [string range $text 0 [expr {$offset(end-bold)+3}]]
			set text [string range $text[set text ""] \
				      [expr {$offset(end-bold)+4}] end]
			continue
		    }
		    default {
			return [reference-error "Uncaught bold case" $text]
		    }
		}
	    }
	    tk {
		append result [string range $text 0 [expr {$offset(tk)-1}]]
		if {![regexp -indices -start $offset(tk) {Tk_\w+} $text range]} {
		    return [reference-error "Tk regexp failed" $text]
		}
		set body [string range $text {*}$range]
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]
		set tail $text
		append result [cross-reference $body]
		continue
	    }
	    ttk {
		append result [string range $text 0 [expr {$offset(ttk)-1}]]
		if {![regexp -indices -start $offset(ttk) {Ttk_\w+} $text range]} {
		    return [reference-error "Ttk regexp failed" $text]
		}
		set body [string range $text {*}$range]
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]
		set tail $text
		append result [cross-reference $body]
		continue
	    }
	    tcl {
		append result [string range $text 0 [expr {$offset(tcl)-1}]]
		if {![regexp -indices -start $offset(tcl) {Tcl_\w+} $text range]} {
		    return [reference-error "Tcl regexp failed" $text]
		}
		set body [string range $text {*}$range]
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]
		set tail $text
		append result [cross-reference $body]
		continue
	    }
	    Tcl1 -
	    Tcl2 {
		set off [lindex $offsets 0]
		append result [string range $text 0 [expr {$off-1}]]
		set text [string range $text[set text ""] [expr {$off+3}] end]
		set tail $text
		append result [cross-reference Tcl]
		continue
	    }
	    url {
		set off [lindex $offsets 0]
		append result [string range $text 0 [expr {$off-1}]]
		regexp -indices -start $off {http://[\w/.]+} $text range
		set url [string range $text {*}$range]
		append result "<A HREF=\"$url\">" $url "</A>"
		set text [string range $text[set text ""] \
			      [expr {[lindex $range 1]+1}] end]
		continue
	    }
	    end-anchor -
	    end-bold -
	    end-quote {
		return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
	    }
	}
    }
}
##
## process formatting directives

set excluded_pages {case menubar pack-old}
set forced_index_pages {GetDash}
set process_first_patterns {*/ttk_widget.n */options.n}
set ensemble_commands {
    after array binary chan clock dde dict encoding file history info interp
    memory namespace package registry self string trace update zlib
    clipboard console font grab grid image option pack place selection tk
    tkwait ttk::style winfo wm
}
array set remap_link_target {
    stdin  Tcl_GetStdChannel
    stdout Tcl_GetStdChannel
    stderr Tcl_GetStdChannel
    style  ttk::style
    {style map} ttk::style

    Tcl_ObjType Tcl_RegisterObjType
    Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel
    errorinfo 	env
    errorcode 	env
    tcl_pkgpath env
    Tcl_Command Tcl_CreateObjCommand
    Tcl_CmdProc Tcl_CreateObjCommand


    Tcl_Channel Tcl_OpenFileChannel
    Tcl_WideInt Tcl_NewIntObj
    Tcl_ChannelType Tcl_CreateChannel
    Tcl_DString Tcl_DStringInit
    Tcl_Namespace Tcl_AppendExportList
    Tcl_Object  Tcl_NewObjectInstance
    Tcl_Class   Tcl_GetObjectAsClass