1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156 |
- ###########################################################
- # Name: win.tcl
- # Author: Daniele Bonini (posta@elettronica.lol)
- # Date: 26/11/2023
- # Desc: Win namespace of RadXIDE.
- #
- # Win namespace scaffolding and most of the code
- # here presented and distributed contains excerpts
- # from [alited](https://github.com/aplsimple/alited
- # by Alex Plotnikov and contributors to the project.
- # The original code of these excerpts could be
- # borrowed from other sources which the author
- # and the contributors to this RadXIDE have no
- # knowledge about.
- #
- # License: MIT. Copyrights 5 Mode (Last implementation and adaptations.)
- # Copyright (c) 2021-2023 Alex Plotnikov https://aplsimple.github.io (original scaffolding and excerpts.)
- #
- ###########################################################
- namespace eval win {
- array set _PU_opts [list -NONE =NONE=]
- set _PU_opts(_MODALWIN_) [list]
- variable _AP_Properties; array set _AP_Properties [list]
- variable _AP_ICO { none folder OpenFile SaveFile saveall print font color \
- date help home misc terminal run tools file find replace other view \
- categories actions config pin cut copy paste plus minus add delete \
- change diagram box trash double more undo redo up down previous next \
- previous2 next2 upload download tag tagoff tree lock light restricted \
- attach share mail www map umbrella gulls sound heart clock people info \
- err warn ques retry yes no ok cancel exit }
- variable _AP_IMG; array set _AP_IMG [list]
- variable _AP_VARS; array set _AP_VARS [list]
- variable UFF "\uFFFF"
- variable querydlg {}
- variable CheckNomore
- array set msgarray [list]
- set Dlgpath ""
- set Dlgname ""
- set dlg(PATH) ""
- set dlg(NAME) ""
- set dlg(FIELDS) {}
- set Indexdlg 0
- set _savedvv [list]
- set MODALWINDOW {}
- set Foundstr {}
- # array set data [list]
- # set data(en1) {}
- # set data(docheck) yes
- set Foundstr {} ;# current found string
- set HLstring {} ;# current selected string
- set Widgetopts [list]
-
- set _Defaults [dict create \
- bts {{} {}} \
- but {{} {}} \
- buT {{} {-width -20 -pady 1}} \
- btT {{} {-width -20 -pady 1 -relief flat -overrelief raised -highlightthickness 0 -takefocus 0}} \
- can {{} {}} \
- chb {{} {}} \
- swi {{} {}} \
- chB {{} {-relief sunken -padx 6 -pady 2}} \
- cbx {{} {}} \
- fco {{} {}} \
- ent {{} {}} \
- enT {{} {-insertwidth $::apave::cursorwidth -insertofftime 250 -insertontime 750}} \
- fil {{} {}} \
- fis {{} {}} \
- dir {{} {}} \
- fon {{} {}} \
- clr {{} {}} \
- dat {{} {}} \
- fiL {{} {}} \
- fiS {{} {}} \
- diR {{} {}} \
- foN {{} {}} \
- clR {{} {}} \
- daT {{} {}} \
- sta {{} {}} \
- too {{} {}} \
- fra {{} {}} \
- ftx {{} {}} \
- frA {{} {}} \
- gut {{} {-width 0 -highlightthickness 1}} \
- lab {{-sticky w} {}} \
- laB {{-sticky w} {}} \
- lfr {{} {}} \
- lfR {{} {-relief groove}} \
- lbx {{} {-activestyle none -exportselection 0 -selectmode browse}} \
- flb {{} {}} \
- meb {{} {}} \
- meB {{} {}} \
- nbk {{} {}} \
- opc {{} {}} \
- pan {{} {}} \
- pro {{} {}} \
- rad {{} {}} \
- raD {{} {-padx 6 -pady 2}} \
- sca {{} {-orient horizontal -takefocus 0}} \
- scA {{} {-orient horizontal -takefocus 0}} \
- sbh {{-sticky ew} {-orient horizontal -takefocus 0}} \
- sbH {{-sticky ew} {-orient horizontal -takefocus 0}} \
- sbv {{-sticky ns} {-orient vertical -takefocus 0}} \
- sbV {{-sticky ns} {-orient vertical -takefocus 0}} \
- scf {{} {}} \
- seh {{-sticky ew} {-orient horizontal -takefocus 0}} \
- sev {{-sticky ns} {-orient vertical -takefocus 0}} \
- siz {{} {}} \
- spx {{} {}} \
- spX {{} {}} \
- tbl {{} {-selectborderwidth 1 -highlightthickness 2 \
- -labelcommand tablelist::sortByColumn -stretch all \
- -showseparators 1}} \
- tex {{} {-undo 1 -maxundo 0 -highlightthickness 2 -insertofftime 250 -insertontime 750 -insertwidth $::apave::cursorwidth -wrap word -selborderwidth 1 -exportselection 0}} \
- tre {{} {-selectmode browse}} \
- h_ {{-sticky ew -csz 3 -padx 3} {}} \
- v_ {{-sticky ns -rsz 3 -pady 3} {}}]
-
-
- set TexM {}
- # __________________________ AddButtonIcon _________________________ #
- proc AddButtonIcon {w attrsName} {
- # Gets the button's icon based on its text and name (e.g. butOK) and
- # appends it to the attributes of button.
- # w - button's name
- # attrsName - name of variable containing attributes of the button
- upvar 1 $attrsName attrs
- set com [getOption -com {*}$attrs]
- if {[string is integer -strict $com]} {
- extractOptions attrs -com {}
- append attrs " -com {::radxide::win::res {} $com}" ;# returned integer result
- }
- if {[getOption -image {*}$attrs] ne {}} return
- set txt [getOption -t {*}$attrs]
- if {$txt eq {}} { set txt [getOption -text {*}$attrs] }
- set im {}
- set icolist [list {exit abort} {exit close} \
- {SaveFile save} {OpenFile open}]
- # ok, yes, cancel, apply buttons should be at the end of list
- # as their texts can be renamed (e.g. "Help" in e_menu's "About")
- lappend icolist {*}[iconImage] {yes apply}
- foreach icon $icolist {
- lassign $icon ic1 ic2
- # text of button is of highest priority at defining its icon
- if {[string match -nocase $ic1 $txt] || \
- [string match -nocase b*t$ic1 $w] || ($ic2 ne {} && ( \
- [string match -nocase b*t$ic2 $w] || [string match -nocase $ic2 $txt]))} {
- if {[string match -nocase btT* $w]} {
- set cmpd none
- } else {
- set cmpd left
- }
- append attrs " [iconA $ic1 small $cmpd]"
- break
- }
- }
- return
- }
- # __________________ AddPopupAttr ________________#
- proc AddPopupAttr {w attrsName atRO isRO args} {
- # Adds the attribute to call a popup menu for an editable widget.
- # w - widget's name
- # attrsName - variable name for attributes of widget
- # atRO - "readonly" attribute (internally used)
- # isRO - flag of readonly widget
- # args - widget states to be checked
- upvar 1 $attrsName attrs
- lassign $args state state2
- if {$state2 ne {}} {
- if {[getOption -state {*}$attrs] eq $state2} return
- set isRO [expr {$isRO || [getOption -state {*}$attrs] eq $state}]
- }
- if {$isRO} {append atRO RO}
- append attrs " $atRO $w"
- return
- }
- # __________________________ AppendButtons _________________________ #
- proc AppendButtons {widlistName buttons neighbor pos defb timeout win modal} {
- # Adds buttons to the widget list from a position of neighbor widget.
- # widlistName - variable name for widget list
- # buttons - buttons to add
- # neighbor - neighbor widget
- # pos - position of neighbor widget
- # defb - default button
- # timeout - timeout (to count down seconds and invoke a button)
- # win - dialogue's path
- # modal - yes if the window is modal
- # Returns list of "Help" button's name and command.
- upvar $widlistName widlist
- namespace upvar ::radxide dan dan
- variable Dlgpath
-
- set Defb1 [set Defb2 [set bhlist {}]]
- foreach {but txt res} $buttons {
- #set com "res $Dlgpath"
- #set com "::radxide::win::res $Dlgpath"
- #if {[info commands $res] eq {}} {
- # set com "$com $res"
- #} else {
- # if {$res eq {destroy}} {
- # # for compatibility with old modal windows
- # if {$modal} {set res "$com 0"} {set res "destroy $win"}
- # }
- # set com $res ;# "res" is set as a command
- #}
- set com $res
- if {$but eq {butHELP}} {
- # Help button contains the command in "res"
- set com [string map "%w $win" $res]
- set bhlist [list $but $com]
- } elseif {$Defb1 eq {}} {
- set Defb1 $but
- } elseif {$Defb2 eq {}} {
- set Defb2 $but
- }
- if {[set _ [string first "::" $txt]]>-1} {
- set tt " -tip {[string range $txt $_+2 end]}"
- set txt [string range $txt 0 $_-1]
- } else {
- set tt {}
- }
- if {$timeout ne {} && ($defb eq $but || $defb eq {})} {
- set tmo "-timeout {$timeout}"
- } else {
- set tmo {}
- }
- if {$but eq {butHELP}} {
- set neighbor [lindex $widlist end 1]
- set widlist [lreplace $widlist end end]
- lappend widlist [list $but $neighbor T 1 1 {-st w} \
- "-t \"$txt\" -com \"$com\"$tt $tmo -tip F1"]
- set h h_Help
- lappend widlist [list $h $but L 1 94 {-st we}]
- set neighbor $h
- } else {
- lappend widlist [list $but $neighbor $pos 1 1 {-st we} \
- "-t \"$txt\" -com \"$com\"$tt $tmo"]
- set neighbor $but
- }
- set pos L
- }
- lassign [LowercaseWidgetName $Dlgpath.fra.$Defb1] Defb1
- lassign [LowercaseWidgetName $Dlgpath.fra.$Defb2] Defb2
- return $bhlist
- }
- # __________________________ appendDialogField _________________________ #
-
-
- proc addDialogField {fldname oldval newval} {
-
- variable dlg
-
- set newlist [list $fldname $oldval $newval]
-
- set dlg(FIELDS) [linsert $dlg(FIELDS) end $newlist]
- }
- # __________________________ basicFontSize _________________________ #
- proc basicFontSize {{fs 0} {ds 0}} {
- # Gets/Sets a basic size of font used in apave
- # fs - font size
- # ds - incr/decr of size
- # If 'fs' is omitted or ==0, this method gets it.
- # If 'fs' >0, this method sets it.
- namespace upvar ::radxide dan dan
- #if {$fs} {
- # set ::radxide::_CS_(fs) [expr {$fs + $ds}]
- # my create_Fonts
- # return $::radxide::_CS_(fs)
- #} else {
- # return [expr {$::radxide::_CS_(fs) + $ds}]
- #}
-
- return $dan(CHARSIZE)
-
- }
- # __________________________ basicDefFont _________________________ #
- proc basicDefFont {{deffont ""}} {
- # Gets/Sets a basic default font.
- # deffont - font
- # If 'deffont' is omitted or =="", this method gets it.
- # If 'deffont' is set, this method sets it.
- namespace upvar ::radxide dan dan
- #if {$deffont ne ""} {
- # return [set ::apave::_CS_(defFont) $deffont]
- #} else {
- # return $::apave::_CS_(defFont)
- #}
-
- return $dan(CHARFAMILY)
- }
- # __________________________ basicTextFont _________________________ #
- proc basicTextFont {{textfont ""}} {
- # Gets/Sets a basic font used in editing/viewing text widget.
- # textfont - font
- # If 'textfont' is omitted or =="", this method gets it.
- # If 'textfont' is set, this method sets it.
- namespace upvar ::radxide dan dan
- #if {$textfont ne ""} {
- # return [set ::apave::_CS_(textFont) $textfont]
- #} else {
- # return $::apave::_CS_(textFont)
- #}
-
- return $dan(CHARFAMILY)
- }
-
- # __________________________ checkXY _________________________ #
- proc checkXY {win w h x y} {
- # Checks the coordinates of window (against the screen).
- # w - width of window
- # h - height of window
- # x - window's X coordinate
- # y - window's Y coordinate
- # Returns new coordinates in +X+Y form.
- # check for left/right edge of screen (accounting decors)
- set scrw [expr {[winfo vrootwidth $win] - 12}]
- set scrh [expr {[winfo vrootheight $win] - 36}]
- if {($x + $w) > $scrw } {
- set x [expr {$scrw - $w}]
- }
- if {($y + $h) > $scrh } {
- set y [expr {$scrh - $h}]
- }
- if {![string match -* $x]} {set x +[string trimleft $x +]}
- if {![string match -* $y]} {set y +[string trimleft $y +]}
- return ${x}x${y}
- }
- # _________________________ centeredXY ________________________ #
- proc centeredXY {win rw rh rx ry w h} {
- # Gets the coordinates of centered window (against its parent).
- # rw - parent's width
- # rh - parent's height
- # rx - parent's X coordinate
- # ry - parent's Y coordinate
- # w - width of window to be centered
- # h - height of window to be centered
- # Returns centered coordinates in +X+Y form.
- set x [expr {max(0, $rx + ($rw - $w) / 2)}]
- set y [expr {max(0,$ry + ($rh - $h) / 2)}]
- return [checkXY $win $w $h $x $y]
- }
- # ________________________ centerWin _________________________ #
- proc centerWin {win wwidth wheight} {
-
- namespace upvar ::radxide dan dan
-
- set screen_width [winfo screenwidth $win]
- set screen_height [winfo screenheight $win]
- #tk_messageBox -title $dan(TITLE) -icon error -message $screen_width
- set half_screen_w [expr {0}]
- if {[expr {$screen_width/$screen_height} > 2]} {
- set half_screen_w [expr {$screen_width/2}]
- set wrong_geo [centeredXY $win $half_screen_w $screen_height 0 0 $wwidth $wheight]
- } else {
- set wrong_geo [centeredXY $win $screen_width $screen_height 0 0 $wwidth $wheight]
- }
- #set geo [string map {x ""} $geo]
- #wm geometry $dan(WIN) "=$dan(WIDTH)x$dan(HEIGHT)$geo"
- wm geometry $win =${wwidth}x${wheight}
- # Lets do it modal:
- set offsetx [winfo x $win]
- set offsety [winfo y $win]
- set disinfox [winfo pointerx [winfo parent $win]]
- #tk_messageBox -title $dan(TITLE) -icon error -message $disinfox
- #tk_messageBox -title $dan(TITLE) -icon error -message $half_screen_w
- set display [expr {1}]
- if { $disinfox>$half_screen_w } {
- set display [expr {2}]
- }
- #tk_messageBox -title $dan(TITLE) -icon error -message $display
- set newx [expr {($half_screen_w-$wwidth)/2}]
- if {$display>1} {
- set newx [expr {$half_screen_w+(($half_screen_w-$wwidth)/2)}]
- }
- #tk_messageBox -title $dan(TITLE) -icon error -message newx=$newx
- set newy [expr {70}]
- wm geometry $win +$newx+$newy
- }
- #_______________________ CheckData _______________________ #
- # proc CheckData {op} {
- # # Checks if the find/replace data are valid.
- # # op - if "repl", checks for "Replace" operation
- # # Return "yes", if the input data are valid.
- #
- # namespace upvar :radxide dan dan
- #
- # variable data
- #
- # # this means "no checks when used outside of the dialogue":
- # if {!$data(docheck)} {return yes}
- #
- # set ret yes
- # if {[set data(en1)] eq {}} { set ret no }
- # if {[set data(en1)] > $dan(MAXFINDLENGTH)} { set ret no }
- #
- # if {$ret eq no} {
- # # if find/replace field is empty, let the bell tolls for him
- # bell
- # return no
- # }
- # return yes
- # }
- # ________________________ CleanUps _________________________ #
- proc CleanUps {{wr ""}} {
- }
- proc danInitDialogs {} {
- namespace upvar ::radxide dan dan
- variable Dlgpath
- variable Dlgname
- variable dlg
- variable Indexdlg
-
- set Dlgpath ""
- set Dlgname ""
- set dlg(PATH) ""
- set dlg(NAME) ""
- set dlg(FIELDS) {}
- set Indexdlg 0
-
- }
- # ________________________ defaultATTRS _________________________ #
- proc defaultATTRS {{type ""} {opts ""} {atrs ""} {widget ""}} {
- # Sets, gets or registers default options and attributes for widget type.
- # type - widget type
- # opts - new default grid/pack options
- # atrs - new default attributes
- # widget - Tcl/Tk command for the new registered widget type
- # The *type* should be a three letter unique string.
- # If the *type* is absent in the registered types and *opts* and/or *atrs*
- # is not set to "", defaultATTRS registers the new *type* with its grid/pack
- # options and attributes. At that *widget* is a command for the new widget
- # type. For example, to register "toolbutton" widget:
- # my defaultATTRS tbt {} {-style Toolbutton -compound top} ttk::button
- # Options and attributes may contain data (variables and commands)
- # to be processed by [subst].
- # Returns:
- # - if not set *type*: a full list of options and attributes of all types
- # - if set *type* only: a list of options, attributes and *widget*
- # - else: a list of updated options, attributes and *widget*
- variable _Defaults
- if {$type eq {}} {return $_Defaults}
- set optatr "$opts$atrs"
- if {[catch {set def1 [dict get $_Defaults $type]}]} {
- if {$optatr eq {}} {
- set err "[self method]: \"$type\" widget type not registered."
- puts -nonewline stderr $err
- return -code error $err
- }
- set def1 [list $opts $atrs $widget]
- }
- if {$optatr eq {}} {return [subst $def1]}
- lassign $def1 defopts defatrs widget
- if {[catch {set defopts [dict replace $defopts {*}$opts]}]} {
- set defopts [string trim "$defopts $opts"]
- }
- if {[catch {set defatrs [dict replace $defatrs {*}$atrs]}]} {
- set defatrs [string trim "$defatrs $atrs"]
- }
- set newval [list $defopts $defatrs $widget]
- dict set _Defaults $type $newval
- return $newval
- }
- # ________________________ defaultAttrs _________________________ #
- proc defaultAttrs {{type ""} {opts ""} {atrs ""} {widget ""}} {
- # Sets, gets or registers default options and attributes for widget type.
- # type - widget type
- # opts - new default grid/pack options
- # atrs - new default attributes
- # widget - Tcl/Tk command for the new registered widget type
- # See also: APaveBase::defaultATTRS
- return [defaultATTRS $type $opts $atrs $widget]
- }
- # ________________________ dlgPath _________________________ #
- proc dlgPath {} {
- # Gets a current dialogue's path.
- # In fact, it does the same as [my dlgPath], but it can be
- # called outside of apave dialogue object (useful sometimes).
-
- namespace upvar ::radxide dan dan
-
- #variable Dlgpath
- # xxx
- variable Dlgname
-
- variable Indexdlg
-
- set Winpath $dan(WIN)
-
- # xxx
- #set wdia $Winpath.dia
- set wdia $Winpath.dia$Dlgname$Indexdlg
- return [set dlg(PATH) [set Dlgpath $wdia]]
- }
- # ________________________ DiaWidgetNameter _________________________ #
- proc DiaWidgetName {w} {
- # Gets a widget name of apave dialogue.
- # w - name of widget
- # The name of widget may be partial. In this case it's prepended
- # the current dialogue's frame path.
- # Useful in "input" dialogue when -method option is present
- # or widget names are uppercased.
- # See also: MakeWidgetName, input
- if {[string index $w 0] eq {.}} {return $w}
- return $Dlgpath.fra.$w
- }
- # ________________________ displayTaggedText _________________________ #
- proc displayTaggedText {w contsName {tags ""}} {
- # Sets the text widget's contents using tags (ornamental details).
- # w - text widget's name
- # contsName - variable name for contents to be set in the widget
- # tags - list of tags to be applied to the text
- # The lines in *text contents* are divided by \n and can include
- # *tags* like in a html layout, e.g. <red>RED ARMY</red>.
- # The *tags* is a list of "name/value" pairs. 1st is a tag's name, 2nd
- # is a tag's value.
- # The tag's name is "pure" one (without <>) so e.g.for <b>..</b> the tag
- # list contains "b".
- # The tag's value is a string of text attributes (-font etc.).
- # If the tag's name is FG, FG2, BG or BG2, then it is really a link color.
- }
- # ________________________ displayText _________________________ #
- proc displayText {w conts {pos 1.0}} {
- # Sets the text widget's contents.
- # w - text widget's name
- # conts - contents to be set in the widget
- if {[set state [$w cget -state]] ne {normal}} {
- $w configure -state normal
- }
- $w replace 1.0 end $conts
- $w edit reset; $w edit modified no
- if {$state eq {normal}} {
- ::tk::TextSetCursor $w $pos
- } else {
- $w configure -state $state
- }
- return
- }
- # __________________________ editDialogField _________________________ #
-
-
- proc editDialogField {index fldname oldval newval} {
-
- namespace upvar ::radxide dan dan
-
- variable dlg
-
- set newlist {$fldname $oldval $newval}
-
- lset dlg(FIELDS) $index $newlist
-
- }
- # ________________________ ExpandOptions _________________________ #
- proc ExpandOptions {options} {
- # Expands shortened options.
- set options [string map {
- { -st } { -sticky }
- { -com } { -command }
- { -t } { -text }
- { -w } { -width }
- { -h } { -height }
- { -var } { -variable }
- { -tvar } { -textvariable }
- { -lvar } { -listvariable }
- { -ro } { -readonly }
- } " $options"]
- return $options
- }
- # ________________________ error _________________________ #
- proc error {{fileName ""}} {
- # Gets the error's message at reading/writing.
- # fileName - if set, return a full error messageat opening file
- variable _PU_opts
- if {$fileName eq ""} {
- return $_PU_opts(_ERROR_)
- }
- return "Error of access to\n\"$fileName\"\n\n$_PU_opts(_ERROR_)"
- }
- # ________________________ extractOption _________________________ #
- proc extractOptions {optsVar args} {
- # Gets options' values and removes the options from the input list.
- # optsVar - variable name for the list of options and values
- # args - list of "option / default value" pairs
- # Returns a list of options' values, according to args.
- # See also: parseOptions
- upvar 1 $optsVar opts
- set retlist [parseOptions $opts {*}$args]
- foreach {o v} $args {
- set opts [removeOptions $opts $o]
- }
- return $retlist
- }
- # ________________________ FCfieldAttrs _________________________ #
- proc FCfieldAttrs {wnamefull attrs varopt} {
- # Fills the non-standard attributes of file content widget.
- # wnamefull - a widget name
- # attrs - a list of all attributes
- # varopt - a variable option
- # The *varopt* refers to a variable part such as tvar, lvar:
- # * -inpval option means an initial value of the field
- # * -retpos option has p1:p2 format (e.g. 0:10) to cut a substring from a returned value
- # Returns *attrs* without -inpval and -retpos options.
- # xxx
- variable Widgetopts
- lassign [parseOptions $attrs $varopt {} -retpos {} -inpval {}] \
- vn rp iv
- if {[string first {-state disabled} $attrs]<0 && $vn ne {}} {
- set all {}
- if {$varopt eq {-lvar}} {
- lassign [extractOptions attrs -values {} -ALL 0] iv a
- if {[string is boolean -strict $a] && $a} {set all ALL}
- lappend Widgetopts "-lbxname$all $wnamefull $vn"
- }
- if {$rp ne {}} {
- if {$all ne {}} {set rp 0:end}
- lappend Widgetopts "-retpos $wnamefull $vn $rp"
- }
- }
- if {$iv ne {}} { set $vn $iv }
- return [removeOptions $attrs -retpos -inpval]
- }
- # ________________________ FCfieldValues _________________________ #
- proc FCfieldValues {wnamefull attrs} {
- # Fills the file content widget's values.
- # wnamefull - name (path) of fco widget
- # attrs - attributes of the widget
- ; proc readFCO {fname} {
- # Reads a file's content.
- # Returns a list of (non-empty) lines of the file.
- if {$fname eq {}} {
- set retval {{}}
- } else {
- set retval {}
- foreach ln [split [readTextFile $fname {} 1] \n] {
- # probably, it's bad idea to have braces in the file of contents
- set ln [string map [list \\ \\\\ \{ \\\{ \} \\\}] $ln]
- if {$ln ne {}} {lappend retval $ln}
- }
- }
- return $retval
- }
- ; proc contFCO {fline opts edge args} {
- # Given a file's line and options,
- # cuts a substring from the line.
-
- # xxx
- variable Widgetopts
-
- lassign [parseOptionsFile 1 $opts {*}$args] opts
- lassign $opts - - - div1 - div2 - pos - len - RE - ret
- set ldv1 [string length $div1]
- set ldv2 [string length $div2]
- set i1 [expr {[string first $div1 $fline]+$ldv1}]
- set i2 [expr {[string first $div2 $fline]-1}]
- set filterfile yes
- if {$ldv1 && $ldv2} {
- if {$i1<0 || $i2<0} {return $edge}
- set retval [string range $fline $i1 $i2]
- } elseif {$ldv1} {
- if {$i1<0} {return $edge}
- set retval [string range $fline $i1 end]
- } elseif {$ldv2} {
- if {$i2<0} {return $edge}
- set retval [string range $fline 0 $i2]
- } elseif {$pos ne {} && $len ne {}} {
- set retval [string range $fline $pos $pos+[incr len -1]]
- } elseif {$pos ne {}} {
- set retval [string range $fline $pos end]
- } elseif {$len ne {}} {
- set retval [string range $fline 0 $len-1]
- } elseif {$RE ne {}} {
- set retval [regexp -inline $RE $fline]
- if {[llength $retval]>1} {
- foreach r [lrange $retval 1 end] {append retval_tmp $r}
- set retval $retval_tmp
- } else {
- set retval [lindex $retval 0]
- }
- } else {
- set retval $fline
- set filterfile no
- }
- if {$retval eq {} && $filterfile} {return $edge}
- set retval [string map [list "\}" "\\\}" "\{" "\\\{"] $retval]
- return [list $retval $ret]
- }
- set edge $Edge
- set ldv1 [string length $edge]
- set filecontents {}
- set optionlists {}
- set tplvalues {}
- set retpos {}
- set values [getOption -values {*}$attrs]
- if {[string first $edge $values]<0} { ;# if 1 file, edge
- set values "$edge$values$edge" ;# may be omitted
- }
- # get: files' contents, files' options, template line
- set lopts {-list {} -div1 {} -div2 {} -pos {} -len {} -RE {} -ret 0}
- while {1} {
- set i1 [string first $edge $values]
- set i2 [string first $edge $values $i1+1]
- if {$i1>=0 && $i2>=0} {
- incr i1 $ldv1
- append tplvalues [string range $values 0 $i1-1]
- set fdata [string range $values $i1 $i2-1]
- lassign [parseOptionsFile 1 $fdata {*}$lopts] fopts fname
- lappend filecontents [readFCO $fname]
- lappend optionlists $fopts
- set values [string range $values $i2+$ldv1 end]
- } else {
- append tplvalues $values
- break
- }
- }
- # fill the combobox lines, using files' contents and options
- if {[set leno [llength $optionlists]]} {
- set newvalues {}
- set ilin 0
- lassign $filecontents firstFCO
- foreach fline $firstFCO { ;# lines of first file for a base
- set line {}
- set tplline $tplvalues
- for {set io 0} {$io<$leno} {incr io} {
- set opts [lindex $optionlists $io]
- if {$ilin==0} { ;# 1st cycle: add items from -list option
- lassign $opts - list1 ;# -list option goes first
- if {[llength $list1]} {
- foreach l1 $list1 {append newvalues "\{$l1\} "}
- lappend Widgetopts "-list $wnamefull [list $list1]"
- }
- }
- set i1 [string first $edge $tplline]
- if {$i1>=0} {
- lassign [contFCO $fline $opts $edge {*}$lopts] retline ret
- if {$ret ne "0" && $retline ne $edge && \
- [string first $edge $line]<0} {
- set p1 [expr {[string length $line]+$i1}]
- if {$io<($leno-1)} {
- set p2 [expr {$p1+[string length $retline]-1}]
- } else {
- set p2 end
- }
- set retpos "-retpos $p1:$p2"
- }
- append line [string range $tplline 0 $i1-1] $retline
- set tplline [string range $tplline $i1+$ldv1 end]
- } else {
- break
- }
- set fline [lindex [lindex $filecontents $io+1] $ilin]
- }
- if {[string first $edge $line]<0} {
- # put only valid lines into the list of values
- append newvalues "\{$line$tplline\} "
- }
- incr ilin
- }
- # replace old 'values' attribute with the new 'values'
- lassign [parseOptionsFile 2 $attrs -values \
- [string trimright $newvalues]] attrs
- }
- return "$attrs $retpos"
- }
- # ________________________ fillGutter _________________________ #
- proc fillGutter {txt {canvas ""} {width ""} {shift ""} fg bg} {
- # Fills a gutter of text with the text's line numbers.
- # txt - path to the text widget
- # canvas - canvas of the gutter
- # width - width of the gutter, in chars
- # shift - addition to the width (to shift from the left side)
- # args - additional arguments for tracing
- # The code is borrowed from open source tedit project.
-
- namespace upvar ::radxide dan dan
-
- $canvas configure -state normal
-
- if {$canvas eq {}} {
- event generate $txt <Configure> ;# repaints the gutter
- return
- }
- set i 1
- set gcont [list]
- set totlines [expr [$txt count -lines 0.0 end]]
- while true {
- if {$i > $totlines} break
- #set dline [$txt dlineinfo $i] ;# xxx
- set dline [$txt get [lindex [split $i .] 0].0 [lindex [split $i .] 0].end]
- #if {[llength $dline] == 0} break
- #set height [lindex $dline 3] ;# xxx
- #set y [expr {[lindex $dline 1]}] ;# xxx
- set linenum [format "%${width}d" [lindex [split $i .] 0]]
- #set i [$txt index "$i +1 lines linestart"] # xxx
- #lappend gcont [list $y $linenum\n]
- lappend gcont [list [lindex [split $i .] 0] [expr {$linenum}]\n]
- incr i
- }
- set newwidth $dan(GUTTERWIDTH);
- $canvas delete 1.0 end
- set y [expr {0}]
- foreach g $gcont {
- lassign $g y linenum
- $canvas insert [expr {$y}].0 $linenum
- }
- $canvas configure -state disabled
-
- return 2
- }
- # ________________________ FieldName _________________________ #
- proc FieldName {name} {
- # Gets a field name.
- return fraM.fra$name.$name
- }
- # ________________________ findInText ___________________________ #
- proc findInText {{donext 0} {txt ""} {varFind ""} {dobell yes}} {
- # Finds a string in text widget.
- # donext - "1" means 'from a current position'
- # txt - path to the text widget
- # varFind - variable
- # dobell - if yes, bells
- # Returns yes, if found (or nothing to find), otherwise returns "no";
- # also, if there was a real search, the search string is added.
- namespace upvar ::radxide dan dan
- variable Foundstr
- if {$txt eq {}} {
- set txt $dan(TEXT)
- set sel $Foundstr
- } elseif {$donext && [set sel [get_HighlightedString]] ne {}} {
- # find a string got with alt+left/right
- } elseif {$varFind eq {}} {
- set sel $Foundstr
- } else {
- set sel [set $varFind]
- }
- if {$donext} {
- set pos [$txt index insert]
- if {{sel} in [$txt tag names $pos]} {
- set pos [$txt index "$pos + 1 chars"]
- }
- set pos [$txt search -- $sel $pos end]
- } else {
- set pos {}
- set_HighlightedString {}
- }
- if {![string length "$pos"]} {
- set pos [$txt search -- $sel 1.0 end]
- }
- if {[string length "$pos"]} {
- ::tk::TextSetCursor $txt $pos
- $txt tag add sel $pos [$txt index "$pos + [string length $sel] chars"]
- #focus $txt
- set res yes
- } else {
- if {$dobell} bell
- set res no
- }
- return [list $res $sel]
- }
- # ________________________ findTextOK _________________________ #
- proc findTextOK {} {
-
- namespace upvar ::radxide dan dan
- variable dlg
- variable data
- variable Foundstr
-
- set wt $dan(TEXT)
-
- #if {$inv>-1} {set data(lastinvoke) $inv}
-
- #set t $Dlgpath.fra.fraM.fraent.ent
- set t [dlgPath].fra.[FieldName [lindex [getDialogField 0] 0]]
- #tk_messageBox -title $dan(TITLE) -icon info -message textbox=$t
- set varname [lindex [getDialogField end] 0]
- #tk_messageBox -title $dan(TITLE) -icon info -message varname=$varname
- set oldsearchtext [lindex [getDialogField end] 1]
- #tk_messageBox -title $dan(TITLE) -icon info -message oldsearchtext=$oldsearchtext
- set newsearchtext [string trim [$t get]]
- #tk_messageBox -title $dan(TITLE) -icon info -message newsearchtext=$newsearchtext
-
- set Foundstr $newsearchtext
-
- findInText 1 $wt
-
- #ShowResults1 [FindAll $wt]
-
- return 1
- }
- # ________________________ findTextCancel _________________________ #
- proc findTextCancel {} {
-
- #catch {[destroy .danwin.diaRenameFile1]}
- catch {[destroy [dlgPath]]}
-
- return 0
- }
- # ________________________ GetAttrs _________________________ #
- proc GetAttrs {options {nam3 ""} {disabled 0} } {
- # Expands attributes' values.
- # options - list of attributes and values
- # nam3 - first three letters (type) of widget's name
- # disabled - flag of "disabled" state
- # Returns expanded attributes.
- set opts [list]
- foreach {opt val} [list {*}$options] {
- switch -exact -- $opt {
- -t - -text {
- ;# these options need translating \\n to \n
- # catch {set val [subst -nocommands -novariables $val]}
- set val [string map [list \\n \n \\t \t] $val]
- set opt -text
- }
- -st {set opt -sticky}
- -com {set opt -command}
- -w {set opt -width}
- -h {set opt -height}
- -var {set opt -variable}
- -tvar {set opt -textvariable}
- -lvar {set opt -listvariable}
- -ro {set opt -readonly}
- }
- lappend opts $opt \{$val\}
- }
- if {$disabled} {
- append opts [NonTtkStyle $nam3 1]
- }
- return $opts
- }
- # ________________________ get_HighlightedString _________________________ #
- proc get_HighlightedString {} {
- # Returns a string got from highlighting by Alt+left/right/q/w.
- variable HLstring
- if {[info exists HLstring]} {
- return $HLstring
- }
- return {}
- }
- # ________________________ GetIntOptions _________________________ #
- proc GetIntOptions {w options row rowspan col colspan} {
- # Gets specific integer options. Then expands other options.
- # w - widget's name
- # options - grid options
- # row, rowspan - row and its span of thw widget
- # col, colspan - column and its span of thw widget
- # The options are set in grid options as "-rw <int>", "-cw <int>" etc.
- # Returns the resulting grid options.
- set opts {}
- foreach {opt val} [list {*}$options] {
- switch -exact -- $opt {
- -rw {SpanConfig $w row $row $rowspan -weight $val}
- -cw {SpanConfig $w column $col $colspan -weight $val}
- -rsz {SpanConfig $w row $row $rowspan -minsize $val}
- -csz {SpanConfig $w column $col $colspan -minsize $val}
- -ro {SpanConfig $w column $col $colspan -readonly $val}
- default {append opts " $opt $val"}
- }
- }
- # Get other grid options
- return [ExpandOptions $opts]
- }
- # ________________________ GetLinkLab _________________________ #
- proc GetLinkLab {m} {
- # Gets a link for label.
- # m - label with possible link (between <link> and </link>)
- # Returns: list of "pure" message and link for label.
- if {[set i1 [string first "<link>" $m]]<0} {
- return [list $m]
- }
- set i2 [string first "</link>" $m]
- set link [string range $m $i1+6 $i2-1]
- set m [string range $m 0 $i1-1][string range $m $i2+7 end]
- return [list $m [list -link $link]]
- }
- # ________________________ getOption _________________________ #
- proc getOption {optname args} {
- # Extracts one option from an option list.
- # optname - option name
- # args - option list
- # Returns an option value or "".
- # Example:
- # set options [list -name some -value "any value" -tip "some tip"]
- # set optvalue [::apave::getOption -tip {*}$options]
- set optvalue [lindex [parseOptions $args $optname ""] 0]
- return $optvalue
- }
- # ________________________ GetOutputValues _________________________ #
- proc GetOutputValues {} {
- # Makes output values for some widgets (lbx, fco).
- # Some i/o widgets need a special method to get their returned values.
- # xxx
- variable Widgetopts
- foreach aop $Widgetopts {
- lassign $aop optnam vn v1 v2
- switch -glob -- $optnam {
- -lbxname* {
- # To get a listbox's value, its methods are used.
- # The widget may not exist when an apave object is used for
- # several dialogs which is a bad style (very very bad).
- if {[winfo exists $vn]} {
- lassign [$vn curselection] s1
- if {$s1 eq {}} {set s1 0}
- set w [string range $vn [string last . $vn]+1 end]
- if {[catch {set v0 [$vn get $s1]}]} {set v0 {}}
- if {$optnam eq {-lbxnameALL}} {
- # when -ALL option is set to 1, listbox returns
- # a list of 3 items - sel index, sel contents and all contents
- set $v1 [list $s1 $v0 [set $v1]]
- } else {
- set $v1 $v0
- }
- }
- }
- -retpos { ;# a range to cut from -tvar/-lvar variable
- lassign [split $v2 :] p1 p2
- set val1 [set $v1]
- # there may be -list option for this widget
- # then if the value is from the list, it's fully returned
- foreach aop2 $Widgetopts {
- lassign $aop2 optnam2 vn2 lst2
- if {$optnam2 eq {-list} && $vn eq $vn2} {
- foreach val2 $lst2 {
- if {$val1 eq $val2} {
- set p1 0
- set p2 end
- break
- }
- }
- break
- }
- }
- set $v1 [string range $val1 $p1 $p2]
- }
- }
- }
- return
- }
- # __________________________ getDialogField _________________________ #
-
-
- proc getDialogField {index} {
- variable dlg
- set ret [lindex $dlg(FIELDS) $index]
- return $ret
-
- }
- #_______________________ getProperty _______________________#
- proc getProperty {name {defvalue ""}} {
- # Gets a property's value as "application-wide".
- # name - name of property
- # defvalue - default value
- # If the property had been set, the method returns its value.
- # Otherwise, the method returns the default value (`$defvalue`).
- variable _AP_Properties
- if {[info exists _AP_Properties($name)]} {
- return $_AP_Properties($name)
- }
- return $defvalue
- }
- # ________________________ getShowOption _________________________ #
- proc getShowOption {name {defval ""}} {
- # Gets a default show option, used in showModal.
- # name - name of option
- # defval - default value
- # See also: showModal
- getProperty [ShowOption $name] $defval
- }
- # ________________________ GetVarsValues _________________________ #
- proc GetVarsValues {lwidgets} {
- # Gets values of entries passed (or set) in -tvar.
- # lwidgets - list of widget items
- set res [set vars [list]]
- foreach wl $lwidgets {
- set ownname [ownWName [lindex $wl 0]]
- set vv [varName $ownname]
- set attrs [lindex $wl 6]
- if {[string match "ra*" $ownname]} {
- # only for widgets with a common variable (e.g. radiobuttons):
- foreach t {-var -tvar} {
- if {[set v [getOption $t {*}$attrs]] ne {}} {
- array set a $attrs
- set vv $v
- }
- }
- }
- if {[info exist $vv] && [lsearch $vars $vv]==-1} {
- lappend res [set $vv]
- lappend vars $vv
- }
- }
- return $res
- }
- # ________________________ GotoLineOK _________________________ #
- proc GotoLineOK {} {
-
- namespace upvar ::radxide dan dan
- variable dlg
-
- set wt $dan(TEXT)
- set lmax [expr {int([$wt index "end -1c"])}]
-
- #set t $Dlgpath.fra.fraM.fraent.ent
- set t [dlgPath].fra.[FieldName [lindex [getDialogField 0] 0]]
- #tk_messageBox -title $dan(TITLE) -icon info -message textbox=$t
- set varname [lindex [getDialogField end] 0]
- #tk_messageBox -title $dan(TITLE) -icon info -message varname=$varname
- set oldlinenumber [lindex [getDialogField end] 1]
- #tk_messageBox -title $dan(TITLE) -icon info -message oldlinenumber=$oldlinenumber
- set newlinenumber [string trim [$t get]]
- #tk_messageBox -title $dan(TITLE) -icon info -message newlinenumber=$newlinenumber
- if {$newlinenumber>$lmax} {
- tk_messageBox -title $dan(TITLE) -icon info -message "Line $newlinenumber doesn't exist $newlinenumber>MAXLINES."
- return 0
- }
- ::tk::TextSetCursor $wt 0.0
- after 200 "tk::TextSetCursor $wt [expr $newlinenumber].0"
-
- catch {[destroy [dlgPath]]}
-
- return 1
- }
- # ________________________ GotoLineCancel _________________________ #
- proc GotoLineCancel {} {
-
- #catch {[destroy .danwin.diaRenameFile1]}
- catch {[destroy [dlgPath]]}
-
- return 0
- }
- # ________________________ iconImage _________________________ #
- proc iconA {icon {iconset small} {cmpd left}} {
- # Gets icon attributes for buttons, menus etc.
- # icon - name of icon
- # iconset - one of small/middle/large
- # cmpd - value of -compound option
- # The *iconset* is "small" for menus (recommended and default).
- return "-image [iconImage $icon $iconset] -compound $cmpd"
- }
- # ________________________ iconifyOption _________________________ #
- proc iconifyOption {args} {
- # Gets/sets "-iconify" option.
- # args - if contains no arguments, gets "-iconify" option; otherwise sets it
- # Option values mean:
- # none - do nothing: no withdraw/deiconify
- # Linux - do withdraw/deiconify for Linux
- # Windows - do withdraw/deiconify for Windows
- # default - do withdraw/deiconify depending on the platform
- # See also: withdraw, deiconify
- if {[llength $args]} {
- set iconify [setShowOption -iconify $args]
- } else {
- set iconify [getShowOption -iconify]
- }
- return $iconify
- }
- # ________________________ iconImage _________________________ #
- proc iconImage {{icon ""} {iconset "small"} {doit no}} {
- # Gets a defined icon's image or list of icons.
- # If *icon* equals to "-init", initializes apave's icon set.
- # icon - icon's name
- # iconset - one of small/middle/large
- # doit - force the initialization
- # Returns the icon's image or, if *icon* is blank, a list of icons
- # available in *apave*.
- variable _AP_IMG
- variable _AP_ICO
-
- return folder
- # if {$icon eq {}} {return $_AP_ICO}
- # ; proc imagename {icon} { # Get a defined icon's image name
- # return _AP_IMG(img$icon)
- # }
- # variable apaveDir
- # if {![array size _AP_IMG] || $doit} {
- # # Make images of icons
- # source [file join $apaveDir apaveimg.tcl]
- # if {$iconset ne "small"} {
- # foreach ic $_AP_ICO { ;# small icons best fit for menus
- # set _AP_IMG($ic-small) [set _AP_IMG($ic)]
- # }
- # if {$iconset eq "middle"} {
- # source [file join $apaveDir apaveimg2.tcl]
- # } else {
- # source [file join $apaveDir apaveimg2.tcl] ;# TODO
- # }
- # }
- # foreach ic $_AP_ICO {
- # if {[catch {image create photo [imagename $ic] -data [set _AP_IMG($ic)]}]} {
- # # some png issues on old Tk
- # image create photo [imagename $ic] -data [set _AP_IMG(none)]
- # } elseif {$iconset ne "small"} {
- # image create photo [imagename $ic-small] -data [set _AP_IMG($ic-small)]
- # }
- # }
- # }
- # if {$icon eq "-init"} {return $_AP_ICO} ;# just to get to icons
- # if {$icon ni $_AP_ICO} {set icon [lindex $_AP_ICO 0]}
- # if {$iconset eq "small" && "_AP_IMG(img$icon-small)" in [image names]} {
- # set icon $icon-small
- # }
- # return [imagename $icon]
- }
- # ________________________ InfoFind _________________________ #
- proc InfoFind {w modal} {
- # Searches data of a window in a list of registered windows.
- # w - root window's path
- # modal - yes, if the window is modal
- # Returns: the window's path or "" if not found.
- # See also: InfoWindow
- variable _PU_opts
- foreach winfo [lrange $_PU_opts(_MODALWIN_) 1 end] { ;# skip 1st window
- incr i
- lassign $winfo w1 var1 modal1
- if {[winfo exists $w1]} {
- if {$w eq $w1 && ($modal && $modal1 || !$modal && !$modal1)} {
- return $w1
- }
- } else {
- catch {set _PU_opts(_MODALWIN_) [lreplace $_PU_opts(_MODALWIN_) $i $i]}
- }
- }
- return {}
- }
- # ________________________ InitFindInText _________________________ #
- proc InitFindInText { {ctrlf 0} {txt {}} } {
- # Initializes the search in the text.
- # ctrlf - "1" means that the method is called by Ctrl+F
- # txt - path to the text widget
- namespace upvar ::radxide dan dan
- variable Foundstr
- if {$txt eq {}} {set txt $dan(TEXT)}
- #if {$ctrlf} { ;# Ctrl+F moves cursor 1 char ahead
- # ::tk::TextSetCursor $txt [$txt index "insert -1 char"]
- #}
- if {[set seltxt [selectedWordText $txt]] ne {}} {
- set Foundstr $seltxt
- }
- return $Foundstr
- }
- # ________________________ initInput _________________________ #
- proc initInput {} {
- # Initializes input and clears variables made in previous session.
- variable _savedvv
- # xxx
- variable Widgetopts
- foreach {vn vv} $_savedvv {
- catch {unset $vn}
- }
- set _savedvv [list]
- set Widgetopts [list]
- return
- }
- proc InfoWindow {{val ""} {w .} {modal no} {var ""} {regist no}} {
- # Registers/unregisters windows. Also sets/gets 'count of open modal windows'.
- # val - current number of open modal windows
- # w - root window's path
- # modal - yes, if the window is modal
- # var - variable's name for tkwait
- # regist - yes or no for registering/unregistering
- variable _PU_opts
- if {$modal || $regist} {
- set info [list $w $var $modal]
- set i [lsearch -exact $_PU_opts(_MODALWIN_) $info]
- catch {set _PU_opts(_MODALWIN_) [lreplace $_PU_opts(_MODALWIN_) $i $i]}
- if {$regist} {
- lappend _PU_opts(_MODALWIN_) $info
- }
- set res [IntStatus . MODALS $val]
- } else {
- set res [IntStatus . MODALS]
- }
- return $res
- }
- # ________________________ input _________________________ #
- proc input {dlgname icon ttl iopts args} {
- # Makes and runs an input dialog.
- # dlgname - dialog name
- # icon - icon (omitted if equals to "")
- # ttl - title of window
- # iopts - list of widgets and their attributes
- # args - list of dialog's attributes
- # The `iopts` contains lists of three items:
- # name - name of widgets
- # prompt - prompt for entering data
- # valopts - value options
- # The `valopts` is a list specific for a widget's type, however
- # a first item of `valopts` is always an initial input value.
- namespace upvar ::radxide dan dan
- variable Indexdlg
- variable _savedvv
- variable Dlgpath
- variable Dlgname
- variable dlg
- #tk_messageBox -title $dan(TITLE) -icon error -message "proc Input"
- danInitDialogs
- set Winpath $dan(WIN)
- set Dlgname [set dlg(NAME) $dlgname]
- set wdia $Winpath.dia$Dlgname[incr Indexdlg]
- set dlg(PATH) [set Dlgpath $wdia]
- if {$iopts ne {}} {
- initInput ;# clear away all internal vars
- }
- set pady "-pady 2"
- if {[set focusopt [getOption -focus {*}$args]] ne {}} {
- set focusopt "-focus $focusopt"
- }
- lappend inopts [list fraM + T 1 98 "-st nsew $pady -rw 1"]
- set _savedvv [list]
- set frameprev {}
- foreach {name prompt valopts} $iopts {
- if {$name eq {}} continue
- lassign $prompt prompt gopts attrs
- lassign [extractOptions attrs -method {} -toprev {}] ismeth toprev
- if {[string toupper $name 0] eq $name} {
- set ismeth yes ;# overcomes the above setting
- set name [string tolower $name 0]
- }
- set ismeth [string is true -strict $ismeth]
- set gopts "$pady $gopts"
- set typ [string tolower [string range $name 0 1]]
- if {$typ eq "v_" || $typ eq "se"} {
- lappend inopts [list fraM.$name - - - - "pack -fill x $gopts"]
- continue
- }
- set tvar "-tvar"
- switch -exact -- $typ {
- ch { set tvar "-var" }
- sp { set gopts "$gopts -expand 0 -side left"}
- }
- set framename fraM.fra$name
- if {$typ in {lb te tb}} { ;# the widgets sized vertically
- lappend inopts [list $framename - - - - "pack -expand 1 -fill both"]
- } else {
- lappend inopts [list $framename - - - - "pack -fill x"]
- }
- set vv [::radxide::win::varName $name]
- #tk_messageBox -title $dan(TITLE) -icon info -message vv=$vv
- set ff [FieldName $name]
- set Name [string toupper $name 0]
- if {$ismeth && $typ ni {ra}} {
- # -method option forces making "WidgetName" method from "widgetName"
- MakeWidgetName $ff $Name -
- }
- if {$typ ne {la} && $toprev eq {}} {
- set takfoc [parseOptions $attrs -takefocus 1]
- if {$focusopt eq {} && $takfoc} {
- if {$typ in {fi di cl fo da}} {
- set _ en*$name ;# 'entry-like mega-widgets'
- } elseif {$typ eq "ft"} {
- set _ te*$name ;# ftx - 'text-like mega-widget'
- } else {
- set _ $name
- }
- set focusopt "-focus $_"
- }
- if {$typ in {lb tb te}} {set anc nw} {set anc w}
- lappend inopts [list fraM.fra$name.labB$name - - - - \
- "pack -side left -anchor $anc -padx 3" \
- "-t \"$prompt\" -font \
- \"-family {[basicTextFont]} -size [basicFontSize]\""]
- }
- # for most widgets:
- # 1st item of 'valopts' list is the current value
- # 2nd and the rest of 'valopts' are a list of values
- if {$typ ni {fc te la}} {
- # curr.value can be set with a variable, so 'subst' is applied
- set vsel [lindex $valopts 0]
- catch {set vsel [subst -nocommands -nobackslashes $vsel]}
- set vlist [lrange $valopts 1 end]
- }
- if {[set msgLab [getOption -msgLab {*}$attrs]] ne {}} {
- set attrs [removeOptions $attrs -msgLab]
- }
- # define a current widget's info
- switch -exact -- $typ {
- lb - tb {
- set $vv $vlist
- lappend attrs -lvar $vv
- if {$vsel ni {{} -}} {
- lappend attrs -lbxsel "$UFF$vsel$UFF"
- }
- lappend inopts [list $ff - - - - \
- "pack -side left -expand 1 -fill both $gopts" $attrs]
- lappend inopts [list fraM.fra$name.sbv$name $ff L - - "pack -fill y"]
- }
- cb {
- if {![info exist $vv]} {catch {set $vv $vsel}}
- lappend attrs -tvar $vv -values $vlist
- if {$vsel ni {{} -}} {
- lappend attrs -cbxsel $UFF$vsel$UFF
- }
- lappend inopts [list $ff - - - - "pack -side left -expand 1 -fill x $gopts" $attrs]
- }
- fc {
- if {![info exist $vv]} {catch {set $vv {}}}
- lappend inopts [list $ff - - - - "pack -side left -expand 1 -fill x $gopts" "-tvar $vv -values \{$valopts\} $attrs"]
- }
- op {
- set $vv $vsel
- lappend inopts [list $ff - - - - "pack -fill x $gopts" "$vv $vlist"]
- }
- ra {
- if {![info exist $vv]} {catch {set $vv $vsel}}
- set padx 0
- foreach vo $vlist {
- set name $name
- set FF $ff[incr nnn]
- lappend inopts [list $FF - - - - "pack -side left $gopts -padx $padx" "-var $vv -value \"$vo\" -t \"$vo\" $attrs"]
- if {$ismeth} {
- MakeWidgetName $FF $Name$nnn -
- }
- set padx [expr {$padx ? 0 : 9}]
- }
- }
- te {
- if {![info exist $vv]} {
- set valopts [string map [list \\n \n \\t \t] $valopts]
- set $vv [string map [list \\\\ \\ \\\} \} \\\{ \{] $valopts]
- }
- # xxx
- #tk_messageBox -title $dan(TITLE) -icon error -message $vv
- if {[dict exist $attrs -state] && [dict get $attrs -state] eq "disabled"} \
- {
- # disabled text widget cannot be filled with a text, so we should
- # compensate this through a home-made attribute (-disabledtext)
- set disattr "-disabledtext \{[set $vv]\}"
- } elseif {[dict exist $attrs -readonly] && [dict get $attrs -readonly] || [dict exist $attrs -ro] && [dict get $attrs -ro]} {
- set disattr "-rotext \{[set $vv]\}"
- set attrs [removeOptions $attrs -readonly -ro]
- } else {
- set disattr {}
- }
- lappend inopts [list $ff - - - - "pack -side left -expand 1 -fill both $gopts" "$attrs $disattr"]
- lappend inopts [list fraM.fra$name.sbv$name $ff L - - "pack -fill y"]
- }
- la {
- if {$prompt ne {}} { set prompt "-t \"$prompt\" " } ;# prompt as -text
- lappend inopts [list $ff - - - - "pack -anchor w $gopts" "$prompt$attrs"]
- continue
- }
- bu - bt - ch {
- set prompt {}
- if {$toprev eq {}} {
- lappend inopts [list $ff - - - - \
- "pack -side left -expand 1 -fill both $gopts" "$tvar $vv $attrs"]
- } else {
- lappend inopts [list $frameprev.$name - - - - \
- "pack -side left $gopts" "$tvar $vv $attrs"]
- }
- if {$vv ne {}} {
- if {![info exist $vv]} {
- catch {
- if {$vsel eq {}} {set vsel 0}
- set $vv $vsel
- }
- }
- }
- }
- default {
- if {$vlist ne {}} {lappend attrs -values $vlist}
- lappend inopts [list $ff - - - - \
- "pack -side left -expand 1 -fill x $gopts" "$tvar $vv $attrs"]
- if {$vv ne {}} {
- if {![info exist $vv]} {catch {set $vv $vsel}}
- }
- }
- }
- if {$msgLab ne {}} {
- lassign $msgLab lab msg attlab
- set lab [parentWName [lindex $inopts end 0]].$lab
- if {$msg ne {}} {set msg "-t {$msg}"}
- append msg " $attlab"
- lappend inopts [list $lab - - - - "pack -side left -expand 1 -fill x" $msg]
- }
- if {![info exist $vv]} {set $vv {}}
- # xxx
- if {$typ eq "en"} {
- #tk_messageBox -title $dan(TITLE) -icon error -message setvv=[set $vv]
- addDialogField $name [set $vv] ""
- }
- lappend _savedvv $vv [set $vv]
- set frameprev $framename
- }
- lassign [parseOptions $args -titleHELP {} -buttons {} -comOK 1 \
- -titleOK OK -titleCANCEL Cancel -centerme {}] \
- titleHELP buttons comOK titleOK titleCANCEL centerme
- if {$titleHELP eq {}} {
- set butHelp {}
- } else {
- lassign $titleHELP title command
- set butHelp [list butHELP $title $command]
- }
- if {$titleCANCEL eq {}} {
- set butCancel {}
- } else {
- set butCancel "butCANCEL $titleCANCEL destroy"
- }
- if {$centerme eq {}} {
- set centerme {-centerme 1}
- } else {
- set centerme "-centerme $centerme"
- }
- set args [removeOptions $args \
- -titleHELP -buttons -comOK -titleOK -titleCANCEL -centerme -modal]
- # xxx
- #set buttons [string map {"butOK OK 1" "" "butCANCEL Cancel destroy" ""} $buttons]
- #tk_messageBox -title $dan(TITLE) -icon info -message new_buttons=$buttons
- lappend args {*}$focusopt
- #lassign [PrepArgs {*}$args] args
- if {[catch { \
- lassign [PrepArgs {*}$args] args
- set res [Query $dlgname $icon $ttl {} \
- "$butHelp $buttons butOK $titleOK $comOK $butCancel" \
- butOK $inopts $args {} {*}$centerme -input yes]} e]} {
-
- catch {destroy $Dlgpath]} ;# Query's window
- # ::apave::obj ok err "ERROR" "\n$e\n" \
- # -t 1 -head "\nAPave returned an error: \n" -hfg red -weight bold
-
- #tk_messageBox -title $dan(TITLE) -icon info -message "::win returned an error:$e"
-
- set res 0
- set msg "\nERROR in win:"
- puts \n$msg\n\n$e$::errorInfo\n
- #set msg "$msg\n\n$e\n\nPlease, inform authors.\nDetails are in stdout."
- #tk_messageBox -title $dan(TITLE) -icon error -message $msg
- #exit 2
-
- return $res
- }
- if {![lindex $res 0]} { ;# restore old values if OK not chosen
- foreach {vn vv} $_savedvv {
- # tk_optionCascade (destroyed now) was tracing its variable => catch
- catch {set $vn $vv}
- }
- }
-
- return $res
- }
- # _______________________ insert tab amenities _______________ #
- proc insertTab {} {
-
- namespace upvar ::radxide dan dan
-
- set wt $dan(TEXT)
-
- #set idx1 [$wt index {insert linestart}]
- #set idx2 [$wt index {insert lineend}]
- #set line [$wt get $idx1 $idx2]
-
- $wt insert {insert} $dan(TAB_IN_SPACE)
-
- return -code break
-
- }
- # ________________________ IntStatus _________________________ #
- proc IntStatus {w {name "status"} {val ""}} {
- # Sets/gets a status of window. The status is an integer assigned to a name.
- # w - window's path
- # name - name of status
- # val - if blank, to get a value of status; otherwise a value to set
- # Default value of status is 0.
- # Returns an old value of status.
- # See also: WindowStatus
- set old [WindowStatus $w $name {} 0]
- if {$val ne {}} {WindowStatus $w $name $val 1}
- return $old
- }
- # ________________________ LbxSelect _________________________ #
- proc LbxSelect {w idx} {
- # Selects a listbox item.
- # w - listbox's path
- # idx - item index
- $w activate $idx
- $w see $idx
- if {[$w cget -selectmode] in {single browse}} {
- $w selection clear 0 end
- $w selection set $idx
- event generate $w <<ListboxSelect>>
- }
- }
- # ________________________ ListboxesAttrs _________________________ #
- proc ListboxesAttrs {w attrs} {
- # Appends selection attributes to listboxes.
- # Details:
- # 1. https://wiki.tcl-lang.org/page/listbox+selection
- # 2. https://stackoverflow.com, the question:
- # the-tablelist-curselection-goes-at-calling-the-directory-dialog
- if {{-exportselection} ni $attrs} {
- append attrs " -ListboxSel $w -selectmode extended -exportselection 0"
- }
- return $attrs
- }
- # ________________________ LowercaseWidgetName _________________________ #
- proc LowercaseWidgetName {name} {
- # Makes the widget name lowercased.
- # name - widget's name
- # The widgets of widget list can have uppercased names which
- # means that the appropriate methods will be created to access
- # their full pathes with a command `my Name`.
- # This method gets a "normal" name of widget accepted by Tk.
- # See also: MakeWidgetName
- set root [ownWName $name]
- return [list [string range $name 0 [string last . $name]][string tolower $root 0 0] $root]
- }
- # ________________________ NonTtkStyle _________________________ #
- proc NonTtkStyle {typ {dsbl 0}} {
- # Gets a style for non-ttk widgets.
- # typ - the type of widget (in apave terms, i.e. but, buT etc.)
- # dsbl - a mode to get style of disabled (1) or readonly (2) widgets
- # See also: widgetType
- # Method to be redefined in descendants/mixins.
- return
- }
- # ________________________ NormalizeName _________________________ #
- proc NormalizeName {refname refi reflwidgets} {
- # Gets the real name of widget from *.name*.
- # refname - variable name for widget name
- # refi - variable name for index in widget list
- # reflwidgets - variable name for widget list
- # The *.name* means "child of some previous" and should be normalized.
- # Example:
- # If parent: fra.fra .....
- # child: .but
- # => normalized: fra.fra.but
- upvar $refname name $refi i $reflwidgets lwidgets
- set wname $name
- if {[string index $name 0] eq {.}} {
- for {set i2 [expr {$i-1}]} {$i2 >=0} {incr i2 -1} {
- lassign [lindex $lwidgets $i2] name2
- if {[string index $name2 0] ne {.}} {
- set name2 [lindex [LowercaseWidgetName $name2] 0]
- set wname "$name2$name"
- set name [lindex [LowercaseWidgetName $name] 0]
- set name "$name2$name"
- break
- }
- }
- }
- return [list $name $wname]
- }
- # ________________________ makeMainWindow _________________________ #
-
- # Scrollbars amenities
- proc Yset {widgets master sb args} {
-
- #if {$master eq "master"} {
- #list $sb set [expr [lindex $args 0]] [expr [lindex $args 1]]
-
- set sb1 [lrange $sb 0 0]
- set sb2 [lrange $sb 1 1]
-
- $sb1 set {*}$args
- $sb2 set {*}$args
-
- set myw [lrange $widgets 1 end]
- #} else {
- # set myw [lrange $widgets 0 0]
- #}
-
- ::radxide::win::Yview $myw moveto [lindex $args 0]
- #::radxide::win::Yview [lrange $widgets 0 0] moveto [lindex $args 0]
- }
-
- proc Yview {widgets args} {
- foreach w $widgets {
- $w yview {*}$args
- }
- }
-
- proc makeMainWindow {win ttl bg fg} {
- namespace upvar ::radxide dan dan
- set w [set wtop [string trimright $win .]]
- set withfr [expr {[set pp [string last . $w]]>0 && \
- [string match *.fra $w]}]
- if {$withfr} {
- set wtop [string range $w 0 $pp-1]
- }
-
- # menu
- set m [::radxide::menu::menuScaf]
-
- toplevel $wtop -menu $m
- if {$withfr} {
-
- # main frame
- pack [frame $w -background $bg ] -expand 1 -fill both
-
- # panedwindow
- pack [set pan [ttk::panedwindow $w.pan -orient horizontal]] -side top -fill both -expand 1
-
- # tree pane (panL)
- pack [set w1 [frame $pan.fra1 -background $bg ]] -side left -fill both ;#-expand 1 -fill both
- set panL [$pan add $pan.fra1]
- pack [set tree [ttk::treeview $w1.tree -selectmode extended]] -side left -fill both -expand 1
- set dan(TREEVIEW) $w1.tree
- $tree heading #0 -text " Project" -anchor "w"
-
- # main pane (panR)
- pack [set w2 [ttk::panedwindow $pan.fra2 -orient horizontal]] -side left -fill both -expand 1
- set panR [$pan add $pan.fra2]
- text $w2.gutText -background "lightgray" -foreground "#222223" -font "Monospace 10" -width 5
- text $w2.text -font "monospace 10" -bd 0 -padx 13 -spacing1 0 -spacing2 0 -spacing3 0 -exportselection yes -width 115 -wrap none
- set ww [list .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText]
- $w2.text configure -xscrollcommand [list $w2.xscroll set]
- scrollbar $w2.xscroll -orient horizontal \
- -command [list $w2.text xview]
- scrollbar $w2.yscroll1 -orient vertical \
- -command [list ::radxide::win::Yview $ww]
- scrollbar $w2.yscroll2 -orient vertical \
- -command [list $w2.gutText yview]
- set ssbb [list .danwin.fra.pan.fra2.yscroll1 .danwin.fra.pan.fra2.yscroll2]
- $w2.text configure -yscrollcommand [list ::radxide::win::Yset $ww master $ssbb]
- $w2.gutText configure -yscrollcommand [list .danwin.fra.pan.fra2.yscroll2 set]
- grid $w2.gutText $w2.text $w2.yscroll1 -sticky nsew
- grid $w2.xscroll -columnspan 2 -sticky nsew
- grid rowconfigure $w2 0 -weight 1
- grid columnconfigure $w2 1 -weight 1
-
- set dan(GUTTEXT) $w2.gutText
- set dan(TEXT) $w2.text
- $dan(GUTTEXT) configure -state disabled
- $dan(TEXT) configure -state disabled
-
- # set colors
- $dan(TEXT) configure -background $dan(TEXTBG) -foreground $dan(TEXTFG)
- $dan(TEXT) configure -selectforeground $dan(TEXTSELFG)
- $dan(TEXT) configure -insertbackground $dan(CURSORCOLOR) -insertwidth $dan(CURSORWIDTH);
-
- # code library
- pack [set w3 [frame $pan.fra3 -background $bg]] -side left -fill y -expand 1;
- set panC [$pan add $pan.fra3]
- ::radxide::eglib::create $w3
-
- # update gutter, key bindings
- bind $dan(TEXT) "<Return>" {::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 "#FFFFFF" "#222223"}
- bind $dan(TEXT) "<BackSpace>" {::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 "#FFFFFF" "#222223"}
- bind $dan(TEXT) "<Cancel>" {::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 "#FFFFFF" "#222223" ;::radxide::win::Yview {.danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText} scroll -0 units ;::radxide::win::Yview {.danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText} scroll 1 units}
- bind $dan(TEXT) "<Delete>" {::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 "#FFFFFF" "#222223" ;::radxide::win::Yview {.danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText} scroll -1 units ;::radxide::win::Yview {.danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText} scroll 1 units}
- bind $tree "<ButtonPress>" {after idle {::radxide::tree::buttonPress %b %x %y %X %Y}}
- bind $tree "<ButtonRelease>" {after idle {::radxide::tree::buttonRelease %b %s %x %y %X %Y}}
-
- }
- #wm title $wtop ttl
-
- # window shortcut bindings
- set canvas $w2.gutText
- ::radxide::menu::defWinShortcuts $dan(TEXT) $canvas
- ::radxide::menu::defWinShortcuts $dan(TREEVIEW) $canvas
- }
- # ________________________ MakeWidgetName _________________________ #
- proc MakeWidgetName {w name {an {}}} {
- # Makes an exported method named after root widget, if it's uppercased.
- # w - name of root widget
- # name - name of widget
- # an - additional prefix for name (if "-", $w is full/partial name)
- # The created method used for easy access to the widget's path.
- # Example:
- # fra1.fra2.fra3.Entry1
- # => method Entry1 {} {...}
- # ...
- # my Entry1 ;# instead of .win.fra1.fra2.fra3.Entry1
- if {$an eq {-}} {
- set wnamefull "\[DiaWidgetName $w\]"
- } else {
- set wnamefull [WidgetNameFull $w $name $an]
- lassign [LowercaseWidgetName $wnamefull] wnamefull
- }
- set method [ownWName $name]
- set root1 [string index $method 0]
- #if {[string is upper $root1]} {
- # oo::objdefine [self] "method $method {} {return $wnamefull} ; \
- # export $method"
- #}
- return $wnamefull
- }
- # ________________________ makeWindow _________________________ #
- proc makeWindow {w ttl args} {
- # Creates a toplevel window that has to be paved.
- # w - window's name
- # ttl - window's title
- # args - options for 'toplevel' command
- # If $w matches "*.fra" then ttk::frame is created with name $w.
- namespace upvar ::radxide dan dan
- #CleanUps
- set w [set wtop [string trimright $w .]]
- set withfr [expr {[set pp [string last . $w]]>0 && \
- [string match *.fra $w]}]
- if {$withfr} {
- set wtop [string range $w 0 $pp-1]
- }
- catch {destroy $wtop}
- lassign [extractOptions args -type {}] type
- toplevel $wtop {*}$args
- withdraw $wtop ;# nice to hide all gui manipulations
- if {$type ne {} && [tk windowingsystem] eq {x11}} {
- wm attributes $wtop -type $type
- }
- if {$withfr} {
- pack [frame $w -background $dan(BG)] -expand 1 -fill both
- }
- wm title $wtop $ttl
- return $wtop
- }
- # ________________________ ownWName _________________________ #
- proc ownWName {name} {
- # Gets a tail (last part) of widget's name
- # name - name (path) of the widget
- return [lindex [split $name .] end]
- }
- # ________________________ parentWName _________________________ #
- proc parentWName {name} {
- # Gets parent name of widget.
- # name - name (path) of the widget
- return [string range $name 0 [string last . $name]-1]
- }
- # ________________________ parseOptionsFile _________________________ #
- proc parseOptionsFile {strict inpargs args} {
- # Parses argument list containing options and (possibly) a file name.
- # strict - if 0, 'args' options will be only counted for,
- # other options are skipped
- # strict - if 1, only 'args' options are allowed,
- # all the rest of inpargs to be a file name
- # - if 2, the 'args' options replace the
- # appropriate options of 'inpargs'
- # inpargs - list of options, values and a file name
- # args - list of default options
- #
- # The inpargs list contains:
- # - option names beginning with "-"
- # - option values following their names (may be missing)
- # - "--" denoting the end of options
- # - file name following the options (may be missing)
- #
- # The *args* parameter contains the pairs:
- # - option name (e.g., "-dir")
- # - option default value
- #
- # If the *args* option value is equal to =NONE=, the *inpargs* option
- # is considered to be a single option without a value and,
- # if present in inpargs, its value is returned as "yes".
- #
- # If any option of *inpargs* is absent in *args* and strict==1,
- # the rest of *inpargs* is considered to be a file name.
- #
- # The proc returns a list of two items:
- # - an option list got from args/inpargs according to 'strict'
- # - a file name from inpargs or {} if absent
- #
- # Examples see in tests/obbit.test.
- variable _PU_opts
- set actopts true
- array set argarray "$args yes yes" ;# maybe, tail option without value
- if {$strict==2} {
- set retlist $inpargs
- } else {
- set retlist $args
- }
- set retfile {}
- for {set i 0} {$i < [llength $inpargs]} {incr i} {
- set parg [lindex $inpargs $i]
- if {$actopts} {
- if {$parg eq "--"} {
- set actopts false
- } elseif {[catch {set defval $argarray($parg)}]} {
- if {$strict==1} {
- set actopts false
- append retfile $parg " "
- } else {
- incr i
- }
- } else {
- if {$strict==2} {
- if {$defval == $_PU_opts(-NONE)} {
- set defval yes
- }
- incr i
- } else {
- if {$defval == $_PU_opts(-NONE)} {
- set defval yes
- } else {
- set defval [lindex $inpargs [incr i]]
- }
- }
- set ai [lsearch -exact $retlist $parg]
- incr ai
- set retlist [lreplace $retlist $ai $ai $defval]
- }
- } else {
- append retfile $parg " "
- }
- }
- return [list $retlist [string trimright $retfile]]
- }
-
- # ________________________ parseOptions _________________________ #
- proc parseOptions {opts args} {
- # Parses argument list containing options.
- # opts - list of options and values
- # args - list of "option / default value" pairs
- # It's the same as parseOptionsFile, excluding the file name stuff.
- # Returns a list of options' values, according to args.
- # See also: parseOptionsFile
- lassign [parseOptionsFile 0 $opts {*}$args] tmp
- foreach {nam val} $tmp {
- lappend retlist $val
- }
- return $retlist
- }
- # ________________________ popupHighlightCommands _________________________ #
- proc popupHighlightCommands {{pop ""} {txt ""}} {
- # Returns highlighting commands for a popup menu on a text.
- # pop - path to the menu
- # txt - path to the text
- set res ""
-
- return $res
- }
- # ________________________ Pre _________________________ #
- proc Pre {refattrs} {
- # "Pre" actions for the text widget and similar
- # which all require some actions before and after their creation e.g.:
- # the text widget's text cannot be filled if disabled
- # so, we must act this way:
- # 1. call Pre - to get a text of widget
- # 2. create the widget
- # 3. call Post - to enable, then fill it with a text, then disable it
- # It's only possible with Pre and Post methods.
- # See also: Post
- upvar 1 $refattrs attrs
- set attrs_ret [set Prepost [list]]
- foreach {a v} $attrs {
- switch -exact -- $a {
- -disabledtext - -rotext - -lbxsel - -cbxsel - -notebazook - \
- -entrypop - -entrypopRO - -textpop - -textpopRO - -ListboxSel - \
- -callF2 - -timeout - -bartabs - -onReturn - -linkcom - -selcombobox - \
- -afteridle - -gutter - -propagate - -columnoptions - -selborderwidth -
- -selected - -popup - -bindEC - -tags - -debug - -clearcom {
- # attributes specific to apave, processed below in "Post"
- set v2 [string trimleft $v \{]
- set v2 [string range $v2 0 end-[expr {[string length $v]-[string length $v2]}]]
- lappend Prepost [list $a $v2]
- }
- -myown {
- lappend Prepost [list $a [subst $v]]
- }
- -labelwidget { ;# widget path as a method
- set v [string trim $v \{\}]
- catch {set v [$::win::$v]}
- lappend attrs_ret $a $v
- }
- default {
- lappend attrs_ret $a $v
- }
- }
- }
- set attrs $attrs_ret
- return
- }
- # ________________________ PrepArgs _________________________ #
- proc PrepArgs {args} {
- # Prepares a list of arguments.
- # Returns the list (wrapped in list) and a command for OK button.
- lassign [parseOptions $args -modal {} -ch {} -comOK {} -onclose {}] \
- modal ch comOK onclose
- if {[string is true -strict $modal]} {
- set com 1
- } elseif {$ch ne {}} {
- # some options are incompatible with -ch
- if {$onclose eq {destroy}} {set onclose {}}
- lappend args -modal 1 -onclose $onclose
- set com 1
- } elseif {$comOK eq {}} {
- set com destroy ;# non-modal without -ch option
- } else {
- set com $comOK
- }
- return [list [list $args] $com]
- }
- ## ________________________ Query _________________________ ##
- proc Query {dlgname icon ttl msg buttons defb inopts argdia {precom ""} args} {
- # Makes a query (or a message) and gets the user's response.
- # dlgname - dialog name
- # icon - icon name (info, warn, ques, err)
- # ttl - title
- # msg - message
- # buttons - list of triples "button name, text, ID"
- # defb - default button (OK, YES, NO, CANCEL, RETRY, ABORT)
- # inopts - options for input dialog
- # argdia - list of dialog's options
- # precom - command(s) performed before showing the dialog
- # args - additional options (message's font etc.)
- # The *argdia* may contain additional options of the query, like these:
- # -checkbox text (-ch text) - makes the checkbox's text visible
- # -geometry +x+y (-g +x+y) - sets the geometry of dialog
- # -color cval (-c cval) - sets the color of message
- # If "-geometry" option is set (even equaling "") the Query procedure
- # returns a list with chosen button's ID and a new geometry.
- # Otherwise it returns only the chosen button's ID.
- # See also:
- # [aplsimple.github.io](https://aplsimple.github.io/en/tcl/pave/index.html)
- namespace upvar ::radxide dan dan
- variable Indexdlg
- variable Foundstr
- variable Dlgpath
- variable Dlgname
- variable dlg
-
- #tk_messageBox -title $dan(TITLE) -icon error -message "Query"
- set Winpath $dan(WIN)
- set Dlgname $dlg(NAME)
- set wdia $Winpath.dia$Dlgname
- #append wdia [lindex [split :] end] ;# be unique per apave object
- #set qdlg [set dlg(PATH) [set Dlgpath $wdia[incr Indexdlg]]]
- set qdlg $Dlgpath
- #tk_messageBox -title $dan(TITLE) -icon error -message $qdlg
- # remember the focus (to restore it after closing the dialog)
- set focusback [focus]
- set focusmatch {}
- # options of dialog
- lassign {} chmsg geometry optsLabel optsMisc optsFont optsFontM optsHead \
- root rotext head hsz binds postcom onclose timeout tab2 \
- tags cc themecolors optsGrid addpopup minsize
- set wasgeo [set textmode [set stay [set waitvar 0]]]
- set readonly [set hidefind [set scroll [set modal 1]]]
- set curpos {1.0}
- set CheckNomore 0
- foreach {opt val} {*}$argdia {
- if {$opt in {-c -color -fg -bg -fgS -bgS -cc -hfg -hbg}} {
- # take colors by their variables
- if {[info exist $val]} {set val [set $val]}
- }
- switch -- $opt {
- -H - -head {
- set head [string map {$ \$ \" \'\' \{ ( \} )} $val]
- }
- -help {
- set buttons "butHELP Help {$val} $buttons"
- }
- -ch - -checkbox {set chmsg "$val"}
- -g - -geometry {
- set geometry $val
- if {[set wasgeo [expr {[string first "pointer" $val]<0}]]} {
- lassign [splitGeometry $geometry] - - gx gy
- }
- }
- -c - -color {append optsLabel " -foreground {$val}"}
- -a { ;# additional grid options of message labels
- append optsGrid " $val" }
- -centerme - -ontop - -themed - -resizable - -checkgeometry - -onclose - -comOK - -transient {
- lappend args $opt $val ;# options delegated to showModal method
- }
- -parent - -root { ;# obsolete, used for compatibility
- lappend args -centerme $val
- }
- -t - -text {set textmode $val}
- -tags {
- upvar 2 $val _tags
- set tags $_tags
- }
- -ro - -readonly {set readonly [set hidefind $val]}
- -rotext {set hidefind 0; set rotext $val}
- -w - -width {set charwidth $val}
- -h - -height {set charheight $val}
- -fg {append optsMisc " -foreground {$val}"}
- -bg {append optsMisc " -background {$val}"}
- -fgS {append optsMisc " -selectforeground {$val}"}
- -bgS {append optsMisc " -selectbackground {$val}"}
- -cc {append optsMisc " -insertbackground {$val}"}
- -my - -myown {append optsMisc " -myown {$val}"}
- -pos {set curpos "$val"}
- -hfg {append optsHead " -foreground {$val}"}
- -hbg {append optsHead " -background {$val}"}
- -hsz {append hsz " -size $val"}
- -minsize {set minsize "-minsize {$val}"}
- -focus {set focusmatch "$val"}
- -theme {append themecolors " {$val}"}
- -post {set postcom $val}
- -popup {set addpopup [string map [list %w $qdlg.fra.texM] "$val"]}
- -timeout - -focusback - -scroll - -tab2 - -stay - -modal - -waitvar {
- set [string range $opt 1 end] $val
- }
- default {
- append optsFont " $opt $val"
- if {$opt ne "-family"} {
- append optsFontM " $opt $val"
- }
- }
- }
- }
- if {[set wprev [InfoFind $wdia $modal]] ne {}} {
- catch {
- wm withdraw $wprev
- wm deiconify $wprev
- puts "$wprev already exists: selected now"
- }
- return 0
- }
- set optsFont [string trim $optsFont]
- set optsHeadFont $optsFont
- set fs [basicFontSize]
- set textfont "-family {[basicTextFont]}"
- if {$optsFont ne {}} {
- if {[string first "-size " $optsFont]<0} {
- append optsFont " -size $fs"
- }
- if {[string first "-size " $optsFontM]<0} {
- append optsFontM " -size $fs"
- }
- if {[string first "-family " $optsFont]>=0} {
- set optsFont "-font \{$optsFont"
- } else {
- set optsFont "-font \{$optsFont -family {[basicDefFont]}"
- }
- append optsFont "\}"
- } else {
- set optsFont "-font {[basicDefFont] -size $fs}"
- set optsFontM "-size $fs"
- }
- set msgonly [expr {$readonly || $hidefind || $chmsg ne {}}]
- if {!$textmode || $msgonly} {
- set textfont "-family {[basicDefFont]}"
- if {!$textmode} {
- set msg [string map [list \\ \\\\ \{ \\\\\{ \} \\\\\}] $msg]
- }
- }
- set optsFontM [string trim $optsFontM]
- set optsFontM "-font \{$optsFontM $textfont\}"
- # layout: add the icon
- if {$icon ni {{} -}} {
- #tk_messageBox -title $dan(TITLE) -icon error -message "Yess!"
- set widlist [list [list labBimg - - 99 1 \
- {-st n -pady 7} "-image [iconImage $icon]"]]
- set prevl labBimg
- } else {
- set widlist [list [list labimg - - 99 1]]
- set prevl labimg ;# this trick would hide the prevw at all
- }
- set prevw labBimg
- #tk_messageBox -title $dan(TITLE) -icon info -message Header:$head
- if {$head ne {}} {
- # set the dialog's heading (-head option)
- if {$optsHeadFont ne {} || $hsz ne {}} {
- if {$hsz eq {}} {set hsz "-size [basicFontSize]"}
- set optsHeadFont [string trim "$optsHeadFont $hsz"]
- set optsHeadFont "-font \"$optsHeadFont\""
- }
- set optsFont {}
- set prevp L
- set head [string map {\\n \n} $head]
- foreach lh [split $head "\n"] {
- set labh "labheading[incr il]"
- lappend widlist [list $labh $prevw $prevp 1 99 {-st we} \
- "-t \"$lh\" $optsHeadFont $optsHead"]
- set prevw [set prevh $labh]
- set prevp T
- }
- } else {
- # add the upper (before the message) blank frame
- lappend widlist [list h_1 $prevw L 1 1 {-pady 3}]
- set prevw [set prevh h_1]
- set prevp T
- }
- # add the message lines
- set il [set maxw 0]
- if {$readonly && $rotext eq {}} {
- # only for messaging (not for editing/viewing texts):
- set msg [string map {\\\\n \\n \\n \n} $msg]
- }
- foreach m [split $msg \n] {
- set m [string map {$ \$ \" \'\'} $m]
- if {[set mw [string length $m]] > $maxw} {
- set maxw $mw
- }
- incr il
- if {!$textmode} {
- lassign [GetLinkLab $m] m link
- lappend widlist [list Lab$il $prevw $prevp 1 7 \
- "-st w -rw 1 $optsGrid" "-t \"$m \" $optsLabel $optsFont $link"]
- }
- set prevw Lab$il
- set prevp T
- }
- if {$inopts ne {}} {
- # here are widgets for input (in fraM frame)
- set io0 [lindex $inopts 0]
- lset io0 1 $prevh
- lset inopts 0 $io0
- foreach io $inopts {
- lappend widlist $io
- }
- set prevw fraM
- } elseif {$textmode} {
- # here is text widget (in fraM frame)
- ; proc vallimits {val lowlimit isset limits} {
- set val [expr {max($val,$lowlimit)}]
- if {$isset} {
- upvar $limits lim
- lassign $lim l1 l2
- set val [expr {min($val,$l1)}] ;# forced low
- if {$l2 ne {}} {set val [expr {max($val,$l2)}]} ;# forced high
- }
- return $val
- }
- set il [vallimits $il 1 [info exists charheight] charheight]
- incr maxw
- set maxw [vallimits $maxw 20 [info exists charwidth] charwidth]
- rename vallimits {}
- lappend widlist [list fraM $prevh T 10 12 {-st nswe -pady 3 -rw 1}]
- lappend widlist [list TexM - - 1 12 {pack -side left -expand 1 -fill both -in \
- $qdlg.fra.fraM} [list -h $il -w $maxw {*}$optsFontM {*}$optsMisc \
- -wrap word -textpop 0 -tabnext "$qdlg.fra.[lindex $buttons 0] *but0"]]
- if {$scroll} {
- lappend widlist {sbv texM L 1 1 {pack -in $qdlg.fra.fraM}}
- }
- set prevw fraM
- }
- # add the lower (after the message) blank frame
- lappend widlist [list h_2 $prevw T 1 1 {-pady 0 -ipady 0 -csz 0}]
- # underline the message
- lappend widlist [list seh $prevl T 1 99 {-st ew}]
- # add left frames and checkbox (before buttons)
- lappend widlist [list h_3 seh T 1 1 {-pady 0 -ipady 0 -csz 0}]
- if {$textmode} {
- # binds to the special popup menu of the text widget
- set wt "\[TexM\]"
- set binds "set pop $wt.popupMenu
- bind $wt <Button-3> \{[self] themePopup $wt.popupMenu; tk_popup $wt.popupMenu %X %Y \}"
- if {$msgonly} {
- append binds "
- menu \$pop
- \$pop add command [iconA copy] -accelerator Ctrl+C -label \"Copy\" \\
- -command \"event generate $wt <<Copy>>\""
- if {$hidefind || $chmsg ne {}} {
- append binds "
- \$pop configure -tearoff 0
- \$pop add separator
- \$pop add command [iconA none] -accelerator Ctrl+A \\
- -label \"Select All\" -command \"$wt tag add sel 1.0 end\"
- bind $wt <Control-a> \"$wt tag add sel 1.0 end; break\""
- }
- }
- }
- set appendHL no
- if {$chmsg eq {}} {
- if {$textmode} {
- set noIMG "[iconA none]"
- if {$hidefind} {
- lappend widlist [list h__ h_3 L 1 4 {-cw 1}]
- } else {
- lappend widlist [list labfnd h_3 L 1 1 "-st e" "-t {$::win::msgarray(find)}"]
- lappend widlist [list Entfind labfnd L 1 1 \
- {-st ew -cw 1} "-tvar [namespace current]::Foundstr -w 10"]
- lappend widlist [list labfnd2 Entfind L 1 1 "-cw 2" "-t {}"]
- lappend widlist [list h__ labfnd2 L 1 1]
- #append binds "
- # bind \[[self] Entfind\] <Return> {[self] findInText}
- # bind \[[self] Entfind\] <KP_Enter> {[self] findInText}
- # bind \[[self] Entfind\] <FocusIn> {\[[self] Entfind\] selection range 0 end}
- # bind $qdlg <F3> {[self] findInText 1}
- # bind $qdlg <Control-f> \"InitFindInText 1; focus \[[self] Entfind\]; break\"
- # bind $qdlg <Control-F> \"InitFindInText 1; focus \[[self] Entfind\]; break\""
- }
- if {$readonly} {
- if {!$hidefind} {
- # append binds "
- # \$pop add separator
- # \$pop add command [iconA find] -accelerator Ctrl+F -label \\
- # \"Find First\" -command \"[self] InitFindInText; focus \[[self] Entfind\]\"
- # \$pop add command $noIMG -accelerator F3 -label \"Find Next\" \\
- # -command \"[self] findInText 1\"
- # $addpopup
- # \$pop add separator
- # \$pop add command [iconA exit] -accelerator Esc -label \"Close\" \\
- # -command \"\[[self] paveoptionValue Defb1\] invoke\"
- # "
- } else {
- set appendHL yes
- }
- } else {
- # make bindings and popup menu for text widget
- #after idle "set_highlight_matches \[TexM\]"
- #append binds "
- # [setTextBinds $wt]
- # menu \$pop
- # \$pop add command [iconA cut] -accelerator Ctrl+X -label \"Cut\" \\
- # -command \"event generate $wt <<Cut>>\"
- # \$pop add command [iconA copy] -accelerator Ctrl+C -label \"Copy\" \\
- # -command \"event generate $wt <<Copy>>\"
- # \$pop add command [iconA paste] -accelerator Ctrl+V -label \"Paste\" \\
- # -command \"event generate $wt <<Paste>>\"
- # [popupBlockCommands \$pop $wt]
- # [popupHighlightCommands \$pop $wt]
- # [popupFindCommands \$pop $wt]
- # $addpopup
- # \$pop add separator
- # \$pop add command [iconA SaveFile] -accelerator Ctrl+W \\
- # -label \"Save and Close\" -command \"[self] res $qdlg 1\"
- # "
- }
- #set onclose [namespace current]::exitEditor
- #oo::objdefine [self] export InitFindInText
- } else {
- lappend widlist [list h__ h_3 L 1 4 {-cw 1}]
- }
- } else {
- lappend widlist [list chb h_3 L 1 1 \
- {-st w} "-t {$chmsg} -var [namespace current]::CheckNomore"]
- lappend widlist [list h_ chb L 1 1]
- lappend widlist [list sev h_ L 1 1 {-st nse -cw 1}]
- lappend widlist [list h__ sev L 1 1]
- set appendHL $textmode
- }
- #if {$appendHL} {
- # after idle "set_highlight_matches $wt"
- # append binds "
- # [popupHighlightCommands \$pop $wt]"
- #}
- # add the buttons
-
- # xxx
- if {$dlgname eq "RenameFile" || $dlgname eq "RenameFolder" || $dlgname eq "Find" || $dlgname eq "GotoLine"} {
- set buttons [string map {"butOK OK 1" "" "butCANCEL Cancel destroy" ""} $buttons]
- }
- lassign [AppendButtons widlist $buttons h__ L $defb $timeout $qdlg $modal] \
- bhelp bcomm
- # make the dialog's window
- set wtop [makeWindow $qdlg.fra $ttl]
- if {$bhelp ne {}} {
- bind $qdlg <F1> $bcomm
- }
- # pave the dialog's window
- if {$tab2 eq {}} {
- set widlist [rockWindow $qdlg.fra $widlist]
- } else {
- # pave with the notebook tabs (titl1 title2 [title3...] widlist2 [widlist3...])
- lassign $tab2 ttl1 ttl2 widlist2 ttl3 widlist3 ttl4 widlist4 ttl5 widlist5
- foreach nt {3 4 5} {
- set ttl ttl$nt
- set wdl widlist$nt
- if {[set _ [set $ttl]] ne {}} {
- set $ttl [list f$nt "-t {$_}"]
- set $wdl [list $qdlg.fra.nbk.f$nt "[set $wdl]"]
- }
- }
- set widlist0 [list [list nbk - - - - {pack -side top -expand 1 -fill both} [list \
- f1 "-t {$ttl1}" \
- f2 "-t {$ttl2}" \
- {*}$ttl3 \
- {*}$ttl4 \
- {*}$ttl5 \
- ]]]
-
- set widlist1 [list]
- foreach it $widlist {
- lassign $it w nei pos r c opt atr
- set opt [string map {$qdlg.fra $qdlg.fra.nbk.f1} $opt]
- lappend widlist1 [list $w $nei $pos $r $c $opt $atr]
- }
- set widlist [rockWindow $qdlg.fra $widlist0 \
- $qdlg.fra.nbk.f1 $widlist1 \
- $qdlg.fra.nbk.f2 $widlist2 \
- {*}$widlist3 \
- {*}$widlist4 \
- {*}$widlist5 \
- ]
- set tab2 nbk.f1.
- }
- if {$precom ne {}} {
- {*}$precom ;# actions before showModal
- }
- # if {$themecolors ne {}} {
- # # themed colors are set as sequentional '-theme' args
- # if {[llength $themecolors]==2} {
- # # when only 2 main fb/bg colors are set (esp. for TKE)
- # lassign [::apave::parseOptions $optsMisc -foreground black \
- # -background white -selectforeground black \
- # -selectbackground gray -insertbackground black] v0 v1 v2 v3 v4
- # # the rest colors should be added, namely:
- # # tfg2 tbg2 tfgS tbgS tfgD tbgD tcur bclr help fI bI fM bM fW bW bHL2
- # lappend themecolors $v0 $v1 $v2 $v3 $v3 $v1 $v4 $v4 $v3 $v2 $v3 $v0 $v1 black #ffff9e $v1
- # }
- # catch {
- # my themeWindow $qdlg $themecolors no
- # }
- # }
- # after creating widgets - show dialog texts if any
- SetGetTexts set $qdlg.fra $inopts $widlist
- lassign [LowercaseWidgetName $qdlg.fra.$tab2$defb] focusnow
- if {$textmode} {
- displayTaggedText [TexM] msg $tags
- if {$defb eq "ButTEXT"} {
- if {$readonly} {
- lassign [LowercaseWidgetName $Defb1] focusnow
- } else {
- set focusnow [TexM]
- catch "::tk::TextSetCursor $focusnow $curpos"
- foreach k {w W} \
- {catch "bind $focusnow <Control-$k> {[self] res $qdlg 1; break}"}
- }
- }
- if {$readonly} {
- readonlyWidget ::[TexM] true false
- }
- }
- if {$focusmatch ne {}} {
- foreach w $widlist {
- lassign $w widname
- lassign [LowercaseWidgetName $widname] wn rn
- if {[string match $focusmatch $rn]} {
- lassign [LowercaseWidgetName $qdlg.fra.$wn] focusnow
- break
- }
- }
- }
- catch "$binds"
- set args [removeOptions $args -focus]
- set querydlg $qdlg
- showModal $qdlg -modal $modal -waitvar $waitvar -onclose $onclose \
- -focus $focusnow -geometry $geometry {*}$minsize {*}$args
- if {![winfo exists $qdlg] || (!$modal && !$waitvar)} {
- return 0
- }
- set pdgeometry [wm geometry $qdlg]
- # the dialog's result is defined by "pave res" + checkbox's value
- # xxx
- #tk_messageBox -title $dan(TITLE) -icon info -message $qdlg
- set res [set result [::radxide::win::res $qdlg]]
- #tk_messageBox -title $dan(TITLE) -icon info -message resX=$res
- set chv $CheckNomore
- if { [string is integer $res] } {
- if {$res && $chv} { incr result 10 }
- } else {
- set res [expr {$result ne {} ? 1 : 0}]
- if {$res && $chv} { append result 10 }
- }
- if {$textmode && !$readonly} {
- set focusnow [TexM]
- set textcont [$focusnow get 1.0 end]
- if {$res && $postcom ne {}} {
- {*}$postcom textcont [TexM] ;# actions after showModal
- }
- set textcont " [$focusnow index insert] $textcont"
- } else {
- set textcont {}
- }
- if {$res && $inopts ne {}} {
- SetGetTexts get $qdlg.fra $inopts $widlist
- set inopts " [GetVarsValues $widlist]"
- } else {
- set inopts {}
- }
- if {$textmode && $rotext ne {}} {
- set $rotext [string trimright [TexM] get 1.0 end]]
- }
- if {!$stay} {
- destroy $qdlg
- update
- # pause a bit and restore the old focus
- if {$focusback ne {} && [winfo exists $focusback]} {
- set w ".[lindex [split $focusback .] 1]"
- after 50 [list if "\[winfo exist $focusback\]" "focus -force $focusback" elseif "\[winfo exist $w\]" "focus $w"]
- } else {
- after 50 list focus .
- }
- }
- if {$wasgeo} {
- lassign [splitGeometry $pdgeometry] w h x y
- catch {
- # geometry option can contain pointer/root etc.
- if {abs($x-$gx)<30} {set x $gx}
- if {abs($y-$gy)<30} {set y $gy}
- }
- return [list $result ${w}x$h$x$y $textcont [string trim $inopts]]
- }
- return "$result$textcont$inopts"
- }
- # ________________________ readonlyWidget _________________________ #
- proc readonlyWidget {w {on yes} {popup yes}} {
- # Switches on/off a widget's readonly state for a text widget.
- # w - text widget's path
- # on - "on/off" boolean flag
- # popup - "make popup menu" boolean flag
- # See also:
- # [wiki.tcl-lang.org](https://wiki.tcl-lang.org/page/Read-only+text+widget)
- #my TextCommandForChange $w {} $on
- #if {$popup} {my makePopup $w $on yes}
- return
- }
- proc readTextFile {fileName {varName ""} {doErr 0} args} {
- # Reads a text file.
- # fileName - file name
- # varName - variable name for file content or ""
- # doErr - if 'true', exit at errors with error message
- # Returns file contents or "".
- variable _PU_opts
- if {$varName ne {}} {upvar $varName fvar}
- if {[catch {set chan [open $fileName]} _PU_opts(_ERROR_)]} {
- if {$doErr} {error [::radxide::win::error $fileName]}
- set fvar {}
- } else {
- set enc [getOption -encoding {*}$args]
- set eol [string tolower [getOption -translation {*}$args]]
- if {$eol eq {}} {set eol auto} ;# let EOL be autodetected by default
- textChanConfigure $chan $enc $eol
- set fvar [read $chan]
- close $chan
- logMessage "read $fileName"
- }
- return $fvar
- }
- # ________________________ renameFileOK _________________________ #
- proc renameFileOK {} {
-
- namespace upvar ::radxide dan dan project project
- variable dlg
-
- #set t $Dlgpath.fra.fraM.fraent.ent
- set t [dlgPath].fra.[FieldName [lindex [getDialogField 0] 0]]
- #tk_messageBox -title $dan(TITLE) -icon info -message textbox=$t
- set varname [lindex [getDialogField end] 0]
- #tk_messageBox -title $dan(TITLE) -icon info -message varname=$varname
- set oldpath [lindex [getDialogField end] 1]
- #tk_messageBox -title $dan(TITLE) -icon info -message oldpath=$oldpath
- set newpath [string trim [$t get]]
- #tk_messageBox -title $dan(TITLE) -icon info -message newpath=$newpath
- set pathlength [expr [string length $newpath]-1]
- if {[string range $newpath $pathlength $pathlength] eq "/"} {
- tk_messageBox -title $dan(TITLE) -icon info -message "Destination can't be a folder!"
- return 0
- }
- if {[string first $dan(WORKDIR) $newpath] eq -1} {
- tk_messageBox -title $dan(TITLE) -icon info -message "New file path outside the Working Dir!"
- return 0
- }
- if {[string first $project(ROOT) $newpath] eq -1} {
- tk_messageBox -title $dan(TITLE) -icon info -message "New file path outside the Project Dir!"
- return 0
- }
-
- if {[catch {file rename $oldpath $newpath} e]} {
- set msg "\nERROR in win:"
- puts \n$msg\n\n$e$::errorInfo\n
- set msg "$msg\n\n$e\n\nPlease, inform authors.\nDetails are in stdout."
- tk_messageBox -title $dan(TITLE) -icon error -message $msg
- return 0
- }
-
- # saving {field oldval newval} for later use
- editDialogField end $varname $oldpath $newpath
- ::radxide::tree::create
-
- # Workaround for an overwheling activation of the main text editor..
- if {$project(CUR_FILE_PATH) eq ""} {
- $dan(TEXT) configure -state disabled
- }
-
- catch {destroy [dlgPath]}
- return 1
- }
- # ________________________ renameFileCancel _________________________ #
- proc renameFileCancel {} {
-
- #catch {[destroy .danwin.diaRenameFile1]}
- catch {[destroy [dlgPath]]}
-
- return 0
- }
- # ________________________ renameFolderOK _________________________ #
- proc renameFolderOK {} {
-
- namespace upvar ::radxide dan dan project project
- variable dlg
-
- #set t $Dlgpath.fra.fraM.fraent.ent
- set t [dlgPath].fra.[FieldName [lindex [getDialogField 0] 0]]
- #tk_messageBox -title $dan(TITLE) -icon info -message textbox=$t
- set varname [lindex [getDialogField end] 0]
- #tk_messageBox -title $dan(TITLE) -icon info -message varname=$varname
- set oldpath [lindex [getDialogField end] 1]
- #tk_messageBox -title $dan(TITLE) -icon info -message oldpath=$oldpath
- set newpath [string trim [$t get]]
- #tk_messageBox -title $dan(TITLE) -icon info -message newpath=$newpath
- set oldparent [string range $oldpath 0 [expr [string last "/" $oldpath]-1]]
- #tk_messageBox -title $dan(TITLE) -icon info -message oldparent=$oldparent
- set newparent [string range $newpath 0 [expr [string last "/" $newpath]-1]]
- #tk_messageBox -title $dan(TITLE) -icon info -message newparent=$newparent
-
- set pathlength [expr [string length $newpath]-1]
- if {[string range $newpath $pathlength $pathlength] eq "/"} {
- tk_messageBox -title $dan(TITLE) -icon info -message "Please delete the final '\/'!"
- return 0
- }
- if {[string first $dan(WORKDIR) $newpath] eq -1} {
- tk_messageBox -title $dan(TITLE) -icon info -message "New file path outside the Working Dir!"
- return 0
- }
- if {[string first $project(ROOT) $newpath] eq -1} {
- tk_messageBox -title $dan(TITLE) -icon info -message "New file path outside the Project Dir!"
- return 0
- }
-
- if {$oldparent ne $newparent} {
- tk_messageBox -title $dan(TITLE) -icon info -message "Change of parent folder disallowed!"
- return 0
- }
-
- if {[catch {file rename $oldpath $newpath} e]} {
- set msg "\nERROR in win:"
- puts \n$msg\n\n$e$::errorInfo\n
- set msg "$msg\n\n$e\n\nPlease, inform authors.\nDetails are in stdout."
- tk_messageBox -title $dan(TITLE) -icon error -message $msg
- return 0
- }
-
- # savind {field oldval newval} for later use
- editDialogField end $varname $oldpath $newpath
- ::radxide::tree::create
-
- # Workaround for an overwheling activation of the main text editor..
- if {$project(CUR_FILE_PATH) eq ""} {
- $dan(TEXT) configure -state disabled
- }
-
- catch {destroy [dlgPath]}
- return 1
- }
- # ________________________ renameFolderCancel _________________________ #
- proc renameFolderCancel {} {
-
- #catch {[destroy .danwin.diaRenameFolder1]}
- catch {[destroy [dlgPath]]}
-
- return 0
- }
- # ________________________ Replace_Tcl _________________________ #
- proc Replace_Tcl {r1 r2 r3 args} {
- # Replaces Tcl code with its resulting items in *lwidgets* list.
- # r1 - variable name for a current index in *lwidgets* list
- # r2 - variable name for a length of *lwidgets* list
- # r3 - variable name for *lwidgets* list
- # args - "tcl" and "tcl code" for "tcl" type of widget
- # The code should use the wildcard that goes first at a line:
- # %C - a command for inserting an item into lwidgets list.
- # The "tcl" widget type can be useful to automate the inserting
- # a list of similar widgets to the list of widgets.
- # See tests/test2_pave.tcl where the "tcl" fills "Color schemes" tab.
- lassign $args _name _code
- if {[ownWName $_name] ne {tcl}} {return $args}
- upvar 1 $r1 _ii $r2 _lwlen $r3 _lwidgets
- ; proc lwins {lwName i w} {
- upvar 2 $lwName lw
- set lw [linsert $lw $i $w]
- }
- set _lwidgets [lreplace $_lwidgets $_ii $_ii] ;# removes tcl item
- set _inext [expr {$_ii-1}]
- eval [string map {%C {lwins $r3 [incr _inext] }} $_code]
- return {}
- }
- # ________________________ removeOptions _________________________ #
- proc removeOptions {options args} {
- # Removes some options from a list of options.
- # options - list of options and values
- # args - list of option names to remove
- # The `options` may contain "key value" pairs and "alone" options
- # without values.
- # To remove "key value" pairs, `key` should be an exact name.
- # To remove an "alone" option, `key` should be a glob pattern with `*`.
- foreach key $args {
- while {[incr maxi]<99} {
- if {[set i [lsearch -exact $options $key]]>-1} {
- catch {
- # remove a pair "option value"
- set options [lreplace $options $i $i]
- set options [lreplace $options $i $i]
- }
- } elseif {[string first * $key]>=0 && \
- [set i [lsearch -glob $options $key]]>-1} {
- # remove an option only
- set options [lreplace $options $i $i]
- } else {
- break
- }
- }
- }
- return $options
- }
- # ________________________ res _________________________ #
- proc res {{win {}} {result get}} {
- # Gets/sets a variable for *vwait* command.
- # win - window's path
- # result - value of variable
- # This method is used when
- # - an event cycle should be stopped with changing a variable's value
- # - a result of event cycle (the variable's value) should be got
- # In the first case, *result* is set to an integer. In *apave* dialogs
- # the integer is corresponding a pressed button's index.
- # In the second case, *result* is omitted or equal to "get".
- # Returns a value of variable that controls an event cycle.
- if {$win eq {}} {set win [dlgPath]}
- set varname [WinVarname $win]
- if {$result eq {get}} {
- return [set $varname]
- }
- #CleanUps $win
- return [set $varname $result]
- }
- # ___________________ rockWindow _________________ #
- proc rockWindow {args} {
- # Processes "win / list_of_widgets" pairs.
- # args - list of pairs "win / lwidgets"
- # The *win* is a window's path. The *lwidgets* is a list of widget items.
- # Each widget item contains:
- # name - widget's name (first 3 characters define its type)
- # neighbor - top or left neighbor of the widget
- # posofnei - position of neighbor: T (top) or L (left)
- # rowspan - row span of the widget
- # colspan - column span of the widget
- # options - grid/pack options
- # attrs - attributes of widget
- # First 3 items are mandatory, others are set at need.
- # This method calls *paveWindow* in a cycle, to process a current "win/lwidgets" pair.
- namespace upvar ::radxide dan dan
- #tk_messageBox -title $dan(TITLE) -icon info -message "Start rock-Window!"
- set res [list]
- set wmain [set wdia {}]
- foreach {w lwidgets} $args {
- if {[lindex $lwidgets 0 0] eq {after}} {
- # if 1st item is "after idle" or like "after 1000", layout the window after...
- # (fit for "invisible independent" windows/frames/tabs)
- set what [lindex $lwidgets 0 1]
- if {$what eq {idle} || [string is integer -strict $what]} {
- after $what [rockWindow $w [lrange $lwidgets 1 end]]
- #after $what [list [self] colorWindow $w -doit]
- }
- continue
- }
- lappend res {*}[Window $w $lwidgets]
- if {[set ifnd [regexp -indices -inline {[.]dia\d+} $w]] ne {}} {
- set wdia [string range $w 0 [lindex $ifnd 0 1]]
- } else {
- set wmain .[lindex [split $w .] 1]
- }
- }
- # add a system Menu binding for the created window
- #if {[winfo exists $wdia]} {::apave::initPOP $wdia} elseif {
- # [winfo exists $wmain]} {::apave::initPOP $wmain}
- return $res
- }
- # ________________________ Search _________________________ #
- # proc Search {wtxt} {
- # # Searches a text for a string to find.
- # # wtxt - text widget's path
- #
- # namespace upvar ::alited obPav obPav
- # variable counts
- # variable data
- # set idx [$wtxt index insert]
- # #lassign [FindOptions $wtxt] findstr options
- # set options {}
- # set findstr $data(en1)
- # if {![CheckData find]} {return {}}
- # $obPav set_HighlightedString $findstr
- # SetTags $wtxt
- # lassign [Search1 $wtxt 1.0] err fnd
- # if {$err} {return {}}
- # set i 0
- # set res [list]
- # foreach index1 $fnd {
- # set index2 [$wtxt index "$index1 + [lindex $counts $i]c"]
- # if {[CheckWord $wtxt $index1 $index2]} {
- # lappend res [list $index1 $index2]
- # }
- # incr i
- # }
- # return $res
- # }
- #_______________________ selectedWordText _____________________ #
- proc selectedWordText {txt} {
- # Returns a word under the cursor or a selected text.
- # txt - the text's path
- set seltxt {}
- if {![catch {$txt tag ranges sel} seltxt]} {
- if {$seltxt eq ""} {return ""}
- set forword [expr {$seltxt eq {}}]
- #if {[set forword [expr {$seltxt eq {}}]]} {
- # set pos [$txt index "insert wordstart"]
- # set pos2 [$txt index "insert wordend"]
- # set seltxt [string trim [$txt get $pos $pos2]]
- # if {![string is wordchar -strict $seltxt]} {
- # # when cursor just at the right of word: take the word at the left
- # set pos [$txt index "insert -1 char wordstart"]
- # set pos2 [$txt index "insert -1 char wordend"]
- # }
- #} else {
- lassign $seltxt pos pos2
- #}
- #catch {
- set seltxt [$txt get $pos $pos2]
- if {[set sttrim [string trim $seltxt]] ne {}} {
- if {$forword} {set seltxt $sttrim}
- }
- #}
- }
- return $seltxt
- }
- # ________________________ setAppIcon _________________________ #
- proc setAppIcon {win {winicon ""}} {
- # Sets application's icon.
- # win - path to a window of application
- # winicon - data of icon
- # The *winicon* may be a contents of variable (as supposed by default) or
- # a file's name containing th image data.
- # If it fails to find an image in either, no icon is set.
- set appIcon {}
- if {$winicon ne {}} {
- if {[catch {set appIcon [image create photo -data $winicon]}]} {
- catch {set appIcon [image create photo -file $winicon]}
- }
- }
- if {$appIcon ne {}} {wm iconphoto $win -default $appIcon}
- }
- # ________________________ SetGetTexts _________________________ #
- proc SetGetTexts {oper w iopts lwidgets} {
- # Sets/gets contents of text fields.
- # oper - "set" to set, "get" to get contents of text field
- # w - window's name
- # iopts - equals to "" if no operation
- # lwidgets - list of widget items
- if {$iopts eq {}} return
- foreach widg $lwidgets {
- set wname [lindex $widg 0]
- set name [ownWName $wname]
- if {[string range $name 0 1] eq "te"} {
- set vv [::radxide::win::varName $name]
- if {$oper eq "set"} {
- displayText $w.$wname [set $vv]
- } else {
- set $vv [string trimright [$w.$wname get 1.0 end]]
- }
- }
- }
- return
- }
- # ________________________ set_HighlightedString _________________________ #
- proc set_HighlightedString {sel} {
- # Saves a string got from highlighting by Alt+left/right/q/w.
- # sel - the string to be saved
- set HLstring $sel
- if {$sel ne {}} {set Foundstr $sel}
- }
- # ________________________ set_highlight_matches _________________________ #
- proc set_highlight_matches {w} {
- # Creates bindings to highlight matches in a text.
- # w - path to the text
- }
- # ________________________ setNewLineWithIndent _________________________ #
- proc setNewLineWithIndent {} {
-
- namespace upvar ::radxide dan dan
-
- set wt $dan(TEXT)
- # getting previous line
- set idx1 [$wt index {insert linestart}]
- set idx2 [$wt index {insert lineend}]
- set line [$wt get $idx1 $idx2]
-
- # erasing tabs, replacing them with spaces..
- set line [string map {\t $dan(TAB_IN_SPACE)} $line]
- # calculating identation..
- set orilength [string length $line]
- set newlength [string length [string trimleft $line]]
- if {$newlength <= 0} {
- # case previous line is only spaces..
-
- set $newlength 0
- set nindent 0
-
- ::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 "#FFFFFF" "#222223"
- ::radxide::win::Yview {.danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText} scroll -1 units
- ::radxide::win::Yview {.danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText} scroll 1 units
-
- return 0
- } else {
-
- set nspacesofindent [expr $orilength - $newlength]
-
- # inserintg correct identation..
- $wt insert [$wt index {insert}] \n[string repeat " " $nspacesofindent]
- set idx3 [$wt index insert]
- set idx4 [$wt index "$idx3 +1 line"]
- ::tk::TextSetCursor $wt $idx3
-
- ::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 "#FFFFFF" "#222223"
- ::radxide::win::Yview {.danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText} scroll -1 units
- ::radxide::win::Yview {.danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText} scroll 1 units
-
- return -code break
- }
- }
-
- # ________________________ setTextBinds _________________________ #
- proc setTextBinds {wt} {
- # Returns bindings for a text widget.
- # wt - the text's path
- set res ""
- return $res
- }
- # ________________________ showModal _________________________ #
- proc showModal {win args} {
- # Shows a window as modal.
- # win - window's name
- # args - attributes of window ("-name value" pairs)
- namespace upvar ::radxide dan dan
-
- variable MODALWINDOW
- set MODALWINDOW [set Modalwin $win]
- setAppIcon $win
- lassign [extractOptions args -centerme {} -ontop 0 -modal yes -minsize {} \
- -themed {} -input 0 -variable {} -waitvar {} -transient {-} -root {} -parent {}] \
- centerme ontop modal minsize themed input varname waitvar transient root parent
- $win configure -bg $dan(BG) ;# removes blinking by default bg
- #if {$themed in {{} {0}} && [my csCurrent] != [apave::cs_Non]} {
- # my colorWindow $win
- #}
- if {$centerme eq {}} {
- # obsolete options: -root, -parent
- if {$root ne {}} {set centerme $root} {set centerme $parent}
- }
- set root [winfo parent $win]
- set rooted 1
- if {$centerme ne {}} {
- ;# forced centering relative to a caller's window
- lassign [split $centerme x+] rw rh rx ry
- set rooted [expr {![regexp {[+|-]+\d+\++} $centerme]}]
- if {$rooted && [winfo exist $centerme]} {
- set root $centerme
- }
- }
- set decor [expr {$root in {{} .}}]
- foreach {o v} [list -decor $decor -focus {} -onclose {} -geometry {} \
- -resizable {} -ontop 0 -escape 1 -checkgeometry 1] {
- lappend defargs $o [getShowOption $o $v]
- }
- if {$varname ne {}} {
- set waitvar 1
- } else {
- set waitvar [string is true $waitvar] ;# default 1: wait for closing the window
- set varname [WinVarname $win]
- }
- array set opt [list {*}$defargs {*}$args]
- if {$ontop eq {}} {
- if {$opt(-ontop)} {
- set ontop yes
- } else {
- set ontop no
- catch {
- set ontop [wm attributes [winfo parent $win] -topmost]
- }
- if {!$ontop} {
- # find if a window child of "." is topmost
- # if so, let this one be topmost too
- foreach w [winfo children .] {
- catch {set ontop [wm attributes $w -topmost]}
- if {$ontop} break
- }
- }
- }
- }
- if {$rooted} {
- lassign [splitGeometry [wm geometry [winfo toplevel $root]]] rw rh rx ry
- }
- if {$transient ne {-}} {
- wm transient $win $transient
- } elseif {!$opt(-decor)} {
- wm transient $win $root
- }
- if {[set destroy [expr {$opt(-onclose) eq {destroy}}]]} {
- set opt(-onclose) {}
- }
- if {$opt(-onclose) eq {}} {
- set opt(-onclose) "set $varname 0"
- } else {
- set opt(-onclose) "$opt(-onclose) $varname" ;# $opt(-onclose) is a command
- }
- #if {$destroy} {append opt(-onclose) " ; destroy $win"}
- if {$destroy} {append opt(-onclose) " ; destroy $win"}
- if {$opt(-resizable) ne {}} {
- if {[string is boolean $opt(-resizable)]} {
- set opt(-resizable) "$opt(-resizable) $opt(-resizable)"
- }
- wm resizable $win {*}$opt(-resizable)
- }
- if {!($modal || $waitvar)} {
- append opt(-onclose) "; CleanUps $win"
- }
- wm protocol $win WM_DELETE_WINDOW $opt(-onclose)
- # get the window's geometry from its requested sizes
- set inpgeom $opt(-geometry)
- if {$inpgeom eq {}} {
- # this is for less blinking:
- set opt(-geometry) [centeredXY $win $rw $rh $rx $ry \
- [winfo reqwidth $win] [winfo reqheight $win]]
- } elseif {[string first pointer $inpgeom]==0} {
- lassign [split $inpgeom+0+0 +] -> x y
- set inpgeom +[expr {$x+[winfo pointerx .]}]+[expr {$y+[winfo pointery .]}]
- set opt(-geometry) $inpgeom
- } elseif {[string first root $inpgeom]==0} {
- set root .[string trimleft [string range $inpgeom 5 end] .]
- set opt(-geometry) [set inpgeom {}]
- }
- if {$opt(-geometry) ne {}} {
- lassign [splitGeometry $opt(-geometry) {} {}] - - x y
- if {$x ne {}} {wm geometry $win $x$y}
- }
- if {$opt(-focus) eq {}} {
- set opt(-focus) $win
- }
- set $varname {-}
- if {$opt(-escape)} {bind $win <Escape> $opt(-onclose)}
- update
- if {![winfo exists $win]} {
- return 0 ;# looks idiotic, yet possible at sporadic calls
- }
- set w [winfo reqwidth $win]
- set h [winfo reqheight $win]
- if {$inpgeom eq {}} { ;# final geometrizing with actual sizes
- set geo [centeredXY $win $rw $rh $rx $ry $w $h]
- set y [lindex [split $geo +] end]
- if {!$rooted || $root ne {.} && (($h/2-$ry-$rh/2)>30 || [::radxide::iswindows] && $y>0)} {
- # ::tk::PlaceWindow needs correcting in rare cases, namely:
- # when 'root' is of less sizes than 'win' and at screen top
- wm geometry $win $geo
- } else {
- ::tk::PlaceWindow $win widget $root
- }
- } else {
- lassign [splitGeometry $inpgeom {} {}] - - x y
- if {$x ne {} && $y ne {} && [string first x $inpgeom]<0 && $opt(-checkgeometry)} {
- set inpgeom [checkXY $win $w $h $x $y]
- } elseif {$x eq {} && $y eq {} && $centerme ne {} && $opt(-geometry) ne {}} {
- lassign [split $opt(-geometry) x+] w h
- lassign [split [centeredXY $win $rw $rh $rx $ry $w $h] +] -> x y
- set inpgeom ${w}x$h+$x+$y
- }
- wm geometry $win $inpgeom
- }
- after 50 [list if "\[winfo exist $opt(-focus)\]" "focus -force $opt(-focus)"]
- #if {[info exists ::transpops::my::cntwait]} {
- # # this specific bind - for transpops package (to hide a demo message by keys)
- # bind $win <Control-Alt-0> {set ::transpops::my::cntwait 0}
- #}
- showWindow $win $modal $ontop $varname $minsize $waitvar
- set res 0
- #catch {
- if {$modal || $waitvar} {CleanUps $win}
- if {[winfo exists $win]} {
- if {$input} {GetOutputValues}
- set res [set [set _ $varname]]
- }
- #}
- return $res
- }
- # ________________________ showWindow _________________________ #
- proc showWindow {win modal ontop {var ""} {minsize ""} {waitvar 1}} {
- # Displays a windows and goes in tkwait cycle to interact with a user.
- # win - the window's path
- # modal - yes at showing the window as modal
- # ontop - yes at showing the window as topmost
- # var - variable's name to receive a result (tkwait's variable)
- # minsize - list {minwidth minheight} or {}
- # waitvar - if yes, force tkwait variable (mostly for non-modal windows)
- InfoWindow [expr {[InfoWindow] + 1}] $win $modal $var yes
- #::apave::deiconify $win
- if {$minsize eq {}} {
- set minsize [list [winfo width $win] [winfo height $win]]
- }
- wm minsize $win {*}$minsize
- bind $win <Configure> "[namespace current]::WinResize $win"
- if {$ontop} {wm attributes $win -topmost 1}
- if {$modal} {
- # modal window:
- waitWinVar $win $var $modal
- InfoWindow [expr {[InfoWindow] - 1}] $win $modal $var
- } else {
- # non-modal window:
- if {[set wgr [grab current]] ne {}} {
- # otherwise the non-modal window is irresponsive (in Windows even at WM level):
- grab release $wgr
- }
- if {$waitvar && $var ne {}} {
- waitWinVar $win $var $modal ;# show and wait for closing the window
- }
- }
- }
- # ________________________ setShowOption _________________________ #
- proc setShowOption {name args} {
- # Sets / gets a default show option, used in showModal.
- # name - name of option
- # args - value of option
- # See also: showModal
- setProperty [ShowOption $name] {*}$args
- }
- # ________________________ setProperty _________________________ #
- proc setProperty {name args} {
- # Sets a property's value as "application-wide".
- # name - name of property
- # args - value of property
- # If *args* is omitted, the method returns a property's value.
- # If *args* is set, the method sets a property's value as $args.
- variable _AP_Properties
- switch -exact [llength $args] {
- 0 {return [getProperty $name]}
- 1 {return [set _AP_Properties($name) [lindex $args 0]]}
- }
- puts -nonewline stderr \
- "Wrong # args: should be \"::win::setProperty propertyname ?value?\""
- return -code error
- }
- # ________________________ ShowOption _________________________ #
- proc ShowOption {name} {
- # Gets a default show option, used in showModal.
- # name - name of option
- # See also: getShowOption, setShowOption
- return "_SHOWMODAL_$name"
- }
- # ________________________ SpanConfig _________________________ #
- proc SpanConfig {w rcnam rc rcspan opt val} {
- # The method is used by *GetIntOptions* method to configure
- # row/column for their *span* options.
- for {set i $rc} {$i < ($rc + $rcspan)} {incr i} {
- eval [grid ${rcnam}configure $w $i $opt $val]
- }
- return
- }
- # ________________________ splitGeometry _________________________ #
- proc splitGeometry {geom {X +0} {Y +0}} {
- # Gets widget's geometry components.
- # geom - geometry
- # X - default X-coordinate
- # Y - default Y-coordinate
- # Returns a list of width, height, X and Y (coordinates are always with + or -).
- lassign [split $geom x+-] w h
- lassign [regexp -inline -all {([+-][[:digit:]]+)} $geom] -> x y
- if {$geom ne {}} {
- if {$x in {"" 0} || [catch {expr {$x+0}}]} {set x $X}
- if {$y in {"" 0} || [catch {expr {$y+0}}]} {set y $Y}
- }
- return [list $w $h $x $y]
- }
- # ________________________ textChanConfigure _________________________ #
- proc textChanConfigure {channel {coding {}} {eol {}}} {
- # Configures a channel for text file.
- # channel - the channel
- # coding - if set, defines encoding of the file
- # eol - if set, defines EOL of the file
- if {$coding eq {}} {
- chan configure $channel -encoding utf-8
- } else {
- chan configure $channel -encoding $coding
- }
- if {$eol eq {}} {
- chan configure $channel {*}[textEOL translation]
- } else {
- chan configure $channel -translation $eol
- }
- }
- # ________________________ textEOL _________________________ #
- proc textEOL {{EOL "-"}} {
- # Gets/sets End-of-Line for text reqding/writing.
- # EOL - LF, CR, CRLF or {}
- # If EOL omitted or equals to {} or "-", return the current EOL.
- # If EOL equals to "translation", return -translation option or {}.
- variable _PU_opts
- if {$EOL eq "-"} {return $_PU_opts(_EOL_)}
- if {$EOL eq "translation"} {
- if {$_PU_opts(_EOL_) eq ""} {return ""}
- return "-translation $_PU_opts(_EOL_)"
- }
- set _PU_opts(_EOL_) [string trim [string tolower $EOL]]
- }
- # ________________________ TreSelect _________________________ #
- proc TreSelect {w idx} {
- # Selects a treeview item.
- # w - treeview's path
- # idx - item index
- set items [$w children {}]
- catch {
- set it [lindex $items $idx]
- $w see $it
- $w focus $it
- $w selection set $it ;# generates <<TreeviewSelect>>
- }
- }
- # ________________________ varName _________________________ #
- proc varName {wname} {
- # Gets a variable name associated with a widget's name of "input" dialogue.
- # wname - widget's name
- return [namespace current]::var$wname
- }
-
- # ________________________ waitWinVar _________________________ #
- proc waitWinVar {win var modal} {
- # Tk waiting for variable's change.
- # win - the window's path
- # var - variable's name to receive a result (tkwait's variable)
- # modal - yes at showing the window as modal
- # first of all, wait till the window be visible
- after 1 ;# solves an issue with doubleclicking buttons
- if {![winfo viewable $win]} {
- tkwait visibility $win
- }
- set wmain [winfo parent $win]
- if {$modal} { ;# for modal, grab the window
- set wgr [grab current]
- if {$wmain ne {} && $wmain ne $win} {
- if {[catch {grab set $win} e]} {
- catch {tkwait visibility $win} ;# 2nd attempt to get the window visible, by force
- catch {grab set $win} ;# (not sure, where it can fire, still let it be)
- puts stderr "\n::radxide::win::waitWinVar - please send a note to apave developers on this catch. Error: $e"
- catch {puts stderr "::radxide::win::waitWinVar - [info level -1]\n"}
- }
- }
- }
- # at need, wait till the window associated variable be changed
- if {$var ne {}} {
- tkwait variable $var
- }
- if {$modal} { ;# for modal, release the grab and restore the old one
- catch {grab release $win}
- if {$wgr ne {}} {
- catch {grab set $wgr}
- }
- }
- }
- # ________________________ widgetType _________________________ #
- proc widgetType {wnamefull options attrs} {
- # Gets the widget type based on 3 initial letters of its name. Also
- # fills the grid/pack options and attributes of the widget.
- # wnamefull - path to the widget
- # options - grid/pack options of the widget
- # attrs - attribute of the widget
- # Returns a list of items:
- # widget - Tk/Ttk widget name
- # options - grid/pack options of the widget
- # attrs - attribute of the widget
- # nam3 - 3 initial letters of widget's name
- # disabled - flag of *disabled* state
- set disabled [expr {[getOption -state {*}$attrs] eq {disabled}}]
- set pack $options
- set name [ownWName $wnamefull]
- #if {[info exists ::apave::_AP_VARS(ProSplash,type)] && \
- #$::apave::_AP_VARS(ProSplash,type) eq {}} {
- # set val [my progress_Go [incr ::apave::_AP_VARS(ProSplash,curvalue)] {} $name]
- #}
- set nam3 [string tolower [string index $name 0]][string range $name 1 2]
- if {[string index $nam3 1] eq "_"} {set k [string range $nam3 0 1]} {set k $nam3}
- lassign [defaultATTRS $k] defopts defattrs newtype
- set options "$defopts $options"
- set attrs "$defattrs $attrs"
- switch -glob -- $nam3 {
- #bts {
- # set widget ttk::frame
- # if {![info exists ::bartabs::NewBarID]} {package require bartabs}
- # set attrs "-bartabs {$attrs}"
- #}
- but {
- set widget ttk::button
- AddButtonIcon $name attrs
- }
- buT - btT {
- set widget button
- AddButtonIcon $name attrs
- }
- can {set widget canvas}
- chb {set widget ttk::checkbutton}
- swi {
- set widget ttk::checkbutton
- #if {![my apaveTheme]} {
- # set attrs "$attrs -style Switch.TCheckbutton"
- #}
- }
- chB {set widget checkbutton}
- cbx - fco {
- set widget ttk::combobox
- if {$nam3 eq {fco}} { ;# file content combobox
- set attrs [FCfieldValues $wnamefull $attrs]
- }
- set attrs [FCfieldAttrs $wnamefull $attrs -tvar]
- }
- ent {set widget ttk::entry}
- enT {set widget entry}
- fil - fiL -
- fis - fiS -
- dir - diR -
- fon - foN -
- clr - clR -
- dat - daT -
- sta -
- too -
- fra {
- # + frame for choosers and bars
- set widget ttk::frame
- }
- frA {
- set widget frame
- if {$disabled} {set attrs [removeOptions $attrs -state]}
- }
- ftx {set widget ttk::labelframe}
- gut {set widget canvas}
- lab {
- set widget ttk::label
- if {$disabled} {
- set grey lightgray
- set attrs "-foreground $grey $attrs"
- }
- lassign [parseOptions $attrs -link {} -style {} -font {}] \
- cmd style font
- if {$cmd ne {}} {
- set attrs "-linkcom {$cmd} $attrs"
- set attrs [removeOptions $attrs -link]
- }
- if {$style eq {} && $font eq {}} {
- set attrs "-font {$::radxide::dan(CHARFAMILY)} $attrs"
- } elseif {$style ne {}} {
- # some themes stumble at ttk styles, so bring their attrs directly
- set attrs [removeOptions $attrs -style]
- set attrs "[ttk::style configure $style] $attrs"
- }
- }
- laB {set widget label}
- lfr {set widget ttk::labelframe}
- lfR {
- set widget labelframe
- if {$disabled} {set attrs [removeOptions $attrs -state]}
- }
- lbx - flb {
- set widget listbox
- if {$nam3 eq {flb}} { ;# file content listbox
- set attrs [FCfieldValues $wnamefull $attrs]
- }
- set attrs "[FCfieldAttrs $wnamefull $attrs -lvar]"
- set attrs "[ListboxesAttrs $wnamefull $attrs]"
- AddPopupAttr $wnamefull attrs -entrypop 1
- foreach {ev com} {Home {LbxSelect %w 0} End {LbxSelect %w end}} {
- append attrs " -bindEC {<$ev> {$com}} "
- }
- }
- meb {set widget ttk::menubutton}
- meB {set widget menubutton}
- nbk {
- set widget ttk::notebook
- set attrs "-notebazook {$attrs}"
- }
- opc {
- # tk_optionCascade - example of "my method" widget
- # arguments: vname items mbopts precom args
- #set widget {tk_optionCascade}
- #set imax [expr {min(4,[llength $attrs])}]
- #for {set i 0} {$i<$imax} {incr i} {
- # set atr [lindex $attrs $i]
- # if {$i!=1} {
- # lset attrs $i \{$atr\}
- # } elseif {[llength $atr]==1 && [info exist $atr]} {
- # lset attrs $i [set $atr] ;# items stored in a variable
- # }
- #}
- }
- pan {set widget ttk::panedwindow
- if {[string first -w $attrs]>-1 && [string first -h $attrs]>-1} {
- # important for panes with fixed (customized) dimensions
- set attrs "-propagate {$options} $attrs"
- }
- }
- pro {set widget ttk::progressbar}
- rad {set widget ttk::radiobutton}
- raD {set widget radiobutton}
- sca {set widget ttk::scale}
- scA {set widget scale}
- sbh {set widget ttk::scrollbar}
- sbH {set widget scrollbar}
- sbv {set widget ttk::scrollbar}
- sbV {set widget scrollbar}
- scf {
- # if {![namespace exists ::apave::sframe]} {
- # namespace eval ::apave {
- # source [file join $::apave::apaveDir sframe.tcl]
- # }
- # }
- # # scrolledFrame - example of "my method" widget
- # set widget {my scrolledFrame}
- }
- seh {set widget ttk::separator}
- sev {set widget ttk::separator}
- siz {set widget ttk::sizegrip}
- spx - spX {
- if {$nam3 eq {spx}} {set widget ttk::spinbox} {set widget spinbox}
- lassign [::apave::parseOptions $attrs \
- -command {} -com {} -from {} -to {}] cmd cmd2 from to
- append cmd $cmd2
- lassign [::apave::extractOptions attrs -tip {} -tooltip {}] t1 t2
- set t2 "$t1$t2"
- if {$from ne {} || $to ne {}} {
- if {$t2 ne {}} {set t2 "\n $t2"}
- set t2 " $from .. $to $t2"
- }
- if {$t2 ne {}} {set t2 "-tip {$t2}"}
- append attrs " -onReturn {$UFF{$cmd} {$from} {$to}$UFF} $t2"
- }
- tbl { ;# tablelist
- package require tablelist
- set widget tablelist::tablelist
- set attrs "[FCfieldAttrs $wnamefull $attrs -lvar]"
- set attrs "[ListboxesAttrs $wnamefull $attrs]"
- }
- tex {set widget text
- if {[getOption -textpop {*}$attrs] eq {}} {
- AddPopupAttr $wnamefull attrs -textpop \
- [expr {[getOption -rotext {*}$attrs] ne {}}] -- disabled
- }
- lassign [parseOptions $attrs -ro {} -readonly {} -rotext {} \
- -gutter {} -gutterwidth 5 -guttershift 6] r1 r2 r3 g1 g2 g3
- set b1 [expr [string is boolean -strict $r1]]
- set b2 [expr [string is boolean -strict $r2]]
- if {($b1 && $r1) || ($b2 && $r2) || \
- ($r3 ne {} && !($b1 && !$r1) && !($b2 && !$r2))} {
- set attrs "-takefocus 0 $attrs"
- }
- set attrs [removeOptions $attrs -gutter -gutterwidth -guttershift]
- if {$g1 ne {}} {
- set attrs "$attrs -gutter {-canvas $g1 -width $g2 -shift $g3}"
- }
- }
- tre {
- set widget ttk::treeview
- foreach {ev com} {Home {TreSelect %w 0} End {TreSelect %w end}} {
- append attrs " -bindEC {<$ev> {$com}} "
- }
- }
- h_* {set widget ttk::frame}
- v_* {set widget ttk::frame}
- default {set widget $newtype}
- }
- #set attrs [GetMC $attrs]
- if {$nam3 in {cbx ent enT fco spx spX}} {
- # entry-like widgets need their popup menu
- set clearcom [lindex [parseOptions $attrs -clearcom -] 0]
- if {$clearcom eq {-}} {
- AddPopupAttr $wnamefull attrs -entrypop 0 readonly disabled
- }
- }
- if {[string first pack [string trimleft $pack]]==0} {
- catch {
- # try to expand -after option (if set as WidgetName instead widgetName)
- if {[set i [lsearch -exact $pack {-after}]]>=0} {
- set aft [lindex $pack [incr i]]
- if {[regexp {^[A-Z]} $aft]} {
- set aft [my $aft]
- set pack [lreplace $pack $i $i $aft]
- }
- }
- }
- set options $pack
- }
- set options [string trim $options]
- set attrs [list {*}$attrs]
- return [list $widget $options $attrs $nam3 $disabled]
- }
- # ________________________ WidgetNameFull _________________________ #
- proc WidgetNameFull {w name {an {}}} {
- # Gets a full name of a widget.
- # w - name of root widget
- # name - name of widget
- # an - additional prefix for name
- # See also: apave::sframe::content
- set wn [string trim [parentWName $name].$an[ownWName $name] .]
- set wnamefull $w.$wn
- set wcc canvas.container.content ;# sframe.tcl may be not sourced
- if {[set i1 [string first .scf $wnamefull]]>0 && \
- [set i2 [string first . $wnamefull $i1+1]]>0 && \
- [string first .$wcc. $wnamefull]<0} {
- # insert a container's name into a scrolled frame's child
- set wend [string range $wnamefull $i2 end]
- set wnamefull [string range $wnamefull 0 $i2]
- append wnamefull $wcc $wend
- }
- return $wnamefull
- }
- # ________________________ Window _________________________ #
- proc Window {w inplists} {
- # Paves the window with widgets.
- # w - window's name (path)
- # inplists - list of widget items (lists of widget data)
- # Contents of a widget's item:
- # name - widget's name (first 3 characters define its type)
- # neighbor - top (T) or left (L) neighbor of the widget
- # posofnei - position of neighbor: T (top) or L (left)
- # rowspan - row span of the widget
- # colspan - column span of the widget
- # options - grid/pack options
- # attrs - attributes of widget
- # First 3 items are mandatory, others are set at need.
- # Called by *paveWindow* method to process a portion of widgets.
- # The "portion" refers to a separate block of widgets such as
- # notebook's tabs or frames.
- namespace upvar ::radxide dan dan
- #tk_messageBox -title $dan(TITLE) -icon info -message "Start Window!"
- set lwidgets [list]
- # comments be skipped
- foreach lst $inplists {
- if {[string index $lst 0] ne {#}} {
- lappend lwidgets $lst
- }
- }
- set lused [list]
- set lwlen [llength $lwidgets]
- if {$lwlen<2 && [string trim $lwidgets "{} "] eq {}} {
- set lwidgets [list {fra - - - - {pack -padx 99 -pady 99}}]
- set lwlen 1
- }
- for {set i 0} {$i < $lwlen} {} {
- set lst1 [lindex $lwidgets $i]
- if {[Replace_Tcl i lwlen lwidgets {*}$lst1] ne {}} {incr i}
- }
- # firstly, normalize all names that are "subwidgets" (.lab for fra.lab)
- # also, "+" for previous neighbors
- set i [set lwlen [llength $lwidgets]]
- while {$i>1} {
- incr i -1
- set lst1 [lindex $lwidgets $i]
- lassign $lst1 name neighbor
- if {$neighbor eq {+}} {set neighbor [lindex $lwidgets $i-1 0]}
- lassign [NormalizeName name i lwidgets] name wname
- set neighbor [lindex [NormalizeName neighbor i lwidgets] 0]
- set lst1 [lreplace $lst1 0 1 $wname $neighbor]
- set lwidgets [lreplace $lwidgets $i $i $lst1]
- }
- for {set i 0} {$i < $lwlen} {} {
- # List of widgets contains data per widget:
- # widget's name,
- # neighbor widget, position of neighbor (T, L),
- # widget's rowspan and columnspan (both optional),
- # grid options, widget's attributes (both optional)
- set lst1 [lindex $lwidgets $i]
- #set lst1 [my Replace_chooser w i lwlen lwidgets {*}$lst1]
- #if {[set lst1 [my Replace_bar w i lwlen lwidgets {*}$lst1]] eq {}} {
- # incr i
- # continue
- #}
- lassign $lst1 name neighbor posofnei rowspan colspan options1 attrs1
- lassign [NormalizeName name i lwidgets] name wname
- set wname [MakeWidgetName $w $wname]
- if {$colspan eq {} || $colspan eq {-}} {
- set colspan 1
- if {$rowspan eq {} || $rowspan eq {-}} {
- set rowspan 1
- }
- }
- foreach ao {attrs options} {
- if {[catch {set $ao [uplevel 2 subst -nocommand -nobackslashes [list [set ${ao}1]]]}]} {
- set $ao [set ${ao}1]
- }
- }
- lassign [widgetType $wname $options $attrs] widget options attrs nam3 dsbl
- # The type of widget (if defined) means its creation
- # (if not defined, it was created after "makewindow" call
- # and before "window" call)
- if { !($widget eq {} || [winfo exists $widget])} {
- set attrs [GetAttrs $attrs $nam3 $dsbl]
- set attrs [ExpandOptions $attrs]
- # for scrollbars - set up the scrolling commands
- if {$widget in {ttk::scrollbar scrollbar}} {
- set neighbor [lindex [LowercaseWidgetName $neighbor] 0]
- set wneigb [WidgetNameFull $w $neighbor]
- if {$posofnei eq {L}} {
- $wneigb config -yscrollcommand "$wname set"
- set attrs "$attrs -com \\\{$wneigb yview\\\}"
- append options { -side right -fill y} ;# -after $wneigb"
- } elseif {$posofnei eq {T}} {
- $wneigb config -xscrollcommand "$wname set"
- set attrs "$attrs -com \\\{$wneigb xview\\\}"
- append options { -side bottom -fill x} ;# -before $wneigb"
- }
- set options [string map [list %w $wneigb] $options]
- }
- #% doctest 1
- #% set a "123 \\\\\\\\ 45"
- #% eval append b {*}$a
- #% set b
- #> 123\45
- #> doctest
- Pre attrs
- #set addcomms [my AdditionalCommands $w $wname attrs]
- eval $widget $wname {*}$attrs
- #my Post $wname $attrs
- #foreach acm $addcomms {{*}$acm}
- # for buttons and entries - set up the hotkeys (Up/Down etc.)
- #my DefineWidgetKeys $wname $widget
- }
- if {$neighbor eq {-} || $row < 0} {
- set row [set col 0]
- }
- # check for simple creation of widget (without pack/grid)
- if {$neighbor ne {#}} {
- set options [GetIntOptions $w $options $row $rowspan $col $colspan]
- set pack [string trim $options]
- if {[string first add $pack]==0} {
- set comm "[winfo parent $wname] add $wname [string range $pack 4 end]"
- {*}$comm
- } elseif {[string first pack $pack]==0} {
- set opts [string trim [string range $pack 5 end]]
- if {[string first forget $opts]==0} {
- pack forget {*}[string range $opts 6 end]
- } else {
- pack $wname {*}$opts
- }
- } else {
- grid $wname -row $row -column $col -rowspan $rowspan \
- -columnspan $colspan -padx 1 -pady 1 {*}$options
- }
- }
- lappend lused [list $name $row $col $rowspan $colspan]
- if {[incr i] < $lwlen} {
- lassign [lindex $lwidgets $i] name neighbor posofnei
- set neighbor [lindex [LowercaseWidgetName $neighbor] 0]
- set row -1
- foreach cell $lused {
- lassign $cell uname urow ucol urowspan ucolspan
- if {[lindex [LowercaseWidgetName $uname] 0] eq $neighbor} {
- set col $ucol
- set row $urow
- if {$posofnei eq {T} || $posofnei eq {}} {
- incr row $urowspan
- } elseif {$posofnei eq {L}} {
- incr col $ucolspan
- }
- }
- }
- }
- }
- return $lwidgets
- }
- # ________________________ WindowStatus _________________________ #
- proc WindowStatus {w name {val ""} {defval ""}} {
- # Sets/gets a status of window. The status is a value assigned to a name.
- # w - window's path
- # name - name of status
- # val - if blank, to get a value of status; otherwise a value to set
- # defval - default value (actual if the status not set beforehand)
- # Returns a value of status.
- # See also: IntStatus
- variable _AP_VARS
- if {$val eq {}} { ;# getting
- if {[info exist _AP_VARS($w,$name)]} {
- return $_AP_VARS($w,$name)
- }
- return $defval
- }
- return [set _AP_VARS($w,$name) $val] ;# setting
- }
- # ________________________ WinResize _________________________ #
- proc WinResize {win} {
- # Restricts the window's sizes (thus fixing Tk's issue with a menubar)
- # win - path to a window to be of restricted sizes
- if {[$win cget -menu] ne {}} {
- lassign [splitGeometry [wm geometry $win]] w h
- lassign [wm minsize $win] wmin hmin
- if {$w<$wmin && $h<$hmin} {
- set corrgeom ${wmin}x$hmin
- } elseif {$w<$wmin} {
- set corrgeom ${wmin}x$h
- } elseif {$h<$hmin} {
- set corrgeom ${w}x$hmin
- } else {
- return
- }
- wm geometry $win $corrgeom
- }
- return
- }
- # ________________________ WinVarname _________________________ #
- proc WinVarname {win} {
- # Gets a unique varname for a window.
- # win - window's path
- return [namespace current]::PV(_WIN_,$win)
- }
- # ________________________ withdraw _________________________ #
- proc withdraw {w} {
- # Does 'withdraw' for a window.
- # w - the window's path
- # See also: iconifyOption
- switch -- [iconifyOption] {
- none { ; # no withdraw/deiconify actions
- }
- Linux { ; # do it for Linux
- wm withdraw $w
- }
- Windows { ; # do it for Windows
- wm withdraw $w
- wm attributes $w -alpha 0.0
- }
- default { ; # do it depending on the platform
- wm withdraw $w
- if {[::radxide::iswindows]} {
- wm attributes $w -alpha 0.0
- }
- }
- }
- }
- # ________________________ #
- }
|