diff options
Diffstat (limited to 'pd/tcl/pd.tcl')
| -rw-r--r-- | pd/tcl/pd.tcl | 315 |
1 files changed, 315 insertions, 0 deletions
diff --git a/pd/tcl/pd.tcl b/pd/tcl/pd.tcl new file mode 100644 index 00000000..0418dcd8 --- /dev/null +++ b/pd/tcl/pd.tcl @@ -0,0 +1,315 @@ +#!/bin/sh +# This line continues for Tcl, but is a single line for 'sh' \ + exec wish "$0" -- ${1+"$@"} +# For information on usage and redistribution, and for a DISCLAIMER OF ALL +# WARRANTIES, see the file, "LICENSE.txt," in this distribution. +# Copyright (c) 1997-2009 Miller Puckette. + +# puts -------------------------------pd.tcl----------------------------------- + +package require Tcl 8.3 +package require Tk +if {[tk windowingsystem] ne "win32"} {package require msgcat} + +# Pd's packages are stored in the same directory as the main script (pd.tcl) +set auto_path [linsert $auto_path 0 [file dirname [info script]]] +package require pd_connect +package require pd_menus +package require pd_bindings +package require dialog_font +package require dialog_gatom +package require dialog_iemgui +package require pdtk_array +package require pdtk_canvas +package require pdtk_text +# TODO eliminate this kludge: +package require wheredoesthisgo + +# import into the global namespace for backwards compatibility +namespace import ::pd_connect::pdsend +namespace import ::dialog_font::pdtk_canvas_dofont +namespace import ::dialog_gatom::pdtk_gatom_dialog +namespace import ::dialog_iemgui::pdtk_iemgui_dialog + +#------------------------------------------------------------------------------# +# global variables + +# for testing which platform we are running on ("aqua", "win32", or "x11") +set windowingsystem "" + +# canvas font, received from pd in pdtk_pd_startup, set in s_main.c +set font_family "Courier" +set font_weight "bold" +# sizes of chars for each of the Pd fixed font sizes: +# fontsize width(pixels) height(pixels) +set font_fixed_metrics { + 8 5 10 + 9 6 11 + 10 6 13 + 12 7 15 + 14 8 17 + 16 10 20 + 18 11 22 + 24 14 30 + 30 18 37 + 36 22 45 +} + +# store list of parent windows for Window menu +set menu_windowlist {} + +#------------------------------------------------------------------------------# +# coding style +# +# these are preliminary ideas, we'll change them as we work things out: +# - when possible use "" doublequotes to delimit messages +# - use '$::myvar' instead of 'global myvar' +# - for the sake of clarity, there should not be any inline code, everything +# should be in a proc that is ultimately triggered from main() +# - if a menu_* proc opens a panel, that proc is called menu_*_panel +# - use "eq/ne" for string comparison, NOT "==/!=" +# +## Names for Common Variables +#---------------------------- +# +# variables named after the Tk widgets they represent +# $mytoplevel = 'toplevel' +# $mymenubar = the 'menu' attached to the 'toplevel' +# $mymenu = 'menu' attached to the menubar 'menu' +# $menuitem = 'menu' item +# $mycanvas = 'canvas' +# $canvasitem = 'canvas' item +# +# +## Prefix Names for procs +#---------------------------- +# pdtk pd -> pd-gui API (i.e. called from 'pd') +# pdsend pd-gui -> pd API (sends a message to 'pd' using pdsend) +# canvas manipulates a canvas +# text manipulates a Tk 'text' widget + +# ------------------------------------------------------------------------------ +# init functions + +proc init {} { + # we are not using Tk scaling, so fix it to 1 on all platforms. This + # guarantees that patches will be pixel-exact on every platform + tk scaling 1 + + # TODO Tcl/Tk 8.3 doesn't have [tk windowingsystem] + set ::windowingsystem [tk windowingsystem] + # get the versions for later testing + regexp {([0-9])\.([0-9])\.([0-9]+)} [info patchlevel] \ + wholematch ::tcl_major ::tcl_minor ::tcl_patch + switch -- $::windowingsystem { + "x11" { + # add control to show/hide hidden files in the open panel (load + # the tk_getOpenFile dialog once, otherwise it will not work) + catch {tk_getOpenFile -with-invalid-argument} + set ::tk::dialog::file::showHiddenBtn 1 + set ::tk::dialog::file::showHiddenVar 0 + # set file types that open/save recognize + set ::filetypes { + {{pd files} {.pd} } + {{max patch files} {.pat} } + {{max text files} {.mxt} } + } + } + "aqua" { + # set file types that open/save recognize + set ::filetypes { + {{Pd Files} {.pd} } + {{Max Patch Files (.pat)} {.pat} } + {{Max Text Files (.mxt)} {.mxt} } + } + } + "win32" { + font create menufont -family Tahoma -size -11 + # set file types that open/save recognize + set ::filetypes { + {{Pd Files} {.pd} } + {{Max Patch Files} {.pat} } + {{Max Text Files} {.mxt} } + } + } + } +} + +# official GNU gettext msgcat shortcut +if {[tk windowingsystem] ne "win32"} { + proc _ {s} {return [::msgcat::mc $s]} +} else { + proc _ {s} {return $s} +} + +proc load_locale {} { + ::msgcat::mcload [file join [file dirname [info script]] locale] + + # for Windows + #set locale "en" ;# Use whatever is right for your app + #if {[catch {package require registry}]} { + # tk_messageBox -icon error -message "Could not get locale from registry" + #} else { + # set locale [string tolower \ + # [string range \ + # [registry get {HKEY_CURRENT_USER\Control Panel\International} sLanguage] 0 1] ] + #} + + ##--moo: force default system and stdio encoding to UTF-8 + encoding system utf-8 + fconfigure stderr -encoding utf-8 + fconfigure stdout -encoding utf-8 + ##--/moo +} + +# ------------------------------------------------------------------------------ +# font handling + +# this proc gets the internal font name associated with each size +proc get_font_for_size {size} { + return "pd_font_${size}" +} + +proc set_base_font {family weight} { + if {[lsearch -exact [font families] $family] > -1} { + set ::font_family $family + } else { + puts stderr "Error: Font family \"$family\" not found, using default: $::font_family" + } + if {[lsearch -exact {bold normal} $weight] > -1} { + set ::font_weight $weight + set using_defaults 0 + } else { + puts stderr "Error: Font weight \"$weight\" not found, using default: $::font_weight" + } + puts stderr "Using FONT $::font_family $::font_weight" +} + +# creates all the base fonts (i.e. pd_font_8 thru pd_font_36) so that they fit +# into the metrics given by $::font_fixed_metrics for any given font/weight +proc fit_font_into_metrics {} { +# TODO the fonts picked seem too small, probably on fixed width + foreach {size width height} $::font_fixed_metrics { + set myfont [get_font_for_size $size] + font create $myfont -family $::font_family -weight $::font_weight \ + -size [expr {-$height}] + set height2 $height + set giveup 0 + while {[font measure $myfont M] > $width} { + incr height2 -1 + font configure $myfont -size [expr {-$height2}] + if {$height2 * 2 <= $height} { + set giveup 1 + puts "error: [lindex [info level 0] 0] failed to find a font of size $size fitting into a $width x $height cell! this system sucks" + break + } + } + if {$giveup} {continue} + } +} + + +# ------------------------------------------------------------------------------ +# procs called directly by pd + +proc pdtk_pd_startup {version {args ""}} { + # pdtk_post "pdtk_pd_startup $version $args" + # pdtk_post "\tversion: $version" + # pdtk_post "\targs: $args" + set oldtclversion 0 + pdsend "pd init [enquote_path [pwd]] $oldtclversion $::font_fixed_metrics" + set_base_font [lindex $args 2] [lindex $args 3] + fit_font_into_metrics + # TODO what else is needed from the original? +} + +##### routine to ask user if OK and, if so, send a message on to Pd ###### +proc pdtk_check {ignoredarg message reply_to_pd default} { + # TODO this should use -parent and -title, but the hard part is figuring + # out how to get the values for those without changing g_editor.c + set answer [tk_messageBox -type yesno -icon question \ + -default $default -message $message] + if {$answer eq "yes"} { + pdsend $reply_to_pd + } +} + +proc pdtk_fixwindowmenu {} { + #TODO figure out how to do this cleanly + puts stderr "Running pdtk_fixwindowmenu" +} + +# ------------------------------------------------------------------------------ +# procs called directly by pd + +proc check_for_running_instances {} { +## http://tcl.tk/man/tcl8.4/TkCmd/send.htm +## This script fragment can be used to make an application that only +## runs once on a particular display. +# +#if {[tk appname FoobarApp] ne "FoobarApp"} { +# send -async FoobarApp RemoteStart $argv +# exit +#} +## The command that will be called remotely, which raises +## the application main window and opens the requested files +#proc RemoteStart args { +# raise . +# foreach filename $args { +# OpenFile $filename +# } +#} +} + +proc load_startup {} { + global errorInfo + set pd_guidir "[pwd]/../startup" + # puts stderr "load_startup $pd_guidir" + if { ! [file isdirectory $pd_guidir]} { return } + foreach filename [glob -directory $pd_guidir -nocomplain -types {f} -- *.tcl] { + puts "Loading $filename" + set tclfile [open $filename] + set tclcode [read $tclfile] + close $tclfile + if {[catch {uplevel #0 $tclcode} errorname]} { + puts stderr "------------------------------------------------------" + puts stderr "UNHANDLED ERROR: $errorInfo" + puts stderr "FAILED TO LOAD $filename" + puts stderr "------------------------------------------------------" + } + } +} + +# ------------------------------------------------------------------------------ +# main +proc main {argc argv} { + catch {console show} ;# Not all platforms have the console command + post_tclinfo + pdtk_post "Starting pd.tcl with main($argc $argv)" + check_for_running_instances + if {[tk windowingsystem] ne "win32"} {load_locale} + init + + # TODO check args for -stderr and set pdtk_post accordingly + if { $argc == 1 && [string is int [lindex $argv 0]]} { + # 'pd' started first and launched us, so get the port to connect to + ::pd_connect::to_pd [lindex $argv 0] + } else { + # the GUI is starting first, so create socket and exec 'pd' + set portnumber [::pd_connect::create_socket] + set pd_exec [file join [file dirname [info script]] ../bin/pd] + exec -- $pd_exec -guiport $portnumber & + #TODO add vwait so that pd-gui will exit if pd never shows up + } + ::pd_bindings::class_bindings + create_pdwindow + load_startup +} + +main $::argc $::argv + + + + + + |