12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217 |
- ###########################################################
- # 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]]
- set dan(TOTLINES) $totlines
- 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
- }
- set oldval [$dan(GUTTEXT) yview]
- $dan(GUTTEXT) yview $dan(TOTLINES).0
- set dan(CUR_FILE_MAX_YVIEW) [lindex [$dan(GUTTEXT) yview] 0]
-
- # yyy
- #set t .danwin.fra.pan.fra3.body.text
- #$t config -state normal
- #$t delete 1.0 end
- #$t insert end $dan(CUR_FILE_MAX_YVIEW)
- #$t insert end ddd[expr {$dan(CUR_FILE_MAX_YVIEW) / $dan(TOTLINES)}]
- # end yyy
-
- #$dan(GUTTEXT) yview [lindex $oldval 1]
- $dan(GUTTEXT) yview moveto [lindex [$dan(TEXT) yview] 0]
- #$dan(TEXT) yview 1.0
- #set ww [list .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText]
- #.danwin.fra.pan.fra2.yscroll2 set {*}[.danwin.fra.pan.fra2.yscroll1 get]
- #catch {list $dan(GUTTEXT) yview moveto [string range [lindex [$dan(TEXT) yview] 0] 0 2]}
- #list ::radxide::win::Yview $ww yes {*}[.danwin.fra.pan.fra2.yscroll1 get]
-
- $canvas configure -state disabled
- catch {
- return -code break
- }
-
- #return 0
- }
- # ________________________ 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} {
-
- namespace upvar ::radxide dan dan
-
- 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]
- #.danwin.fra.pan.fra3.body.text delete 1.0 end
- #.danwin.fra.pan.fra3.body.text insert end [expr [lindex $args 0]]
- #if {[expr [lindex $args 0]] > [expr $dan(CUR_FILE_MAX_YVIEW) - 0.01]} { ;#yyy
- # ::radxide::win::Yview $widgets no moveto [lindex $args 1]
- #} else {
- ::radxide::win::Yview $widgets no moveto [lindex $args 0]
- #}
- }
-
- proc Yview {widgets callfromsbmaster args} {
-
- namespace upvar ::radxide dan dan
-
- foreach w $widgets {
- $w yview {*}$args
- }
-
- if ($callfromsbmaster) {
- #catch {list $dan(GUTTEXT) yview moveto [lindex [$dan(TEXT) yview] 0]}
- #catch {list $dan(GUTTEXT) yview moveto [string range [lindex [$dan(TEXT) yview] 0] 0 2]}
- }
- }
-
- 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]
- if {[string first " " $dan(TEXTFONT)]} {
- set myfont "\"$dan(TEXTFONT)\""
- } else {
- set myfont $dan(TEXTFONT)
- }
- set myfontsize $dan(TEXTFONTSIZE)
- text $w2.gutText -background "lightgray" -foreground "#222223" -font "$myfont $myfontsize" -width 5
- text $w2.text -font "$myfont $myfontsize" -bd 0 -padx 13 -spacing1 0 -spacing2 0 -spacing3 0 -exportselection yes -width 115 -wrap none -undo yes
- 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 yes]
- scrollbar $w2.yscroll1 -orient vertical \
- -command [list $w2.text yview]
- 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]
- #$w2.gutText configure -yscrollcommand [list ::radxide::win::Yset $ww slave $ssbb]
- 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)
- if {$dan(CURSORWIDTH) > 4} {
- $dan(TEXT) configure -blockcursor true
- } else {
- $dan(TEXT) configure -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) "<Enter>" "::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 #FFFFFF #222223 ;$dan(TEXT) yview [$dan(TEXT) index insert] ;$dan(GUTTEXT) yview moveto [lindex [$dan(TEXT) yview] 1]"
- #bind $dan(TEXT) "<BackSpace>" "::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 #FFFFFF #222223 ;$dan(TEXT) yview [$dan(TEXT) index insert] ;$dan(GUTTEXT) yview moveto [lindex [$dan(TEXT) yview] 1]"
- #bind $dan(TEXT) "<Delete>" "::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 #FFFFFF #222223 ;$dan(TEXT) yview [$dan(TEXT) index insert] ;$dan(GUTTEXT) yview moveto [lindex [$dan(TEXT) yview] 1]"
- 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}}
- bind $dan(TEXT) "<KeyPress>" {
- switch %K {
- #KP_Enter {
- # ::radxide::menu::edit::makeNewLine
- #}
- #Return {
- # ::radxide::menu::edit::makeNewLine
- #}
- Tab {
- ::radxide::menu::edit::Indent
- }
- Shift_L-Tab {
- ::radxide::menu::edit::UnIndent
- }
- ISO_Left_Tab {
- ::radxide::menu::edit::UnIndent
- }
- ISO_Right_Tab {
- ::radxide::menu::edit::UnIndent
- }
- #Shift_L {
- #}
- #Shift_R {
- #}
- #default {
- # tk_messageBox -title radxide -icon info -message %K
- #}
- }
- }
- bind $dan(TEXT) "<KeyRelease>" {
- switch %K {
- #KP_Enter {
- # ::radxide::menu::edit::makeNewLine
- #}
- #Return {
- # ::radxide::menu::edit::makeNewLine
- #}
- BackSpace {
- ::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 #FFFFFF #222223
- }
- Delete {
- ::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 #FFFFFF #222223
- }
- Cancel {
- ::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 #FFFFFF #222223
- }
- Tab {
- }
- #default {
- # tk_messageBox -title radxide -icon info -message %K
- #}
- }
- }
- }
- #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
- }
-
- # ________________________ 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
- }
- }
- }
- }
- # ________________________ #
- }
|