win.tcl 137 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217
  1. ###########################################################
  2. # Name: win.tcl
  3. # Author: Daniele Bonini (posta@elettronica.lol)
  4. # Date: 26/11/2023
  5. # Desc: Win namespace of RadXIDE.
  6. #
  7. # Win namespace scaffolding and most of the code
  8. # here presented and distributed contains excerpts
  9. # from [alited](https://github.com/aplsimple/alited
  10. # by Alex Plotnikov and contributors to the project.
  11. # The original code of these excerpts could be
  12. # borrowed from other sources which the author
  13. # and the contributors to this RadXIDE have no
  14. # knowledge about.
  15. #
  16. # License: MIT. Copyrights 5 Mode (Last implementation and adaptations.)
  17. # Copyright (c) 2021-2023 Alex Plotnikov https://aplsimple.github.io (original scaffolding and excerpts.)
  18. #
  19. ###########################################################
  20. namespace eval win {
  21. array set _PU_opts [list -NONE =NONE=]
  22. set _PU_opts(_MODALWIN_) [list]
  23. variable _AP_Properties; array set _AP_Properties [list]
  24. variable _AP_ICO { none folder OpenFile SaveFile saveall print font color \
  25. date help home misc terminal run tools file find replace other view \
  26. categories actions config pin cut copy paste plus minus add delete \
  27. change diagram box trash double more undo redo up down previous next \
  28. previous2 next2 upload download tag tagoff tree lock light restricted \
  29. attach share mail www map umbrella gulls sound heart clock people info \
  30. err warn ques retry yes no ok cancel exit }
  31. variable _AP_IMG; array set _AP_IMG [list]
  32. variable _AP_VARS; array set _AP_VARS [list]
  33. variable UFF "\uFFFF"
  34. variable querydlg {}
  35. variable CheckNomore
  36. array set msgarray [list]
  37. set Dlgpath ""
  38. set Dlgname ""
  39. set dlg(PATH) ""
  40. set dlg(NAME) ""
  41. set dlg(FIELDS) {}
  42. set Indexdlg 0
  43. set _savedvv [list]
  44. set MODALWINDOW {}
  45. set Foundstr {}
  46. # array set data [list]
  47. # set data(en1) {}
  48. # set data(docheck) yes
  49. set Foundstr {} ;# current found string
  50. set HLstring {} ;# current selected string
  51. set Widgetopts [list]
  52. set _Defaults [dict create \
  53. bts {{} {}} \
  54. but {{} {}} \
  55. buT {{} {-width -20 -pady 1}} \
  56. btT {{} {-width -20 -pady 1 -relief flat -overrelief raised -highlightthickness 0 -takefocus 0}} \
  57. can {{} {}} \
  58. chb {{} {}} \
  59. swi {{} {}} \
  60. chB {{} {-relief sunken -padx 6 -pady 2}} \
  61. cbx {{} {}} \
  62. fco {{} {}} \
  63. ent {{} {}} \
  64. enT {{} {-insertwidth $::apave::cursorwidth -insertofftime 250 -insertontime 750}} \
  65. fil {{} {}} \
  66. fis {{} {}} \
  67. dir {{} {}} \
  68. fon {{} {}} \
  69. clr {{} {}} \
  70. dat {{} {}} \
  71. fiL {{} {}} \
  72. fiS {{} {}} \
  73. diR {{} {}} \
  74. foN {{} {}} \
  75. clR {{} {}} \
  76. daT {{} {}} \
  77. sta {{} {}} \
  78. too {{} {}} \
  79. fra {{} {}} \
  80. ftx {{} {}} \
  81. frA {{} {}} \
  82. gut {{} {-width 0 -highlightthickness 1}} \
  83. lab {{-sticky w} {}} \
  84. laB {{-sticky w} {}} \
  85. lfr {{} {}} \
  86. lfR {{} {-relief groove}} \
  87. lbx {{} {-activestyle none -exportselection 0 -selectmode browse}} \
  88. flb {{} {}} \
  89. meb {{} {}} \
  90. meB {{} {}} \
  91. nbk {{} {}} \
  92. opc {{} {}} \
  93. pan {{} {}} \
  94. pro {{} {}} \
  95. rad {{} {}} \
  96. raD {{} {-padx 6 -pady 2}} \
  97. sca {{} {-orient horizontal -takefocus 0}} \
  98. scA {{} {-orient horizontal -takefocus 0}} \
  99. sbh {{-sticky ew} {-orient horizontal -takefocus 0}} \
  100. sbH {{-sticky ew} {-orient horizontal -takefocus 0}} \
  101. sbv {{-sticky ns} {-orient vertical -takefocus 0}} \
  102. sbV {{-sticky ns} {-orient vertical -takefocus 0}} \
  103. scf {{} {}} \
  104. seh {{-sticky ew} {-orient horizontal -takefocus 0}} \
  105. sev {{-sticky ns} {-orient vertical -takefocus 0}} \
  106. siz {{} {}} \
  107. spx {{} {}} \
  108. spX {{} {}} \
  109. tbl {{} {-selectborderwidth 1 -highlightthickness 2 \
  110. -labelcommand tablelist::sortByColumn -stretch all \
  111. -showseparators 1}} \
  112. tex {{} {-undo 1 -maxundo 0 -highlightthickness 2 -insertofftime 250 -insertontime 750 -insertwidth $::apave::cursorwidth -wrap word -selborderwidth 1 -exportselection 0}} \
  113. tre {{} {-selectmode browse}} \
  114. h_ {{-sticky ew -csz 3 -padx 3} {}} \
  115. v_ {{-sticky ns -rsz 3 -pady 3} {}}]
  116. set TexM {}
  117. # __________________________ AddButtonIcon _________________________ #
  118. proc AddButtonIcon {w attrsName} {
  119. # Gets the button's icon based on its text and name (e.g. butOK) and
  120. # appends it to the attributes of button.
  121. # w - button's name
  122. # attrsName - name of variable containing attributes of the button
  123. upvar 1 $attrsName attrs
  124. set com [getOption -com {*}$attrs]
  125. if {[string is integer -strict $com]} {
  126. extractOptions attrs -com {}
  127. append attrs " -com {::radxide::win::res {} $com}" ;# returned integer result
  128. }
  129. if {[getOption -image {*}$attrs] ne {}} return
  130. set txt [getOption -t {*}$attrs]
  131. if {$txt eq {}} { set txt [getOption -text {*}$attrs] }
  132. set im {}
  133. set icolist [list {exit abort} {exit close} \
  134. {SaveFile save} {OpenFile open}]
  135. # ok, yes, cancel, apply buttons should be at the end of list
  136. # as their texts can be renamed (e.g. "Help" in e_menu's "About")
  137. lappend icolist {*}[iconImage] {yes apply}
  138. foreach icon $icolist {
  139. lassign $icon ic1 ic2
  140. # text of button is of highest priority at defining its icon
  141. if {[string match -nocase $ic1 $txt] || \
  142. [string match -nocase b*t$ic1 $w] || ($ic2 ne {} && ( \
  143. [string match -nocase b*t$ic2 $w] || [string match -nocase $ic2 $txt]))} {
  144. if {[string match -nocase btT* $w]} {
  145. set cmpd none
  146. } else {
  147. set cmpd left
  148. }
  149. append attrs " [iconA $ic1 small $cmpd]"
  150. break
  151. }
  152. }
  153. return
  154. }
  155. # __________________ AddPopupAttr ________________#
  156. proc AddPopupAttr {w attrsName atRO isRO args} {
  157. # Adds the attribute to call a popup menu for an editable widget.
  158. # w - widget's name
  159. # attrsName - variable name for attributes of widget
  160. # atRO - "readonly" attribute (internally used)
  161. # isRO - flag of readonly widget
  162. # args - widget states to be checked
  163. upvar 1 $attrsName attrs
  164. lassign $args state state2
  165. if {$state2 ne {}} {
  166. if {[getOption -state {*}$attrs] eq $state2} return
  167. set isRO [expr {$isRO || [getOption -state {*}$attrs] eq $state}]
  168. }
  169. if {$isRO} {append atRO RO}
  170. append attrs " $atRO $w"
  171. return
  172. }
  173. # __________________________ AppendButtons _________________________ #
  174. proc AppendButtons {widlistName buttons neighbor pos defb timeout win modal} {
  175. # Adds buttons to the widget list from a position of neighbor widget.
  176. # widlistName - variable name for widget list
  177. # buttons - buttons to add
  178. # neighbor - neighbor widget
  179. # pos - position of neighbor widget
  180. # defb - default button
  181. # timeout - timeout (to count down seconds and invoke a button)
  182. # win - dialogue's path
  183. # modal - yes if the window is modal
  184. # Returns list of "Help" button's name and command.
  185. upvar $widlistName widlist
  186. namespace upvar ::radxide dan dan
  187. variable Dlgpath
  188. set Defb1 [set Defb2 [set bhlist {}]]
  189. foreach {but txt res} $buttons {
  190. #set com "res $Dlgpath"
  191. #set com "::radxide::win::res $Dlgpath"
  192. #if {[info commands $res] eq {}} {
  193. # set com "$com $res"
  194. #} else {
  195. # if {$res eq {destroy}} {
  196. # # for compatibility with old modal windows
  197. # if {$modal} {set res "$com 0"} {set res "destroy $win"}
  198. # }
  199. # set com $res ;# "res" is set as a command
  200. #}
  201. set com $res
  202. if {$but eq {butHELP}} {
  203. # Help button contains the command in "res"
  204. set com [string map "%w $win" $res]
  205. set bhlist [list $but $com]
  206. } elseif {$Defb1 eq {}} {
  207. set Defb1 $but
  208. } elseif {$Defb2 eq {}} {
  209. set Defb2 $but
  210. }
  211. if {[set _ [string first "::" $txt]]>-1} {
  212. set tt " -tip {[string range $txt $_+2 end]}"
  213. set txt [string range $txt 0 $_-1]
  214. } else {
  215. set tt {}
  216. }
  217. if {$timeout ne {} && ($defb eq $but || $defb eq {})} {
  218. set tmo "-timeout {$timeout}"
  219. } else {
  220. set tmo {}
  221. }
  222. if {$but eq {butHELP}} {
  223. set neighbor [lindex $widlist end 1]
  224. set widlist [lreplace $widlist end end]
  225. lappend widlist [list $but $neighbor T 1 1 {-st w} \
  226. "-t \"$txt\" -com \"$com\"$tt $tmo -tip F1"]
  227. set h h_Help
  228. lappend widlist [list $h $but L 1 94 {-st we}]
  229. set neighbor $h
  230. } else {
  231. lappend widlist [list $but $neighbor $pos 1 1 {-st we} \
  232. "-t \"$txt\" -com \"$com\"$tt $tmo"]
  233. set neighbor $but
  234. }
  235. set pos L
  236. }
  237. lassign [LowercaseWidgetName $Dlgpath.fra.$Defb1] Defb1
  238. lassign [LowercaseWidgetName $Dlgpath.fra.$Defb2] Defb2
  239. return $bhlist
  240. }
  241. # __________________________ appendDialogField _________________________ #
  242. proc addDialogField {fldname oldval newval} {
  243. variable dlg
  244. set newlist [list $fldname $oldval $newval]
  245. set dlg(FIELDS) [linsert $dlg(FIELDS) end $newlist]
  246. }
  247. # __________________________ basicFontSize _________________________ #
  248. proc basicFontSize {{fs 0} {ds 0}} {
  249. # Gets/Sets a basic size of font used in apave
  250. # fs - font size
  251. # ds - incr/decr of size
  252. # If 'fs' is omitted or ==0, this method gets it.
  253. # If 'fs' >0, this method sets it.
  254. namespace upvar ::radxide dan dan
  255. #if {$fs} {
  256. # set ::radxide::_CS_(fs) [expr {$fs + $ds}]
  257. # my create_Fonts
  258. # return $::radxide::_CS_(fs)
  259. #} else {
  260. # return [expr {$::radxide::_CS_(fs) + $ds}]
  261. #}
  262. return $dan(CHARSIZE)
  263. }
  264. # __________________________ basicDefFont _________________________ #
  265. proc basicDefFont {{deffont ""}} {
  266. # Gets/Sets a basic default font.
  267. # deffont - font
  268. # If 'deffont' is omitted or =="", this method gets it.
  269. # If 'deffont' is set, this method sets it.
  270. namespace upvar ::radxide dan dan
  271. #if {$deffont ne ""} {
  272. # return [set ::apave::_CS_(defFont) $deffont]
  273. #} else {
  274. # return $::apave::_CS_(defFont)
  275. #}
  276. return $dan(CHARFAMILY)
  277. }
  278. # __________________________ basicTextFont _________________________ #
  279. proc basicTextFont {{textfont ""}} {
  280. # Gets/Sets a basic font used in editing/viewing text widget.
  281. # textfont - font
  282. # If 'textfont' is omitted or =="", this method gets it.
  283. # If 'textfont' is set, this method sets it.
  284. namespace upvar ::radxide dan dan
  285. #if {$textfont ne ""} {
  286. # return [set ::apave::_CS_(textFont) $textfont]
  287. #} else {
  288. # return $::apave::_CS_(textFont)
  289. #}
  290. return $dan(CHARFAMILY)
  291. }
  292. # __________________________ checkXY _________________________ #
  293. proc checkXY {win w h x y} {
  294. # Checks the coordinates of window (against the screen).
  295. # w - width of window
  296. # h - height of window
  297. # x - window's X coordinate
  298. # y - window's Y coordinate
  299. # Returns new coordinates in +X+Y form.
  300. # check for left/right edge of screen (accounting decors)
  301. set scrw [expr {[winfo vrootwidth $win] - 12}]
  302. set scrh [expr {[winfo vrootheight $win] - 36}]
  303. if {($x + $w) > $scrw } {
  304. set x [expr {$scrw - $w}]
  305. }
  306. if {($y + $h) > $scrh } {
  307. set y [expr {$scrh - $h}]
  308. }
  309. if {![string match -* $x]} {set x +[string trimleft $x +]}
  310. if {![string match -* $y]} {set y +[string trimleft $y +]}
  311. return ${x}x${y}
  312. }
  313. # _________________________ centeredXY ________________________ #
  314. proc centeredXY {win rw rh rx ry w h} {
  315. # Gets the coordinates of centered window (against its parent).
  316. # rw - parent's width
  317. # rh - parent's height
  318. # rx - parent's X coordinate
  319. # ry - parent's Y coordinate
  320. # w - width of window to be centered
  321. # h - height of window to be centered
  322. # Returns centered coordinates in +X+Y form.
  323. set x [expr {max(0, $rx + ($rw - $w) / 2)}]
  324. set y [expr {max(0,$ry + ($rh - $h) / 2)}]
  325. return [checkXY $win $w $h $x $y]
  326. }
  327. # ________________________ centerWin _________________________ #
  328. proc centerWin {win wwidth wheight} {
  329. namespace upvar ::radxide dan dan
  330. set screen_width [winfo screenwidth $win]
  331. set screen_height [winfo screenheight $win]
  332. #tk_messageBox -title $dan(TITLE) -icon error -message $screen_width
  333. set half_screen_w [expr {0}]
  334. if {[expr {$screen_width/$screen_height} > 2]} {
  335. set half_screen_w [expr {$screen_width/2}]
  336. set wrong_geo [centeredXY $win $half_screen_w $screen_height 0 0 $wwidth $wheight]
  337. } else {
  338. set wrong_geo [centeredXY $win $screen_width $screen_height 0 0 $wwidth $wheight]
  339. }
  340. #set geo [string map {x ""} $geo]
  341. #wm geometry $dan(WIN) "=$dan(WIDTH)x$dan(HEIGHT)$geo"
  342. wm geometry $win =${wwidth}x${wheight}
  343. # Lets do it modal:
  344. set offsetx [winfo x $win]
  345. set offsety [winfo y $win]
  346. set disinfox [winfo pointerx [winfo parent $win]]
  347. #tk_messageBox -title $dan(TITLE) -icon error -message $disinfox
  348. #tk_messageBox -title $dan(TITLE) -icon error -message $half_screen_w
  349. set display [expr {1}]
  350. if { $disinfox>$half_screen_w } {
  351. set display [expr {2}]
  352. }
  353. #tk_messageBox -title $dan(TITLE) -icon error -message $display
  354. set newx [expr {($half_screen_w-$wwidth)/2}]
  355. if {$display>1} {
  356. set newx [expr {$half_screen_w+(($half_screen_w-$wwidth)/2)}]
  357. }
  358. #tk_messageBox -title $dan(TITLE) -icon error -message newx=$newx
  359. set newy [expr {70}]
  360. wm geometry $win +$newx+$newy
  361. }
  362. #_______________________ CheckData _______________________ #
  363. # proc CheckData {op} {
  364. # # Checks if the find/replace data are valid.
  365. # # op - if "repl", checks for "Replace" operation
  366. # # Return "yes", if the input data are valid.
  367. #
  368. # namespace upvar :radxide dan dan
  369. #
  370. # variable data
  371. #
  372. # # this means "no checks when used outside of the dialogue":
  373. # if {!$data(docheck)} {return yes}
  374. #
  375. # set ret yes
  376. # if {[set data(en1)] eq {}} { set ret no }
  377. # if {[set data(en1)] > $dan(MAXFINDLENGTH)} { set ret no }
  378. #
  379. # if {$ret eq no} {
  380. # # if find/replace field is empty, let the bell tolls for him
  381. # bell
  382. # return no
  383. # }
  384. # return yes
  385. # }
  386. # ________________________ CleanUps _________________________ #
  387. proc CleanUps {{wr ""}} {
  388. }
  389. proc danInitDialogs {} {
  390. namespace upvar ::radxide dan dan
  391. variable Dlgpath
  392. variable Dlgname
  393. variable dlg
  394. variable Indexdlg
  395. set Dlgpath ""
  396. set Dlgname ""
  397. set dlg(PATH) ""
  398. set dlg(NAME) ""
  399. set dlg(FIELDS) {}
  400. set Indexdlg 0
  401. }
  402. # ________________________ defaultATTRS _________________________ #
  403. proc defaultATTRS {{type ""} {opts ""} {atrs ""} {widget ""}} {
  404. # Sets, gets or registers default options and attributes for widget type.
  405. # type - widget type
  406. # opts - new default grid/pack options
  407. # atrs - new default attributes
  408. # widget - Tcl/Tk command for the new registered widget type
  409. # The *type* should be a three letter unique string.
  410. # If the *type* is absent in the registered types and *opts* and/or *atrs*
  411. # is not set to "", defaultATTRS registers the new *type* with its grid/pack
  412. # options and attributes. At that *widget* is a command for the new widget
  413. # type. For example, to register "toolbutton" widget:
  414. # my defaultATTRS tbt {} {-style Toolbutton -compound top} ttk::button
  415. # Options and attributes may contain data (variables and commands)
  416. # to be processed by [subst].
  417. # Returns:
  418. # - if not set *type*: a full list of options and attributes of all types
  419. # - if set *type* only: a list of options, attributes and *widget*
  420. # - else: a list of updated options, attributes and *widget*
  421. variable _Defaults
  422. if {$type eq {}} {return $_Defaults}
  423. set optatr "$opts$atrs"
  424. if {[catch {set def1 [dict get $_Defaults $type]}]} {
  425. if {$optatr eq {}} {
  426. set err "[self method]: \"$type\" widget type not registered."
  427. puts -nonewline stderr $err
  428. return -code error $err
  429. }
  430. set def1 [list $opts $atrs $widget]
  431. }
  432. if {$optatr eq {}} {return [subst $def1]}
  433. lassign $def1 defopts defatrs widget
  434. if {[catch {set defopts [dict replace $defopts {*}$opts]}]} {
  435. set defopts [string trim "$defopts $opts"]
  436. }
  437. if {[catch {set defatrs [dict replace $defatrs {*}$atrs]}]} {
  438. set defatrs [string trim "$defatrs $atrs"]
  439. }
  440. set newval [list $defopts $defatrs $widget]
  441. dict set _Defaults $type $newval
  442. return $newval
  443. }
  444. # ________________________ defaultAttrs _________________________ #
  445. proc defaultAttrs {{type ""} {opts ""} {atrs ""} {widget ""}} {
  446. # Sets, gets or registers default options and attributes for widget type.
  447. # type - widget type
  448. # opts - new default grid/pack options
  449. # atrs - new default attributes
  450. # widget - Tcl/Tk command for the new registered widget type
  451. # See also: APaveBase::defaultATTRS
  452. return [defaultATTRS $type $opts $atrs $widget]
  453. }
  454. # ________________________ dlgPath _________________________ #
  455. proc dlgPath {} {
  456. # Gets a current dialogue's path.
  457. # In fact, it does the same as [my dlgPath], but it can be
  458. # called outside of apave dialogue object (useful sometimes).
  459. namespace upvar ::radxide dan dan
  460. #variable Dlgpath
  461. # xxx
  462. variable Dlgname
  463. variable Indexdlg
  464. set Winpath $dan(WIN)
  465. # xxx
  466. #set wdia $Winpath.dia
  467. set wdia $Winpath.dia$Dlgname$Indexdlg
  468. return [set dlg(PATH) [set Dlgpath $wdia]]
  469. }
  470. # ________________________ DiaWidgetNameter _________________________ #
  471. proc DiaWidgetName {w} {
  472. # Gets a widget name of apave dialogue.
  473. # w - name of widget
  474. # The name of widget may be partial. In this case it's prepended
  475. # the current dialogue's frame path.
  476. # Useful in "input" dialogue when -method option is present
  477. # or widget names are uppercased.
  478. # See also: MakeWidgetName, input
  479. if {[string index $w 0] eq {.}} {return $w}
  480. return $Dlgpath.fra.$w
  481. }
  482. # ________________________ displayTaggedText _________________________ #
  483. proc displayTaggedText {w contsName {tags ""}} {
  484. # Sets the text widget's contents using tags (ornamental details).
  485. # w - text widget's name
  486. # contsName - variable name for contents to be set in the widget
  487. # tags - list of tags to be applied to the text
  488. # The lines in *text contents* are divided by \n and can include
  489. # *tags* like in a html layout, e.g. <red>RED ARMY</red>.
  490. # The *tags* is a list of "name/value" pairs. 1st is a tag's name, 2nd
  491. # is a tag's value.
  492. # The tag's name is "pure" one (without <>) so e.g.for <b>..</b> the tag
  493. # list contains "b".
  494. # The tag's value is a string of text attributes (-font etc.).
  495. # If the tag's name is FG, FG2, BG or BG2, then it is really a link color.
  496. }
  497. # ________________________ displayText _________________________ #
  498. proc displayText {w conts {pos 1.0}} {
  499. # Sets the text widget's contents.
  500. # w - text widget's name
  501. # conts - contents to be set in the widget
  502. if {[set state [$w cget -state]] ne {normal}} {
  503. $w configure -state normal
  504. }
  505. $w replace 1.0 end $conts
  506. $w edit reset; $w edit modified no
  507. if {$state eq {normal}} {
  508. ::tk::TextSetCursor $w $pos
  509. } else {
  510. $w configure -state $state
  511. }
  512. return
  513. }
  514. # __________________________ editDialogField _________________________ #
  515. proc editDialogField {index fldname oldval newval} {
  516. namespace upvar ::radxide dan dan
  517. variable dlg
  518. set newlist {$fldname $oldval $newval}
  519. lset dlg(FIELDS) $index $newlist
  520. }
  521. # ________________________ ExpandOptions _________________________ #
  522. proc ExpandOptions {options} {
  523. # Expands shortened options.
  524. set options [string map {
  525. { -st } { -sticky }
  526. { -com } { -command }
  527. { -t } { -text }
  528. { -w } { -width }
  529. { -h } { -height }
  530. { -var } { -variable }
  531. { -tvar } { -textvariable }
  532. { -lvar } { -listvariable }
  533. { -ro } { -readonly }
  534. } " $options"]
  535. return $options
  536. }
  537. # ________________________ error _________________________ #
  538. proc error {{fileName ""}} {
  539. # Gets the error's message at reading/writing.
  540. # fileName - if set, return a full error messageat opening file
  541. variable _PU_opts
  542. if {$fileName eq ""} {
  543. return $_PU_opts(_ERROR_)
  544. }
  545. return "Error of access to\n\"$fileName\"\n\n$_PU_opts(_ERROR_)"
  546. }
  547. # ________________________ extractOption _________________________ #
  548. proc extractOptions {optsVar args} {
  549. # Gets options' values and removes the options from the input list.
  550. # optsVar - variable name for the list of options and values
  551. # args - list of "option / default value" pairs
  552. # Returns a list of options' values, according to args.
  553. # See also: parseOptions
  554. upvar 1 $optsVar opts
  555. set retlist [parseOptions $opts {*}$args]
  556. foreach {o v} $args {
  557. set opts [removeOptions $opts $o]
  558. }
  559. return $retlist
  560. }
  561. # ________________________ FCfieldAttrs _________________________ #
  562. proc FCfieldAttrs {wnamefull attrs varopt} {
  563. # Fills the non-standard attributes of file content widget.
  564. # wnamefull - a widget name
  565. # attrs - a list of all attributes
  566. # varopt - a variable option
  567. # The *varopt* refers to a variable part such as tvar, lvar:
  568. # * -inpval option means an initial value of the field
  569. # * -retpos option has p1:p2 format (e.g. 0:10) to cut a substring from a returned value
  570. # Returns *attrs* without -inpval and -retpos options.
  571. # xxx
  572. variable Widgetopts
  573. lassign [parseOptions $attrs $varopt {} -retpos {} -inpval {}] \
  574. vn rp iv
  575. if {[string first {-state disabled} $attrs]<0 && $vn ne {}} {
  576. set all {}
  577. if {$varopt eq {-lvar}} {
  578. lassign [extractOptions attrs -values {} -ALL 0] iv a
  579. if {[string is boolean -strict $a] && $a} {set all ALL}
  580. lappend Widgetopts "-lbxname$all $wnamefull $vn"
  581. }
  582. if {$rp ne {}} {
  583. if {$all ne {}} {set rp 0:end}
  584. lappend Widgetopts "-retpos $wnamefull $vn $rp"
  585. }
  586. }
  587. if {$iv ne {}} { set $vn $iv }
  588. return [removeOptions $attrs -retpos -inpval]
  589. }
  590. # ________________________ FCfieldValues _________________________ #
  591. proc FCfieldValues {wnamefull attrs} {
  592. # Fills the file content widget's values.
  593. # wnamefull - name (path) of fco widget
  594. # attrs - attributes of the widget
  595. ; proc readFCO {fname} {
  596. # Reads a file's content.
  597. # Returns a list of (non-empty) lines of the file.
  598. if {$fname eq {}} {
  599. set retval {{}}
  600. } else {
  601. set retval {}
  602. foreach ln [split [readTextFile $fname {} 1] \n] {
  603. # probably, it's bad idea to have braces in the file of contents
  604. set ln [string map [list \\ \\\\ \{ \\\{ \} \\\}] $ln]
  605. if {$ln ne {}} {lappend retval $ln}
  606. }
  607. }
  608. return $retval
  609. }
  610. ; proc contFCO {fline opts edge args} {
  611. # Given a file's line and options,
  612. # cuts a substring from the line.
  613. # xxx
  614. variable Widgetopts
  615. lassign [parseOptionsFile 1 $opts {*}$args] opts
  616. lassign $opts - - - div1 - div2 - pos - len - RE - ret
  617. set ldv1 [string length $div1]
  618. set ldv2 [string length $div2]
  619. set i1 [expr {[string first $div1 $fline]+$ldv1}]
  620. set i2 [expr {[string first $div2 $fline]-1}]
  621. set filterfile yes
  622. if {$ldv1 && $ldv2} {
  623. if {$i1<0 || $i2<0} {return $edge}
  624. set retval [string range $fline $i1 $i2]
  625. } elseif {$ldv1} {
  626. if {$i1<0} {return $edge}
  627. set retval [string range $fline $i1 end]
  628. } elseif {$ldv2} {
  629. if {$i2<0} {return $edge}
  630. set retval [string range $fline 0 $i2]
  631. } elseif {$pos ne {} && $len ne {}} {
  632. set retval [string range $fline $pos $pos+[incr len -1]]
  633. } elseif {$pos ne {}} {
  634. set retval [string range $fline $pos end]
  635. } elseif {$len ne {}} {
  636. set retval [string range $fline 0 $len-1]
  637. } elseif {$RE ne {}} {
  638. set retval [regexp -inline $RE $fline]
  639. if {[llength $retval]>1} {
  640. foreach r [lrange $retval 1 end] {append retval_tmp $r}
  641. set retval $retval_tmp
  642. } else {
  643. set retval [lindex $retval 0]
  644. }
  645. } else {
  646. set retval $fline
  647. set filterfile no
  648. }
  649. if {$retval eq {} && $filterfile} {return $edge}
  650. set retval [string map [list "\}" "\\\}" "\{" "\\\{"] $retval]
  651. return [list $retval $ret]
  652. }
  653. set edge $Edge
  654. set ldv1 [string length $edge]
  655. set filecontents {}
  656. set optionlists {}
  657. set tplvalues {}
  658. set retpos {}
  659. set values [getOption -values {*}$attrs]
  660. if {[string first $edge $values]<0} { ;# if 1 file, edge
  661. set values "$edge$values$edge" ;# may be omitted
  662. }
  663. # get: files' contents, files' options, template line
  664. set lopts {-list {} -div1 {} -div2 {} -pos {} -len {} -RE {} -ret 0}
  665. while {1} {
  666. set i1 [string first $edge $values]
  667. set i2 [string first $edge $values $i1+1]
  668. if {$i1>=0 && $i2>=0} {
  669. incr i1 $ldv1
  670. append tplvalues [string range $values 0 $i1-1]
  671. set fdata [string range $values $i1 $i2-1]
  672. lassign [parseOptionsFile 1 $fdata {*}$lopts] fopts fname
  673. lappend filecontents [readFCO $fname]
  674. lappend optionlists $fopts
  675. set values [string range $values $i2+$ldv1 end]
  676. } else {
  677. append tplvalues $values
  678. break
  679. }
  680. }
  681. # fill the combobox lines, using files' contents and options
  682. if {[set leno [llength $optionlists]]} {
  683. set newvalues {}
  684. set ilin 0
  685. lassign $filecontents firstFCO
  686. foreach fline $firstFCO { ;# lines of first file for a base
  687. set line {}
  688. set tplline $tplvalues
  689. for {set io 0} {$io<$leno} {incr io} {
  690. set opts [lindex $optionlists $io]
  691. if {$ilin==0} { ;# 1st cycle: add items from -list option
  692. lassign $opts - list1 ;# -list option goes first
  693. if {[llength $list1]} {
  694. foreach l1 $list1 {append newvalues "\{$l1\} "}
  695. lappend Widgetopts "-list $wnamefull [list $list1]"
  696. }
  697. }
  698. set i1 [string first $edge $tplline]
  699. if {$i1>=0} {
  700. lassign [contFCO $fline $opts $edge {*}$lopts] retline ret
  701. if {$ret ne "0" && $retline ne $edge && \
  702. [string first $edge $line]<0} {
  703. set p1 [expr {[string length $line]+$i1}]
  704. if {$io<($leno-1)} {
  705. set p2 [expr {$p1+[string length $retline]-1}]
  706. } else {
  707. set p2 end
  708. }
  709. set retpos "-retpos $p1:$p2"
  710. }
  711. append line [string range $tplline 0 $i1-1] $retline
  712. set tplline [string range $tplline $i1+$ldv1 end]
  713. } else {
  714. break
  715. }
  716. set fline [lindex [lindex $filecontents $io+1] $ilin]
  717. }
  718. if {[string first $edge $line]<0} {
  719. # put only valid lines into the list of values
  720. append newvalues "\{$line$tplline\} "
  721. }
  722. incr ilin
  723. }
  724. # replace old 'values' attribute with the new 'values'
  725. lassign [parseOptionsFile 2 $attrs -values \
  726. [string trimright $newvalues]] attrs
  727. }
  728. return "$attrs $retpos"
  729. }
  730. # ________________________ fillGutter _________________________ #
  731. proc fillGutter {txt {canvas ""} {width ""} {shift ""} fg bg} {
  732. # Fills a gutter of text with the text's line numbers.
  733. # txt - path to the text widget
  734. # canvas - canvas of the gutter
  735. # width - width of the gutter, in chars
  736. # shift - addition to the width (to shift from the left side)
  737. # args - additional arguments for tracing
  738. # The code is borrowed from open source tedit project.
  739. namespace upvar ::radxide dan dan
  740. $canvas configure -state normal
  741. if {$canvas eq {}} {
  742. event generate $txt <Configure> ;# repaints the gutter
  743. return
  744. }
  745. set i 1
  746. set gcont [list]
  747. set totlines [expr [$txt count -lines 0.0 end]]
  748. set dan(TOTLINES) $totlines
  749. while true {
  750. if {$i > $totlines} break
  751. #set dline [$txt dlineinfo $i] ;# xxx
  752. set dline [$txt get [lindex [split $i .] 0].0 [lindex [split $i .] 0].end]
  753. #if {[llength $dline] == 0} break
  754. #set height [lindex $dline 3] ;# xxx
  755. #set y [expr {[lindex $dline 1]}] ;# xxx
  756. set linenum [format "%${width}d" [lindex [split $i .] 0]]
  757. #set i [$txt index "$i +1 lines linestart"] # xxx
  758. #lappend gcont [list $y $linenum\n]
  759. lappend gcont [list [lindex [split $i .] 0] [expr {$linenum}]\n]
  760. incr i
  761. }
  762. set newwidth $dan(GUTTERWIDTH);
  763. $canvas delete 1.0 end
  764. set y [expr {0}]
  765. foreach g $gcont {
  766. lassign $g y linenum
  767. $canvas insert [expr {$y}].0 $linenum
  768. }
  769. set oldval [$dan(GUTTEXT) yview]
  770. $dan(GUTTEXT) yview $dan(TOTLINES).0
  771. set dan(CUR_FILE_MAX_YVIEW) [lindex [$dan(GUTTEXT) yview] 0]
  772. # yyy
  773. #set t .danwin.fra.pan.fra3.body.text
  774. #$t config -state normal
  775. #$t delete 1.0 end
  776. #$t insert end $dan(CUR_FILE_MAX_YVIEW)
  777. #$t insert end ddd[expr {$dan(CUR_FILE_MAX_YVIEW) / $dan(TOTLINES)}]
  778. # end yyy
  779. #$dan(GUTTEXT) yview [lindex $oldval 1]
  780. $dan(GUTTEXT) yview moveto [lindex [$dan(TEXT) yview] 0]
  781. #$dan(TEXT) yview 1.0
  782. #set ww [list .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText]
  783. #.danwin.fra.pan.fra2.yscroll2 set {*}[.danwin.fra.pan.fra2.yscroll1 get]
  784. #catch {list $dan(GUTTEXT) yview moveto [string range [lindex [$dan(TEXT) yview] 0] 0 2]}
  785. #list ::radxide::win::Yview $ww yes {*}[.danwin.fra.pan.fra2.yscroll1 get]
  786. $canvas configure -state disabled
  787. catch {
  788. return -code break
  789. }
  790. #return 0
  791. }
  792. # ________________________ FieldName _________________________ #
  793. proc FieldName {name} {
  794. # Gets a field name.
  795. return fraM.fra$name.$name
  796. }
  797. # ________________________ findInText ___________________________ #
  798. proc findInText {{donext 0} {txt ""} {varFind ""} {dobell yes}} {
  799. # Finds a string in text widget.
  800. # donext - "1" means 'from a current position'
  801. # txt - path to the text widget
  802. # varFind - variable
  803. # dobell - if yes, bells
  804. # Returns yes, if found (or nothing to find), otherwise returns "no";
  805. # also, if there was a real search, the search string is added.
  806. namespace upvar ::radxide dan dan
  807. variable Foundstr
  808. if {$txt eq {}} {
  809. set txt $dan(TEXT)
  810. set sel $Foundstr
  811. } elseif {$donext && [set sel [get_HighlightedString]] ne {}} {
  812. # find a string got with alt+left/right
  813. } elseif {$varFind eq {}} {
  814. set sel $Foundstr
  815. } else {
  816. set sel [set $varFind]
  817. }
  818. if {$donext} {
  819. set pos [$txt index insert]
  820. if {{sel} in [$txt tag names $pos]} {
  821. set pos [$txt index "$pos + 1 chars"]
  822. }
  823. set pos [$txt search -- $sel $pos end]
  824. } else {
  825. set pos {}
  826. set_HighlightedString {}
  827. }
  828. if {![string length "$pos"]} {
  829. set pos [$txt search -- $sel 1.0 end]
  830. }
  831. if {[string length "$pos"]} {
  832. ::tk::TextSetCursor $txt $pos
  833. $txt tag add sel $pos [$txt index "$pos + [string length $sel] chars"]
  834. #focus $txt
  835. set res yes
  836. } else {
  837. if {$dobell} bell
  838. set res no
  839. }
  840. return [list $res $sel]
  841. }
  842. # ________________________ findTextOK _________________________ #
  843. proc findTextOK {} {
  844. namespace upvar ::radxide dan dan
  845. variable dlg
  846. variable data
  847. variable Foundstr
  848. set wt $dan(TEXT)
  849. #if {$inv>-1} {set data(lastinvoke) $inv}
  850. #set t $Dlgpath.fra.fraM.fraent.ent
  851. set t [dlgPath].fra.[FieldName [lindex [getDialogField 0] 0]]
  852. #tk_messageBox -title $dan(TITLE) -icon info -message textbox=$t
  853. set varname [lindex [getDialogField end] 0]
  854. #tk_messageBox -title $dan(TITLE) -icon info -message varname=$varname
  855. set oldsearchtext [lindex [getDialogField end] 1]
  856. #tk_messageBox -title $dan(TITLE) -icon info -message oldsearchtext=$oldsearchtext
  857. set newsearchtext [string trim [$t get]]
  858. #tk_messageBox -title $dan(TITLE) -icon info -message newsearchtext=$newsearchtext
  859. set Foundstr $newsearchtext
  860. findInText 1 $wt
  861. #ShowResults1 [FindAll $wt]
  862. return 1
  863. }
  864. # ________________________ findTextCancel _________________________ #
  865. proc findTextCancel {} {
  866. #catch {[destroy .danwin.diaRenameFile1]}
  867. catch {[destroy [dlgPath]]}
  868. return 0
  869. }
  870. # ________________________ GetAttrs _________________________ #
  871. proc GetAttrs {options {nam3 ""} {disabled 0} } {
  872. # Expands attributes' values.
  873. # options - list of attributes and values
  874. # nam3 - first three letters (type) of widget's name
  875. # disabled - flag of "disabled" state
  876. # Returns expanded attributes.
  877. set opts [list]
  878. foreach {opt val} [list {*}$options] {
  879. switch -exact -- $opt {
  880. -t - -text {
  881. ;# these options need translating \\n to \n
  882. # catch {set val [subst -nocommands -novariables $val]}
  883. set val [string map [list \\n \n \\t \t] $val]
  884. set opt -text
  885. }
  886. -st {set opt -sticky}
  887. -com {set opt -command}
  888. -w {set opt -width}
  889. -h {set opt -height}
  890. -var {set opt -variable}
  891. -tvar {set opt -textvariable}
  892. -lvar {set opt -listvariable}
  893. -ro {set opt -readonly}
  894. }
  895. lappend opts $opt \{$val\}
  896. }
  897. if {$disabled} {
  898. append opts [NonTtkStyle $nam3 1]
  899. }
  900. return $opts
  901. }
  902. # ________________________ get_HighlightedString _________________________ #
  903. proc get_HighlightedString {} {
  904. # Returns a string got from highlighting by Alt+left/right/q/w.
  905. variable HLstring
  906. if {[info exists HLstring]} {
  907. return $HLstring
  908. }
  909. return {}
  910. }
  911. # ________________________ GetIntOptions _________________________ #
  912. proc GetIntOptions {w options row rowspan col colspan} {
  913. # Gets specific integer options. Then expands other options.
  914. # w - widget's name
  915. # options - grid options
  916. # row, rowspan - row and its span of thw widget
  917. # col, colspan - column and its span of thw widget
  918. # The options are set in grid options as "-rw <int>", "-cw <int>" etc.
  919. # Returns the resulting grid options.
  920. set opts {}
  921. foreach {opt val} [list {*}$options] {
  922. switch -exact -- $opt {
  923. -rw {SpanConfig $w row $row $rowspan -weight $val}
  924. -cw {SpanConfig $w column $col $colspan -weight $val}
  925. -rsz {SpanConfig $w row $row $rowspan -minsize $val}
  926. -csz {SpanConfig $w column $col $colspan -minsize $val}
  927. -ro {SpanConfig $w column $col $colspan -readonly $val}
  928. default {append opts " $opt $val"}
  929. }
  930. }
  931. # Get other grid options
  932. return [ExpandOptions $opts]
  933. }
  934. # ________________________ GetLinkLab _________________________ #
  935. proc GetLinkLab {m} {
  936. # Gets a link for label.
  937. # m - label with possible link (between <link> and </link>)
  938. # Returns: list of "pure" message and link for label.
  939. if {[set i1 [string first "<link>" $m]]<0} {
  940. return [list $m]
  941. }
  942. set i2 [string first "</link>" $m]
  943. set link [string range $m $i1+6 $i2-1]
  944. set m [string range $m 0 $i1-1][string range $m $i2+7 end]
  945. return [list $m [list -link $link]]
  946. }
  947. # ________________________ getOption _________________________ #
  948. proc getOption {optname args} {
  949. # Extracts one option from an option list.
  950. # optname - option name
  951. # args - option list
  952. # Returns an option value or "".
  953. # Example:
  954. # set options [list -name some -value "any value" -tip "some tip"]
  955. # set optvalue [::apave::getOption -tip {*}$options]
  956. set optvalue [lindex [parseOptions $args $optname ""] 0]
  957. return $optvalue
  958. }
  959. # ________________________ GetOutputValues _________________________ #
  960. proc GetOutputValues {} {
  961. # Makes output values for some widgets (lbx, fco).
  962. # Some i/o widgets need a special method to get their returned values.
  963. # xxx
  964. variable Widgetopts
  965. foreach aop $Widgetopts {
  966. lassign $aop optnam vn v1 v2
  967. switch -glob -- $optnam {
  968. -lbxname* {
  969. # To get a listbox's value, its methods are used.
  970. # The widget may not exist when an apave object is used for
  971. # several dialogs which is a bad style (very very bad).
  972. if {[winfo exists $vn]} {
  973. lassign [$vn curselection] s1
  974. if {$s1 eq {}} {set s1 0}
  975. set w [string range $vn [string last . $vn]+1 end]
  976. if {[catch {set v0 [$vn get $s1]}]} {set v0 {}}
  977. if {$optnam eq {-lbxnameALL}} {
  978. # when -ALL option is set to 1, listbox returns
  979. # a list of 3 items - sel index, sel contents and all contents
  980. set $v1 [list $s1 $v0 [set $v1]]
  981. } else {
  982. set $v1 $v0
  983. }
  984. }
  985. }
  986. -retpos { ;# a range to cut from -tvar/-lvar variable
  987. lassign [split $v2 :] p1 p2
  988. set val1 [set $v1]
  989. # there may be -list option for this widget
  990. # then if the value is from the list, it's fully returned
  991. foreach aop2 $Widgetopts {
  992. lassign $aop2 optnam2 vn2 lst2
  993. if {$optnam2 eq {-list} && $vn eq $vn2} {
  994. foreach val2 $lst2 {
  995. if {$val1 eq $val2} {
  996. set p1 0
  997. set p2 end
  998. break
  999. }
  1000. }
  1001. break
  1002. }
  1003. }
  1004. set $v1 [string range $val1 $p1 $p2]
  1005. }
  1006. }
  1007. }
  1008. return
  1009. }
  1010. # __________________________ getDialogField _________________________ #
  1011. proc getDialogField {index} {
  1012. variable dlg
  1013. set ret [lindex $dlg(FIELDS) $index]
  1014. return $ret
  1015. }
  1016. #_______________________ getProperty _______________________#
  1017. proc getProperty {name {defvalue ""}} {
  1018. # Gets a property's value as "application-wide".
  1019. # name - name of property
  1020. # defvalue - default value
  1021. # If the property had been set, the method returns its value.
  1022. # Otherwise, the method returns the default value (`$defvalue`).
  1023. variable _AP_Properties
  1024. if {[info exists _AP_Properties($name)]} {
  1025. return $_AP_Properties($name)
  1026. }
  1027. return $defvalue
  1028. }
  1029. # ________________________ getShowOption _________________________ #
  1030. proc getShowOption {name {defval ""}} {
  1031. # Gets a default show option, used in showModal.
  1032. # name - name of option
  1033. # defval - default value
  1034. # See also: showModal
  1035. getProperty [ShowOption $name] $defval
  1036. }
  1037. # ________________________ GetVarsValues _________________________ #
  1038. proc GetVarsValues {lwidgets} {
  1039. # Gets values of entries passed (or set) in -tvar.
  1040. # lwidgets - list of widget items
  1041. set res [set vars [list]]
  1042. foreach wl $lwidgets {
  1043. set ownname [ownWName [lindex $wl 0]]
  1044. set vv [varName $ownname]
  1045. set attrs [lindex $wl 6]
  1046. if {[string match "ra*" $ownname]} {
  1047. # only for widgets with a common variable (e.g. radiobuttons):
  1048. foreach t {-var -tvar} {
  1049. if {[set v [getOption $t {*}$attrs]] ne {}} {
  1050. array set a $attrs
  1051. set vv $v
  1052. }
  1053. }
  1054. }
  1055. if {[info exist $vv] && [lsearch $vars $vv]==-1} {
  1056. lappend res [set $vv]
  1057. lappend vars $vv
  1058. }
  1059. }
  1060. return $res
  1061. }
  1062. # ________________________ GotoLineOK _________________________ #
  1063. proc GotoLineOK {} {
  1064. namespace upvar ::radxide dan dan
  1065. variable dlg
  1066. set wt $dan(TEXT)
  1067. set lmax [expr {int([$wt index "end -1c"])}]
  1068. #set t $Dlgpath.fra.fraM.fraent.ent
  1069. set t [dlgPath].fra.[FieldName [lindex [getDialogField 0] 0]]
  1070. #tk_messageBox -title $dan(TITLE) -icon info -message textbox=$t
  1071. set varname [lindex [getDialogField end] 0]
  1072. #tk_messageBox -title $dan(TITLE) -icon info -message varname=$varname
  1073. set oldlinenumber [lindex [getDialogField end] 1]
  1074. #tk_messageBox -title $dan(TITLE) -icon info -message oldlinenumber=$oldlinenumber
  1075. set newlinenumber [string trim [$t get]]
  1076. #tk_messageBox -title $dan(TITLE) -icon info -message newlinenumber=$newlinenumber
  1077. if {$newlinenumber>$lmax} {
  1078. tk_messageBox -title $dan(TITLE) -icon info -message "Line $newlinenumber doesn't exist $newlinenumber>MAXLINES."
  1079. return 0
  1080. }
  1081. ::tk::TextSetCursor $wt 0.0
  1082. after 200 "tk::TextSetCursor $wt [expr $newlinenumber].0"
  1083. catch {[destroy [dlgPath]]}
  1084. return 1
  1085. }
  1086. # ________________________ GotoLineCancel _________________________ #
  1087. proc GotoLineCancel {} {
  1088. #catch {[destroy .danwin.diaRenameFile1]}
  1089. catch {[destroy [dlgPath]]}
  1090. return 0
  1091. }
  1092. # ________________________ iconImage _________________________ #
  1093. proc iconA {icon {iconset small} {cmpd left}} {
  1094. # Gets icon attributes for buttons, menus etc.
  1095. # icon - name of icon
  1096. # iconset - one of small/middle/large
  1097. # cmpd - value of -compound option
  1098. # The *iconset* is "small" for menus (recommended and default).
  1099. return "-image [iconImage $icon $iconset] -compound $cmpd"
  1100. }
  1101. # ________________________ iconifyOption _________________________ #
  1102. proc iconifyOption {args} {
  1103. # Gets/sets "-iconify" option.
  1104. # args - if contains no arguments, gets "-iconify" option; otherwise sets it
  1105. # Option values mean:
  1106. # none - do nothing: no withdraw/deiconify
  1107. # Linux - do withdraw/deiconify for Linux
  1108. # Windows - do withdraw/deiconify for Windows
  1109. # default - do withdraw/deiconify depending on the platform
  1110. # See also: withdraw, deiconify
  1111. if {[llength $args]} {
  1112. set iconify [setShowOption -iconify $args]
  1113. } else {
  1114. set iconify [getShowOption -iconify]
  1115. }
  1116. return $iconify
  1117. }
  1118. # ________________________ iconImage _________________________ #
  1119. proc iconImage {{icon ""} {iconset "small"} {doit no}} {
  1120. # Gets a defined icon's image or list of icons.
  1121. # If *icon* equals to "-init", initializes apave's icon set.
  1122. # icon - icon's name
  1123. # iconset - one of small/middle/large
  1124. # doit - force the initialization
  1125. # Returns the icon's image or, if *icon* is blank, a list of icons
  1126. # available in *apave*.
  1127. variable _AP_IMG
  1128. variable _AP_ICO
  1129. return folder
  1130. # if {$icon eq {}} {return $_AP_ICO}
  1131. # ; proc imagename {icon} { # Get a defined icon's image name
  1132. # return _AP_IMG(img$icon)
  1133. # }
  1134. # variable apaveDir
  1135. # if {![array size _AP_IMG] || $doit} {
  1136. # # Make images of icons
  1137. # source [file join $apaveDir apaveimg.tcl]
  1138. # if {$iconset ne "small"} {
  1139. # foreach ic $_AP_ICO { ;# small icons best fit for menus
  1140. # set _AP_IMG($ic-small) [set _AP_IMG($ic)]
  1141. # }
  1142. # if {$iconset eq "middle"} {
  1143. # source [file join $apaveDir apaveimg2.tcl]
  1144. # } else {
  1145. # source [file join $apaveDir apaveimg2.tcl] ;# TODO
  1146. # }
  1147. # }
  1148. # foreach ic $_AP_ICO {
  1149. # if {[catch {image create photo [imagename $ic] -data [set _AP_IMG($ic)]}]} {
  1150. # # some png issues on old Tk
  1151. # image create photo [imagename $ic] -data [set _AP_IMG(none)]
  1152. # } elseif {$iconset ne "small"} {
  1153. # image create photo [imagename $ic-small] -data [set _AP_IMG($ic-small)]
  1154. # }
  1155. # }
  1156. # }
  1157. # if {$icon eq "-init"} {return $_AP_ICO} ;# just to get to icons
  1158. # if {$icon ni $_AP_ICO} {set icon [lindex $_AP_ICO 0]}
  1159. # if {$iconset eq "small" && "_AP_IMG(img$icon-small)" in [image names]} {
  1160. # set icon $icon-small
  1161. # }
  1162. # return [imagename $icon]
  1163. }
  1164. # ________________________ InfoFind _________________________ #
  1165. proc InfoFind {w modal} {
  1166. # Searches data of a window in a list of registered windows.
  1167. # w - root window's path
  1168. # modal - yes, if the window is modal
  1169. # Returns: the window's path or "" if not found.
  1170. # See also: InfoWindow
  1171. variable _PU_opts
  1172. foreach winfo [lrange $_PU_opts(_MODALWIN_) 1 end] { ;# skip 1st window
  1173. incr i
  1174. lassign $winfo w1 var1 modal1
  1175. if {[winfo exists $w1]} {
  1176. if {$w eq $w1 && ($modal && $modal1 || !$modal && !$modal1)} {
  1177. return $w1
  1178. }
  1179. } else {
  1180. catch {set _PU_opts(_MODALWIN_) [lreplace $_PU_opts(_MODALWIN_) $i $i]}
  1181. }
  1182. }
  1183. return {}
  1184. }
  1185. # ________________________ InitFindInText _________________________ #
  1186. proc InitFindInText { {ctrlf 0} {txt {}} } {
  1187. # Initializes the search in the text.
  1188. # ctrlf - "1" means that the method is called by Ctrl+F
  1189. # txt - path to the text widget
  1190. namespace upvar ::radxide dan dan
  1191. variable Foundstr
  1192. if {$txt eq {}} {set txt $dan(TEXT)}
  1193. #if {$ctrlf} { ;# Ctrl+F moves cursor 1 char ahead
  1194. # ::tk::TextSetCursor $txt [$txt index "insert -1 char"]
  1195. #}
  1196. if {[set seltxt [selectedWordText $txt]] ne {}} {
  1197. set Foundstr $seltxt
  1198. }
  1199. return $Foundstr
  1200. }
  1201. # ________________________ initInput _________________________ #
  1202. proc initInput {} {
  1203. # Initializes input and clears variables made in previous session.
  1204. variable _savedvv
  1205. # xxx
  1206. variable Widgetopts
  1207. foreach {vn vv} $_savedvv {
  1208. catch {unset $vn}
  1209. }
  1210. set _savedvv [list]
  1211. set Widgetopts [list]
  1212. return
  1213. }
  1214. proc InfoWindow {{val ""} {w .} {modal no} {var ""} {regist no}} {
  1215. # Registers/unregisters windows. Also sets/gets 'count of open modal windows'.
  1216. # val - current number of open modal windows
  1217. # w - root window's path
  1218. # modal - yes, if the window is modal
  1219. # var - variable's name for tkwait
  1220. # regist - yes or no for registering/unregistering
  1221. variable _PU_opts
  1222. if {$modal || $regist} {
  1223. set info [list $w $var $modal]
  1224. set i [lsearch -exact $_PU_opts(_MODALWIN_) $info]
  1225. catch {set _PU_opts(_MODALWIN_) [lreplace $_PU_opts(_MODALWIN_) $i $i]}
  1226. if {$regist} {
  1227. lappend _PU_opts(_MODALWIN_) $info
  1228. }
  1229. set res [IntStatus . MODALS $val]
  1230. } else {
  1231. set res [IntStatus . MODALS]
  1232. }
  1233. return $res
  1234. }
  1235. # ________________________ input _________________________ #
  1236. proc input {dlgname icon ttl iopts args} {
  1237. # Makes and runs an input dialog.
  1238. # dlgname - dialog name
  1239. # icon - icon (omitted if equals to "")
  1240. # ttl - title of window
  1241. # iopts - list of widgets and their attributes
  1242. # args - list of dialog's attributes
  1243. # The `iopts` contains lists of three items:
  1244. # name - name of widgets
  1245. # prompt - prompt for entering data
  1246. # valopts - value options
  1247. # The `valopts` is a list specific for a widget's type, however
  1248. # a first item of `valopts` is always an initial input value.
  1249. namespace upvar ::radxide dan dan
  1250. variable Indexdlg
  1251. variable _savedvv
  1252. variable Dlgpath
  1253. variable Dlgname
  1254. variable dlg
  1255. #tk_messageBox -title $dan(TITLE) -icon error -message "proc Input"
  1256. danInitDialogs
  1257. set Winpath $dan(WIN)
  1258. set Dlgname [set dlg(NAME) $dlgname]
  1259. set wdia $Winpath.dia$Dlgname[incr Indexdlg]
  1260. set dlg(PATH) [set Dlgpath $wdia]
  1261. if {$iopts ne {}} {
  1262. initInput ;# clear away all internal vars
  1263. }
  1264. set pady "-pady 2"
  1265. if {[set focusopt [getOption -focus {*}$args]] ne {}} {
  1266. set focusopt "-focus $focusopt"
  1267. }
  1268. lappend inopts [list fraM + T 1 98 "-st nsew $pady -rw 1"]
  1269. set _savedvv [list]
  1270. set frameprev {}
  1271. foreach {name prompt valopts} $iopts {
  1272. if {$name eq {}} continue
  1273. lassign $prompt prompt gopts attrs
  1274. lassign [extractOptions attrs -method {} -toprev {}] ismeth toprev
  1275. if {[string toupper $name 0] eq $name} {
  1276. set ismeth yes ;# overcomes the above setting
  1277. set name [string tolower $name 0]
  1278. }
  1279. set ismeth [string is true -strict $ismeth]
  1280. set gopts "$pady $gopts"
  1281. set typ [string tolower [string range $name 0 1]]
  1282. if {$typ eq "v_" || $typ eq "se"} {
  1283. lappend inopts [list fraM.$name - - - - "pack -fill x $gopts"]
  1284. continue
  1285. }
  1286. set tvar "-tvar"
  1287. switch -exact -- $typ {
  1288. ch { set tvar "-var" }
  1289. sp { set gopts "$gopts -expand 0 -side left"}
  1290. }
  1291. set framename fraM.fra$name
  1292. if {$typ in {lb te tb}} { ;# the widgets sized vertically
  1293. lappend inopts [list $framename - - - - "pack -expand 1 -fill both"]
  1294. } else {
  1295. lappend inopts [list $framename - - - - "pack -fill x"]
  1296. }
  1297. set vv [::radxide::win::varName $name]
  1298. #tk_messageBox -title $dan(TITLE) -icon info -message vv=$vv
  1299. set ff [FieldName $name]
  1300. set Name [string toupper $name 0]
  1301. if {$ismeth && $typ ni {ra}} {
  1302. # -method option forces making "WidgetName" method from "widgetName"
  1303. MakeWidgetName $ff $Name -
  1304. }
  1305. if {$typ ne {la} && $toprev eq {}} {
  1306. set takfoc [parseOptions $attrs -takefocus 1]
  1307. if {$focusopt eq {} && $takfoc} {
  1308. if {$typ in {fi di cl fo da}} {
  1309. set _ en*$name ;# 'entry-like mega-widgets'
  1310. } elseif {$typ eq "ft"} {
  1311. set _ te*$name ;# ftx - 'text-like mega-widget'
  1312. } else {
  1313. set _ $name
  1314. }
  1315. set focusopt "-focus $_"
  1316. }
  1317. if {$typ in {lb tb te}} {set anc nw} {set anc w}
  1318. lappend inopts [list fraM.fra$name.labB$name - - - - \
  1319. "pack -side left -anchor $anc -padx 3" \
  1320. "-t \"$prompt\" -font \
  1321. \"-family {[basicTextFont]} -size [basicFontSize]\""]
  1322. }
  1323. # for most widgets:
  1324. # 1st item of 'valopts' list is the current value
  1325. # 2nd and the rest of 'valopts' are a list of values
  1326. if {$typ ni {fc te la}} {
  1327. # curr.value can be set with a variable, so 'subst' is applied
  1328. set vsel [lindex $valopts 0]
  1329. catch {set vsel [subst -nocommands -nobackslashes $vsel]}
  1330. set vlist [lrange $valopts 1 end]
  1331. }
  1332. if {[set msgLab [getOption -msgLab {*}$attrs]] ne {}} {
  1333. set attrs [removeOptions $attrs -msgLab]
  1334. }
  1335. # define a current widget's info
  1336. switch -exact -- $typ {
  1337. lb - tb {
  1338. set $vv $vlist
  1339. lappend attrs -lvar $vv
  1340. if {$vsel ni {{} -}} {
  1341. lappend attrs -lbxsel "$UFF$vsel$UFF"
  1342. }
  1343. lappend inopts [list $ff - - - - \
  1344. "pack -side left -expand 1 -fill both $gopts" $attrs]
  1345. lappend inopts [list fraM.fra$name.sbv$name $ff L - - "pack -fill y"]
  1346. }
  1347. cb {
  1348. if {![info exist $vv]} {catch {set $vv $vsel}}
  1349. lappend attrs -tvar $vv -values $vlist
  1350. if {$vsel ni {{} -}} {
  1351. lappend attrs -cbxsel $UFF$vsel$UFF
  1352. }
  1353. lappend inopts [list $ff - - - - "pack -side left -expand 1 -fill x $gopts" $attrs]
  1354. }
  1355. fc {
  1356. if {![info exist $vv]} {catch {set $vv {}}}
  1357. lappend inopts [list $ff - - - - "pack -side left -expand 1 -fill x $gopts" "-tvar $vv -values \{$valopts\} $attrs"]
  1358. }
  1359. op {
  1360. set $vv $vsel
  1361. lappend inopts [list $ff - - - - "pack -fill x $gopts" "$vv $vlist"]
  1362. }
  1363. ra {
  1364. if {![info exist $vv]} {catch {set $vv $vsel}}
  1365. set padx 0
  1366. foreach vo $vlist {
  1367. set name $name
  1368. set FF $ff[incr nnn]
  1369. lappend inopts [list $FF - - - - "pack -side left $gopts -padx $padx" "-var $vv -value \"$vo\" -t \"$vo\" $attrs"]
  1370. if {$ismeth} {
  1371. MakeWidgetName $FF $Name$nnn -
  1372. }
  1373. set padx [expr {$padx ? 0 : 9}]
  1374. }
  1375. }
  1376. te {
  1377. if {![info exist $vv]} {
  1378. set valopts [string map [list \\n \n \\t \t] $valopts]
  1379. set $vv [string map [list \\\\ \\ \\\} \} \\\{ \{] $valopts]
  1380. }
  1381. # xxx
  1382. #tk_messageBox -title $dan(TITLE) -icon error -message $vv
  1383. if {[dict exist $attrs -state] && [dict get $attrs -state] eq "disabled"} \
  1384. {
  1385. # disabled text widget cannot be filled with a text, so we should
  1386. # compensate this through a home-made attribute (-disabledtext)
  1387. set disattr "-disabledtext \{[set $vv]\}"
  1388. } elseif {[dict exist $attrs -readonly] && [dict get $attrs -readonly] || [dict exist $attrs -ro] && [dict get $attrs -ro]} {
  1389. set disattr "-rotext \{[set $vv]\}"
  1390. set attrs [removeOptions $attrs -readonly -ro]
  1391. } else {
  1392. set disattr {}
  1393. }
  1394. lappend inopts [list $ff - - - - "pack -side left -expand 1 -fill both $gopts" "$attrs $disattr"]
  1395. lappend inopts [list fraM.fra$name.sbv$name $ff L - - "pack -fill y"]
  1396. }
  1397. la {
  1398. if {$prompt ne {}} { set prompt "-t \"$prompt\" " } ;# prompt as -text
  1399. lappend inopts [list $ff - - - - "pack -anchor w $gopts" "$prompt$attrs"]
  1400. continue
  1401. }
  1402. bu - bt - ch {
  1403. set prompt {}
  1404. if {$toprev eq {}} {
  1405. lappend inopts [list $ff - - - - \
  1406. "pack -side left -expand 1 -fill both $gopts" "$tvar $vv $attrs"]
  1407. } else {
  1408. lappend inopts [list $frameprev.$name - - - - \
  1409. "pack -side left $gopts" "$tvar $vv $attrs"]
  1410. }
  1411. if {$vv ne {}} {
  1412. if {![info exist $vv]} {
  1413. catch {
  1414. if {$vsel eq {}} {set vsel 0}
  1415. set $vv $vsel
  1416. }
  1417. }
  1418. }
  1419. }
  1420. default {
  1421. if {$vlist ne {}} {lappend attrs -values $vlist}
  1422. lappend inopts [list $ff - - - - \
  1423. "pack -side left -expand 1 -fill x $gopts" "$tvar $vv $attrs"]
  1424. if {$vv ne {}} {
  1425. if {![info exist $vv]} {catch {set $vv $vsel}}
  1426. }
  1427. }
  1428. }
  1429. if {$msgLab ne {}} {
  1430. lassign $msgLab lab msg attlab
  1431. set lab [parentWName [lindex $inopts end 0]].$lab
  1432. if {$msg ne {}} {set msg "-t {$msg}"}
  1433. append msg " $attlab"
  1434. lappend inopts [list $lab - - - - "pack -side left -expand 1 -fill x" $msg]
  1435. }
  1436. if {![info exist $vv]} {set $vv {}}
  1437. # xxx
  1438. if {$typ eq "en"} {
  1439. #tk_messageBox -title $dan(TITLE) -icon error -message setvv=[set $vv]
  1440. addDialogField $name [set $vv] ""
  1441. }
  1442. lappend _savedvv $vv [set $vv]
  1443. set frameprev $framename
  1444. }
  1445. lassign [parseOptions $args -titleHELP {} -buttons {} -comOK 1 \
  1446. -titleOK OK -titleCANCEL Cancel -centerme {}] \
  1447. titleHELP buttons comOK titleOK titleCANCEL centerme
  1448. if {$titleHELP eq {}} {
  1449. set butHelp {}
  1450. } else {
  1451. lassign $titleHELP title command
  1452. set butHelp [list butHELP $title $command]
  1453. }
  1454. if {$titleCANCEL eq {}} {
  1455. set butCancel {}
  1456. } else {
  1457. set butCancel "butCANCEL $titleCANCEL destroy"
  1458. }
  1459. if {$centerme eq {}} {
  1460. set centerme {-centerme 1}
  1461. } else {
  1462. set centerme "-centerme $centerme"
  1463. }
  1464. set args [removeOptions $args \
  1465. -titleHELP -buttons -comOK -titleOK -titleCANCEL -centerme -modal]
  1466. # xxx
  1467. #set buttons [string map {"butOK OK 1" "" "butCANCEL Cancel destroy" ""} $buttons]
  1468. #tk_messageBox -title $dan(TITLE) -icon info -message new_buttons=$buttons
  1469. lappend args {*}$focusopt
  1470. #lassign [PrepArgs {*}$args] args
  1471. if {[catch { \
  1472. lassign [PrepArgs {*}$args] args
  1473. set res [Query $dlgname $icon $ttl {} \
  1474. "$butHelp $buttons butOK $titleOK $comOK $butCancel" \
  1475. butOK $inopts $args {} {*}$centerme -input yes]} e]} {
  1476. catch {destroy $Dlgpath]} ;# Query's window
  1477. # ::apave::obj ok err "ERROR" "\n$e\n" \
  1478. # -t 1 -head "\nAPave returned an error: \n" -hfg red -weight bold
  1479. #tk_messageBox -title $dan(TITLE) -icon info -message "::win returned an error:$e"
  1480. set res 0
  1481. set msg "\nERROR in win:"
  1482. puts \n$msg\n\n$e$::errorInfo\n
  1483. #set msg "$msg\n\n$e\n\nPlease, inform authors.\nDetails are in stdout."
  1484. #tk_messageBox -title $dan(TITLE) -icon error -message $msg
  1485. #exit 2
  1486. return $res
  1487. }
  1488. if {![lindex $res 0]} { ;# restore old values if OK not chosen
  1489. foreach {vn vv} $_savedvv {
  1490. # tk_optionCascade (destroyed now) was tracing its variable => catch
  1491. catch {set $vn $vv}
  1492. }
  1493. }
  1494. return $res
  1495. }
  1496. # _______________________ insert tab amenities _______________ #
  1497. proc insertTab {} {
  1498. namespace upvar ::radxide dan dan
  1499. set wt $dan(TEXT)
  1500. #set idx1 [$wt index {insert linestart}]
  1501. #set idx2 [$wt index {insert lineend}]
  1502. #set line [$wt get $idx1 $idx2]
  1503. $wt insert {insert} $dan(TAB_IN_SPACE)
  1504. return -code break
  1505. }
  1506. # ________________________ IntStatus _________________________ #
  1507. proc IntStatus {w {name "status"} {val ""}} {
  1508. # Sets/gets a status of window. The status is an integer assigned to a name.
  1509. # w - window's path
  1510. # name - name of status
  1511. # val - if blank, to get a value of status; otherwise a value to set
  1512. # Default value of status is 0.
  1513. # Returns an old value of status.
  1514. # See also: WindowStatus
  1515. set old [WindowStatus $w $name {} 0]
  1516. if {$val ne {}} {WindowStatus $w $name $val 1}
  1517. return $old
  1518. }
  1519. # ________________________ LbxSelect _________________________ #
  1520. proc LbxSelect {w idx} {
  1521. # Selects a listbox item.
  1522. # w - listbox's path
  1523. # idx - item index
  1524. $w activate $idx
  1525. $w see $idx
  1526. if {[$w cget -selectmode] in {single browse}} {
  1527. $w selection clear 0 end
  1528. $w selection set $idx
  1529. event generate $w <<ListboxSelect>>
  1530. }
  1531. }
  1532. # ________________________ ListboxesAttrs _________________________ #
  1533. proc ListboxesAttrs {w attrs} {
  1534. # Appends selection attributes to listboxes.
  1535. # Details:
  1536. # 1. https://wiki.tcl-lang.org/page/listbox+selection
  1537. # 2. https://stackoverflow.com, the question:
  1538. # the-tablelist-curselection-goes-at-calling-the-directory-dialog
  1539. if {{-exportselection} ni $attrs} {
  1540. append attrs " -ListboxSel $w -selectmode extended -exportselection 0"
  1541. }
  1542. return $attrs
  1543. }
  1544. # ________________________ LowercaseWidgetName _________________________ #
  1545. proc LowercaseWidgetName {name} {
  1546. # Makes the widget name lowercased.
  1547. # name - widget's name
  1548. # The widgets of widget list can have uppercased names which
  1549. # means that the appropriate methods will be created to access
  1550. # their full pathes with a command `my Name`.
  1551. # This method gets a "normal" name of widget accepted by Tk.
  1552. # See also: MakeWidgetName
  1553. set root [ownWName $name]
  1554. return [list [string range $name 0 [string last . $name]][string tolower $root 0 0] $root]
  1555. }
  1556. # ________________________ NonTtkStyle _________________________ #
  1557. proc NonTtkStyle {typ {dsbl 0}} {
  1558. # Gets a style for non-ttk widgets.
  1559. # typ - the type of widget (in apave terms, i.e. but, buT etc.)
  1560. # dsbl - a mode to get style of disabled (1) or readonly (2) widgets
  1561. # See also: widgetType
  1562. # Method to be redefined in descendants/mixins.
  1563. return
  1564. }
  1565. # ________________________ NormalizeName _________________________ #
  1566. proc NormalizeName {refname refi reflwidgets} {
  1567. # Gets the real name of widget from *.name*.
  1568. # refname - variable name for widget name
  1569. # refi - variable name for index in widget list
  1570. # reflwidgets - variable name for widget list
  1571. # The *.name* means "child of some previous" and should be normalized.
  1572. # Example:
  1573. # If parent: fra.fra .....
  1574. # child: .but
  1575. # => normalized: fra.fra.but
  1576. upvar $refname name $refi i $reflwidgets lwidgets
  1577. set wname $name
  1578. if {[string index $name 0] eq {.}} {
  1579. for {set i2 [expr {$i-1}]} {$i2 >=0} {incr i2 -1} {
  1580. lassign [lindex $lwidgets $i2] name2
  1581. if {[string index $name2 0] ne {.}} {
  1582. set name2 [lindex [LowercaseWidgetName $name2] 0]
  1583. set wname "$name2$name"
  1584. set name [lindex [LowercaseWidgetName $name] 0]
  1585. set name "$name2$name"
  1586. break
  1587. }
  1588. }
  1589. }
  1590. return [list $name $wname]
  1591. }
  1592. # ________________________ makeMainWindow _________________________ #
  1593. # Scrollbars amenities
  1594. proc Yset {widgets master sb args} {
  1595. namespace upvar ::radxide dan dan
  1596. if {$master eq "master"} {
  1597. #list $sb set [expr [lindex $args 0]] [expr [lindex $args 1]]
  1598. set sb1 [lrange $sb 0 0]
  1599. set sb2 [lrange $sb 1 1]
  1600. $sb1 set {*}$args
  1601. $sb2 set {*}$args
  1602. set myw [lrange $widgets 1 end]
  1603. } else {
  1604. set myw [lrange $widgets 0 0]
  1605. }
  1606. #::radxide::win::Yview $myw moveto [lindex $args 0]
  1607. #::radxide::win::Yview [lrange $widgets 0 0] moveto [lindex $args 0]
  1608. #.danwin.fra.pan.fra3.body.text delete 1.0 end
  1609. #.danwin.fra.pan.fra3.body.text insert end [expr [lindex $args 0]]
  1610. #if {[expr [lindex $args 0]] > [expr $dan(CUR_FILE_MAX_YVIEW) - 0.01]} { ;#yyy
  1611. # ::radxide::win::Yview $widgets no moveto [lindex $args 1]
  1612. #} else {
  1613. ::radxide::win::Yview $widgets no moveto [lindex $args 0]
  1614. #}
  1615. }
  1616. proc Yview {widgets callfromsbmaster args} {
  1617. namespace upvar ::radxide dan dan
  1618. foreach w $widgets {
  1619. $w yview {*}$args
  1620. }
  1621. if ($callfromsbmaster) {
  1622. #catch {list $dan(GUTTEXT) yview moveto [lindex [$dan(TEXT) yview] 0]}
  1623. #catch {list $dan(GUTTEXT) yview moveto [string range [lindex [$dan(TEXT) yview] 0] 0 2]}
  1624. }
  1625. }
  1626. proc makeMainWindow {win ttl bg fg} {
  1627. namespace upvar ::radxide dan dan
  1628. set w [set wtop [string trimright $win .]]
  1629. set withfr [expr {[set pp [string last . $w]]>0 && \
  1630. [string match *.fra $w]}]
  1631. if {$withfr} {
  1632. set wtop [string range $w 0 $pp-1]
  1633. }
  1634. # menu
  1635. set m [::radxide::menu::menuScaf]
  1636. toplevel $wtop -menu $m
  1637. if {$withfr} {
  1638. # main frame
  1639. pack [frame $w -background $bg ] -expand 1 -fill both
  1640. # panedwindow
  1641. pack [set pan [ttk::panedwindow $w.pan -orient horizontal]] -side top -fill both -expand 1
  1642. # tree pane (panL)
  1643. pack [set w1 [frame $pan.fra1 -background $bg ]] -side left -fill both ;#-expand 1 -fill both
  1644. set panL [$pan add $pan.fra1]
  1645. pack [set tree [ttk::treeview $w1.tree -selectmode extended]] -side left -fill both -expand 1
  1646. set dan(TREEVIEW) $w1.tree
  1647. $tree heading #0 -text " Project" -anchor "w"
  1648. # main pane (panR)
  1649. pack [set w2 [ttk::panedwindow $pan.fra2 -orient horizontal]] -side left -fill both -expand 1
  1650. set panR [$pan add $pan.fra2]
  1651. if {[string first " " $dan(TEXTFONT)]} {
  1652. set myfont "\"$dan(TEXTFONT)\""
  1653. } else {
  1654. set myfont $dan(TEXTFONT)
  1655. }
  1656. set myfontsize $dan(TEXTFONTSIZE)
  1657. text $w2.gutText -background "lightgray" -foreground "#222223" -font "$myfont $myfontsize" -width 5
  1658. text $w2.text -font "$myfont $myfontsize" -bd 0 -padx 13 -spacing1 0 -spacing2 0 -spacing3 0 -exportselection yes -width 115 -wrap none -undo yes
  1659. set ww [list .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText]
  1660. $w2.text configure -xscrollcommand [list $w2.xscroll set]
  1661. scrollbar $w2.xscroll -orient horizontal \
  1662. -command [list $w2.text xview]
  1663. #scrollbar $w2.yscroll1 -orient vertical \
  1664. # -command [list ::radxide::win::Yview $ww yes]
  1665. scrollbar $w2.yscroll1 -orient vertical \
  1666. -command [list $w2.text yview]
  1667. scrollbar $w2.yscroll2 -orient vertical \
  1668. -command [list $w2.gutText yview]
  1669. set ssbb [list .danwin.fra.pan.fra2.yscroll1 .danwin.fra.pan.fra2.yscroll2]
  1670. $w2.text configure -yscrollcommand [list ::radxide::win::Yset $ww master $ssbb]
  1671. $w2.gutText configure -yscrollcommand [list .danwin.fra.pan.fra2.yscroll2 set]
  1672. #$w2.gutText configure -yscrollcommand [list ::radxide::win::Yset $ww slave $ssbb]
  1673. grid $w2.gutText $w2.text $w2.yscroll1 -sticky nsew
  1674. grid $w2.xscroll -columnspan 2 -sticky nsew
  1675. grid rowconfigure $w2 0 -weight 1
  1676. grid columnconfigure $w2 1 -weight 1
  1677. set dan(GUTTEXT) $w2.gutText
  1678. set dan(TEXT) $w2.text
  1679. $dan(GUTTEXT) configure -state disabled
  1680. $dan(TEXT) configure -state disabled
  1681. # set colors
  1682. $dan(TEXT) configure -background $dan(TEXTBG) -foreground $dan(TEXTFG)
  1683. $dan(TEXT) configure -selectforeground $dan(TEXTSELFG)
  1684. $dan(TEXT) configure -insertbackground $dan(CURSORCOLOR)
  1685. if {$dan(CURSORWIDTH) > 4} {
  1686. $dan(TEXT) configure -blockcursor true
  1687. } else {
  1688. $dan(TEXT) configure -insertwidth $dan(CURSORWIDTH);
  1689. }
  1690. # code library
  1691. pack [set w3 [frame $pan.fra3 -background $bg]] -side left -fill y -expand 1;
  1692. set panC [$pan add $pan.fra3]
  1693. ::radxide::eglib::create $w3
  1694. # update gutter, key bindings
  1695. #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]"
  1696. #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]"
  1697. #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]"
  1698. bind $tree "<ButtonPress>" {after idle {::radxide::tree::buttonPress %b %x %y %X %Y}}
  1699. bind $tree "<ButtonRelease>" {after idle {::radxide::tree::buttonRelease %b %s %x %y %X %Y}}
  1700. bind $dan(TEXT) "<KeyPress>" {
  1701. switch %K {
  1702. #KP_Enter {
  1703. # ::radxide::menu::edit::makeNewLine
  1704. #}
  1705. #Return {
  1706. # ::radxide::menu::edit::makeNewLine
  1707. #}
  1708. Tab {
  1709. ::radxide::menu::edit::Indent
  1710. }
  1711. Shift_L-Tab {
  1712. ::radxide::menu::edit::UnIndent
  1713. }
  1714. ISO_Left_Tab {
  1715. ::radxide::menu::edit::UnIndent
  1716. }
  1717. ISO_Right_Tab {
  1718. ::radxide::menu::edit::UnIndent
  1719. }
  1720. #Shift_L {
  1721. #}
  1722. #Shift_R {
  1723. #}
  1724. #default {
  1725. # tk_messageBox -title radxide -icon info -message %K
  1726. #}
  1727. }
  1728. }
  1729. bind $dan(TEXT) "<KeyRelease>" {
  1730. switch %K {
  1731. #KP_Enter {
  1732. # ::radxide::menu::edit::makeNewLine
  1733. #}
  1734. #Return {
  1735. # ::radxide::menu::edit::makeNewLine
  1736. #}
  1737. BackSpace {
  1738. ::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 #FFFFFF #222223
  1739. }
  1740. Delete {
  1741. ::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 #FFFFFF #222223
  1742. }
  1743. Cancel {
  1744. ::radxide::win::fillGutter .danwin.fra.pan.fra2.text .danwin.fra.pan.fra2.gutText 5 1 #FFFFFF #222223
  1745. }
  1746. Tab {
  1747. }
  1748. #default {
  1749. # tk_messageBox -title radxide -icon info -message %K
  1750. #}
  1751. }
  1752. }
  1753. }
  1754. #wm title $wtop ttl
  1755. # window shortcut bindings
  1756. set canvas $w2.gutText
  1757. ::radxide::menu::defWinShortcuts $dan(TEXT) $canvas
  1758. ::radxide::menu::defWinShortcuts $dan(TREEVIEW) $canvas
  1759. }
  1760. # ________________________ MakeWidgetName _________________________ #
  1761. proc MakeWidgetName {w name {an {}}} {
  1762. # Makes an exported method named after root widget, if it's uppercased.
  1763. # w - name of root widget
  1764. # name - name of widget
  1765. # an - additional prefix for name (if "-", $w is full/partial name)
  1766. # The created method used for easy access to the widget's path.
  1767. # Example:
  1768. # fra1.fra2.fra3.Entry1
  1769. # => method Entry1 {} {...}
  1770. # ...
  1771. # my Entry1 ;# instead of .win.fra1.fra2.fra3.Entry1
  1772. if {$an eq {-}} {
  1773. set wnamefull "\[DiaWidgetName $w\]"
  1774. } else {
  1775. set wnamefull [WidgetNameFull $w $name $an]
  1776. lassign [LowercaseWidgetName $wnamefull] wnamefull
  1777. }
  1778. set method [ownWName $name]
  1779. set root1 [string index $method 0]
  1780. #if {[string is upper $root1]} {
  1781. # oo::objdefine [self] "method $method {} {return $wnamefull} ; \
  1782. # export $method"
  1783. #}
  1784. return $wnamefull
  1785. }
  1786. # ________________________ makeWindow _________________________ #
  1787. proc makeWindow {w ttl args} {
  1788. # Creates a toplevel window that has to be paved.
  1789. # w - window's name
  1790. # ttl - window's title
  1791. # args - options for 'toplevel' command
  1792. # If $w matches "*.fra" then ttk::frame is created with name $w.
  1793. namespace upvar ::radxide dan dan
  1794. #CleanUps
  1795. set w [set wtop [string trimright $w .]]
  1796. set withfr [expr {[set pp [string last . $w]]>0 && \
  1797. [string match *.fra $w]}]
  1798. if {$withfr} {
  1799. set wtop [string range $w 0 $pp-1]
  1800. }
  1801. catch {destroy $wtop}
  1802. lassign [extractOptions args -type {}] type
  1803. toplevel $wtop {*}$args
  1804. withdraw $wtop ;# nice to hide all gui manipulations
  1805. if {$type ne {} && [tk windowingsystem] eq {x11}} {
  1806. wm attributes $wtop -type $type
  1807. }
  1808. if {$withfr} {
  1809. pack [frame $w -background $dan(BG)] -expand 1 -fill both
  1810. }
  1811. wm title $wtop $ttl
  1812. return $wtop
  1813. }
  1814. # ________________________ ownWName _________________________ #
  1815. proc ownWName {name} {
  1816. # Gets a tail (last part) of widget's name
  1817. # name - name (path) of the widget
  1818. return [lindex [split $name .] end]
  1819. }
  1820. # ________________________ parentWName _________________________ #
  1821. proc parentWName {name} {
  1822. # Gets parent name of widget.
  1823. # name - name (path) of the widget
  1824. return [string range $name 0 [string last . $name]-1]
  1825. }
  1826. # ________________________ parseOptionsFile _________________________ #
  1827. proc parseOptionsFile {strict inpargs args} {
  1828. # Parses argument list containing options and (possibly) a file name.
  1829. # strict - if 0, 'args' options will be only counted for,
  1830. # other options are skipped
  1831. # strict - if 1, only 'args' options are allowed,
  1832. # all the rest of inpargs to be a file name
  1833. # - if 2, the 'args' options replace the
  1834. # appropriate options of 'inpargs'
  1835. # inpargs - list of options, values and a file name
  1836. # args - list of default options
  1837. #
  1838. # The inpargs list contains:
  1839. # - option names beginning with "-"
  1840. # - option values following their names (may be missing)
  1841. # - "--" denoting the end of options
  1842. # - file name following the options (may be missing)
  1843. #
  1844. # The *args* parameter contains the pairs:
  1845. # - option name (e.g., "-dir")
  1846. # - option default value
  1847. #
  1848. # If the *args* option value is equal to =NONE=, the *inpargs* option
  1849. # is considered to be a single option without a value and,
  1850. # if present in inpargs, its value is returned as "yes".
  1851. #
  1852. # If any option of *inpargs* is absent in *args* and strict==1,
  1853. # the rest of *inpargs* is considered to be a file name.
  1854. #
  1855. # The proc returns a list of two items:
  1856. # - an option list got from args/inpargs according to 'strict'
  1857. # - a file name from inpargs or {} if absent
  1858. #
  1859. # Examples see in tests/obbit.test.
  1860. variable _PU_opts
  1861. set actopts true
  1862. array set argarray "$args yes yes" ;# maybe, tail option without value
  1863. if {$strict==2} {
  1864. set retlist $inpargs
  1865. } else {
  1866. set retlist $args
  1867. }
  1868. set retfile {}
  1869. for {set i 0} {$i < [llength $inpargs]} {incr i} {
  1870. set parg [lindex $inpargs $i]
  1871. if {$actopts} {
  1872. if {$parg eq "--"} {
  1873. set actopts false
  1874. } elseif {[catch {set defval $argarray($parg)}]} {
  1875. if {$strict==1} {
  1876. set actopts false
  1877. append retfile $parg " "
  1878. } else {
  1879. incr i
  1880. }
  1881. } else {
  1882. if {$strict==2} {
  1883. if {$defval == $_PU_opts(-NONE)} {
  1884. set defval yes
  1885. }
  1886. incr i
  1887. } else {
  1888. if {$defval == $_PU_opts(-NONE)} {
  1889. set defval yes
  1890. } else {
  1891. set defval [lindex $inpargs [incr i]]
  1892. }
  1893. }
  1894. set ai [lsearch -exact $retlist $parg]
  1895. incr ai
  1896. set retlist [lreplace $retlist $ai $ai $defval]
  1897. }
  1898. } else {
  1899. append retfile $parg " "
  1900. }
  1901. }
  1902. return [list $retlist [string trimright $retfile]]
  1903. }
  1904. # ________________________ parseOptions _________________________ #
  1905. proc parseOptions {opts args} {
  1906. # Parses argument list containing options.
  1907. # opts - list of options and values
  1908. # args - list of "option / default value" pairs
  1909. # It's the same as parseOptionsFile, excluding the file name stuff.
  1910. # Returns a list of options' values, according to args.
  1911. # See also: parseOptionsFile
  1912. lassign [parseOptionsFile 0 $opts {*}$args] tmp
  1913. foreach {nam val} $tmp {
  1914. lappend retlist $val
  1915. }
  1916. return $retlist
  1917. }
  1918. # ________________________ popupHighlightCommands _________________________ #
  1919. proc popupHighlightCommands {{pop ""} {txt ""}} {
  1920. # Returns highlighting commands for a popup menu on a text.
  1921. # pop - path to the menu
  1922. # txt - path to the text
  1923. set res ""
  1924. return $res
  1925. }
  1926. # ________________________ Pre _________________________ #
  1927. proc Pre {refattrs} {
  1928. # "Pre" actions for the text widget and similar
  1929. # which all require some actions before and after their creation e.g.:
  1930. # the text widget's text cannot be filled if disabled
  1931. # so, we must act this way:
  1932. # 1. call Pre - to get a text of widget
  1933. # 2. create the widget
  1934. # 3. call Post - to enable, then fill it with a text, then disable it
  1935. # It's only possible with Pre and Post methods.
  1936. # See also: Post
  1937. upvar 1 $refattrs attrs
  1938. set attrs_ret [set Prepost [list]]
  1939. foreach {a v} $attrs {
  1940. switch -exact -- $a {
  1941. -disabledtext - -rotext - -lbxsel - -cbxsel - -notebazook - \
  1942. -entrypop - -entrypopRO - -textpop - -textpopRO - -ListboxSel - \
  1943. -callF2 - -timeout - -bartabs - -onReturn - -linkcom - -selcombobox - \
  1944. -afteridle - -gutter - -propagate - -columnoptions - -selborderwidth -
  1945. -selected - -popup - -bindEC - -tags - -debug - -clearcom {
  1946. # attributes specific to apave, processed below in "Post"
  1947. set v2 [string trimleft $v \{]
  1948. set v2 [string range $v2 0 end-[expr {[string length $v]-[string length $v2]}]]
  1949. lappend Prepost [list $a $v2]
  1950. }
  1951. -myown {
  1952. lappend Prepost [list $a [subst $v]]
  1953. }
  1954. -labelwidget { ;# widget path as a method
  1955. set v [string trim $v \{\}]
  1956. catch {set v [$::win::$v]}
  1957. lappend attrs_ret $a $v
  1958. }
  1959. default {
  1960. lappend attrs_ret $a $v
  1961. }
  1962. }
  1963. }
  1964. set attrs $attrs_ret
  1965. return
  1966. }
  1967. # ________________________ PrepArgs _________________________ #
  1968. proc PrepArgs {args} {
  1969. # Prepares a list of arguments.
  1970. # Returns the list (wrapped in list) and a command for OK button.
  1971. lassign [parseOptions $args -modal {} -ch {} -comOK {} -onclose {}] \
  1972. modal ch comOK onclose
  1973. if {[string is true -strict $modal]} {
  1974. set com 1
  1975. } elseif {$ch ne {}} {
  1976. # some options are incompatible with -ch
  1977. if {$onclose eq {destroy}} {set onclose {}}
  1978. lappend args -modal 1 -onclose $onclose
  1979. set com 1
  1980. } elseif {$comOK eq {}} {
  1981. set com destroy ;# non-modal without -ch option
  1982. } else {
  1983. set com $comOK
  1984. }
  1985. return [list [list $args] $com]
  1986. }
  1987. ## ________________________ Query _________________________ ##
  1988. proc Query {dlgname icon ttl msg buttons defb inopts argdia {precom ""} args} {
  1989. # Makes a query (or a message) and gets the user's response.
  1990. # dlgname - dialog name
  1991. # icon - icon name (info, warn, ques, err)
  1992. # ttl - title
  1993. # msg - message
  1994. # buttons - list of triples "button name, text, ID"
  1995. # defb - default button (OK, YES, NO, CANCEL, RETRY, ABORT)
  1996. # inopts - options for input dialog
  1997. # argdia - list of dialog's options
  1998. # precom - command(s) performed before showing the dialog
  1999. # args - additional options (message's font etc.)
  2000. # The *argdia* may contain additional options of the query, like these:
  2001. # -checkbox text (-ch text) - makes the checkbox's text visible
  2002. # -geometry +x+y (-g +x+y) - sets the geometry of dialog
  2003. # -color cval (-c cval) - sets the color of message
  2004. # If "-geometry" option is set (even equaling "") the Query procedure
  2005. # returns a list with chosen button's ID and a new geometry.
  2006. # Otherwise it returns only the chosen button's ID.
  2007. # See also:
  2008. # [aplsimple.github.io](https://aplsimple.github.io/en/tcl/pave/index.html)
  2009. namespace upvar ::radxide dan dan
  2010. variable Indexdlg
  2011. variable Foundstr
  2012. variable Dlgpath
  2013. variable Dlgname
  2014. variable dlg
  2015. #tk_messageBox -title $dan(TITLE) -icon error -message "Query"
  2016. set Winpath $dan(WIN)
  2017. set Dlgname $dlg(NAME)
  2018. set wdia $Winpath.dia$Dlgname
  2019. #append wdia [lindex [split :] end] ;# be unique per apave object
  2020. #set qdlg [set dlg(PATH) [set Dlgpath $wdia[incr Indexdlg]]]
  2021. set qdlg $Dlgpath
  2022. #tk_messageBox -title $dan(TITLE) -icon error -message $qdlg
  2023. # remember the focus (to restore it after closing the dialog)
  2024. set focusback [focus]
  2025. set focusmatch {}
  2026. # options of dialog
  2027. lassign {} chmsg geometry optsLabel optsMisc optsFont optsFontM optsHead \
  2028. root rotext head hsz binds postcom onclose timeout tab2 \
  2029. tags cc themecolors optsGrid addpopup minsize
  2030. set wasgeo [set textmode [set stay [set waitvar 0]]]
  2031. set readonly [set hidefind [set scroll [set modal 1]]]
  2032. set curpos {1.0}
  2033. set CheckNomore 0
  2034. foreach {opt val} {*}$argdia {
  2035. if {$opt in {-c -color -fg -bg -fgS -bgS -cc -hfg -hbg}} {
  2036. # take colors by their variables
  2037. if {[info exist $val]} {set val [set $val]}
  2038. }
  2039. switch -- $opt {
  2040. -H - -head {
  2041. set head [string map {$ \$ \" \'\' \{ ( \} )} $val]
  2042. }
  2043. -help {
  2044. set buttons "butHELP Help {$val} $buttons"
  2045. }
  2046. -ch - -checkbox {set chmsg "$val"}
  2047. -g - -geometry {
  2048. set geometry $val
  2049. if {[set wasgeo [expr {[string first "pointer" $val]<0}]]} {
  2050. lassign [splitGeometry $geometry] - - gx gy
  2051. }
  2052. }
  2053. -c - -color {append optsLabel " -foreground {$val}"}
  2054. -a { ;# additional grid options of message labels
  2055. append optsGrid " $val" }
  2056. -centerme - -ontop - -themed - -resizable - -checkgeometry - -onclose - -comOK - -transient {
  2057. lappend args $opt $val ;# options delegated to showModal method
  2058. }
  2059. -parent - -root { ;# obsolete, used for compatibility
  2060. lappend args -centerme $val
  2061. }
  2062. -t - -text {set textmode $val}
  2063. -tags {
  2064. upvar 2 $val _tags
  2065. set tags $_tags
  2066. }
  2067. -ro - -readonly {set readonly [set hidefind $val]}
  2068. -rotext {set hidefind 0; set rotext $val}
  2069. -w - -width {set charwidth $val}
  2070. -h - -height {set charheight $val}
  2071. -fg {append optsMisc " -foreground {$val}"}
  2072. -bg {append optsMisc " -background {$val}"}
  2073. -fgS {append optsMisc " -selectforeground {$val}"}
  2074. -bgS {append optsMisc " -selectbackground {$val}"}
  2075. -cc {append optsMisc " -insertbackground {$val}"}
  2076. -my - -myown {append optsMisc " -myown {$val}"}
  2077. -pos {set curpos "$val"}
  2078. -hfg {append optsHead " -foreground {$val}"}
  2079. -hbg {append optsHead " -background {$val}"}
  2080. -hsz {append hsz " -size $val"}
  2081. -minsize {set minsize "-minsize {$val}"}
  2082. -focus {set focusmatch "$val"}
  2083. -theme {append themecolors " {$val}"}
  2084. -post {set postcom $val}
  2085. -popup {set addpopup [string map [list %w $qdlg.fra.texM] "$val"]}
  2086. -timeout - -focusback - -scroll - -tab2 - -stay - -modal - -waitvar {
  2087. set [string range $opt 1 end] $val
  2088. }
  2089. default {
  2090. append optsFont " $opt $val"
  2091. if {$opt ne "-family"} {
  2092. append optsFontM " $opt $val"
  2093. }
  2094. }
  2095. }
  2096. }
  2097. if {[set wprev [InfoFind $wdia $modal]] ne {}} {
  2098. catch {
  2099. wm withdraw $wprev
  2100. wm deiconify $wprev
  2101. puts "$wprev already exists: selected now"
  2102. }
  2103. return 0
  2104. }
  2105. set optsFont [string trim $optsFont]
  2106. set optsHeadFont $optsFont
  2107. set fs [basicFontSize]
  2108. set textfont "-family {[basicTextFont]}"
  2109. if {$optsFont ne {}} {
  2110. if {[string first "-size " $optsFont]<0} {
  2111. append optsFont " -size $fs"
  2112. }
  2113. if {[string first "-size " $optsFontM]<0} {
  2114. append optsFontM " -size $fs"
  2115. }
  2116. if {[string first "-family " $optsFont]>=0} {
  2117. set optsFont "-font \{$optsFont"
  2118. } else {
  2119. set optsFont "-font \{$optsFont -family {[basicDefFont]}"
  2120. }
  2121. append optsFont "\}"
  2122. } else {
  2123. set optsFont "-font {[basicDefFont] -size $fs}"
  2124. set optsFontM "-size $fs"
  2125. }
  2126. set msgonly [expr {$readonly || $hidefind || $chmsg ne {}}]
  2127. if {!$textmode || $msgonly} {
  2128. set textfont "-family {[basicDefFont]}"
  2129. if {!$textmode} {
  2130. set msg [string map [list \\ \\\\ \{ \\\\\{ \} \\\\\}] $msg]
  2131. }
  2132. }
  2133. set optsFontM [string trim $optsFontM]
  2134. set optsFontM "-font \{$optsFontM $textfont\}"
  2135. # layout: add the icon
  2136. if {$icon ni {{} -}} {
  2137. #tk_messageBox -title $dan(TITLE) -icon error -message "Yess!"
  2138. set widlist [list [list labBimg - - 99 1 \
  2139. {-st n -pady 7} "-image [iconImage $icon]"]]
  2140. set prevl labBimg
  2141. } else {
  2142. set widlist [list [list labimg - - 99 1]]
  2143. set prevl labimg ;# this trick would hide the prevw at all
  2144. }
  2145. set prevw labBimg
  2146. #tk_messageBox -title $dan(TITLE) -icon info -message Header:$head
  2147. if {$head ne {}} {
  2148. # set the dialog's heading (-head option)
  2149. if {$optsHeadFont ne {} || $hsz ne {}} {
  2150. if {$hsz eq {}} {set hsz "-size [basicFontSize]"}
  2151. set optsHeadFont [string trim "$optsHeadFont $hsz"]
  2152. set optsHeadFont "-font \"$optsHeadFont\""
  2153. }
  2154. set optsFont {}
  2155. set prevp L
  2156. set head [string map {\\n \n} $head]
  2157. foreach lh [split $head "\n"] {
  2158. set labh "labheading[incr il]"
  2159. lappend widlist [list $labh $prevw $prevp 1 99 {-st we} \
  2160. "-t \"$lh\" $optsHeadFont $optsHead"]
  2161. set prevw [set prevh $labh]
  2162. set prevp T
  2163. }
  2164. } else {
  2165. # add the upper (before the message) blank frame
  2166. lappend widlist [list h_1 $prevw L 1 1 {-pady 3}]
  2167. set prevw [set prevh h_1]
  2168. set prevp T
  2169. }
  2170. # add the message lines
  2171. set il [set maxw 0]
  2172. if {$readonly && $rotext eq {}} {
  2173. # only for messaging (not for editing/viewing texts):
  2174. set msg [string map {\\\\n \\n \\n \n} $msg]
  2175. }
  2176. foreach m [split $msg \n] {
  2177. set m [string map {$ \$ \" \'\'} $m]
  2178. if {[set mw [string length $m]] > $maxw} {
  2179. set maxw $mw
  2180. }
  2181. incr il
  2182. if {!$textmode} {
  2183. lassign [GetLinkLab $m] m link
  2184. lappend widlist [list Lab$il $prevw $prevp 1 7 \
  2185. "-st w -rw 1 $optsGrid" "-t \"$m \" $optsLabel $optsFont $link"]
  2186. }
  2187. set prevw Lab$il
  2188. set prevp T
  2189. }
  2190. if {$inopts ne {}} {
  2191. # here are widgets for input (in fraM frame)
  2192. set io0 [lindex $inopts 0]
  2193. lset io0 1 $prevh
  2194. lset inopts 0 $io0
  2195. foreach io $inopts {
  2196. lappend widlist $io
  2197. }
  2198. set prevw fraM
  2199. } elseif {$textmode} {
  2200. # here is text widget (in fraM frame)
  2201. ; proc vallimits {val lowlimit isset limits} {
  2202. set val [expr {max($val,$lowlimit)}]
  2203. if {$isset} {
  2204. upvar $limits lim
  2205. lassign $lim l1 l2
  2206. set val [expr {min($val,$l1)}] ;# forced low
  2207. if {$l2 ne {}} {set val [expr {max($val,$l2)}]} ;# forced high
  2208. }
  2209. return $val
  2210. }
  2211. set il [vallimits $il 1 [info exists charheight] charheight]
  2212. incr maxw
  2213. set maxw [vallimits $maxw 20 [info exists charwidth] charwidth]
  2214. rename vallimits {}
  2215. lappend widlist [list fraM $prevh T 10 12 {-st nswe -pady 3 -rw 1}]
  2216. lappend widlist [list TexM - - 1 12 {pack -side left -expand 1 -fill both -in \
  2217. $qdlg.fra.fraM} [list -h $il -w $maxw {*}$optsFontM {*}$optsMisc \
  2218. -wrap word -textpop 0 -tabnext "$qdlg.fra.[lindex $buttons 0] *but0"]]
  2219. if {$scroll} {
  2220. lappend widlist {sbv texM L 1 1 {pack -in $qdlg.fra.fraM}}
  2221. }
  2222. set prevw fraM
  2223. }
  2224. # add the lower (after the message) blank frame
  2225. lappend widlist [list h_2 $prevw T 1 1 {-pady 0 -ipady 0 -csz 0}]
  2226. # underline the message
  2227. lappend widlist [list seh $prevl T 1 99 {-st ew}]
  2228. # add left frames and checkbox (before buttons)
  2229. lappend widlist [list h_3 seh T 1 1 {-pady 0 -ipady 0 -csz 0}]
  2230. if {$textmode} {
  2231. # binds to the special popup menu of the text widget
  2232. set wt "\[TexM\]"
  2233. set binds "set pop $wt.popupMenu
  2234. bind $wt <Button-3> \{[self] themePopup $wt.popupMenu; tk_popup $wt.popupMenu %X %Y \}"
  2235. if {$msgonly} {
  2236. append binds "
  2237. menu \$pop
  2238. \$pop add command [iconA copy] -accelerator Ctrl+C -label \"Copy\" \\
  2239. -command \"event generate $wt <<Copy>>\""
  2240. if {$hidefind || $chmsg ne {}} {
  2241. append binds "
  2242. \$pop configure -tearoff 0
  2243. \$pop add separator
  2244. \$pop add command [iconA none] -accelerator Ctrl+A \\
  2245. -label \"Select All\" -command \"$wt tag add sel 1.0 end\"
  2246. bind $wt <Control-a> \"$wt tag add sel 1.0 end; break\""
  2247. }
  2248. }
  2249. }
  2250. set appendHL no
  2251. if {$chmsg eq {}} {
  2252. if {$textmode} {
  2253. set noIMG "[iconA none]"
  2254. if {$hidefind} {
  2255. lappend widlist [list h__ h_3 L 1 4 {-cw 1}]
  2256. } else {
  2257. lappend widlist [list labfnd h_3 L 1 1 "-st e" "-t {$::win::msgarray(find)}"]
  2258. lappend widlist [list Entfind labfnd L 1 1 \
  2259. {-st ew -cw 1} "-tvar [namespace current]::Foundstr -w 10"]
  2260. lappend widlist [list labfnd2 Entfind L 1 1 "-cw 2" "-t {}"]
  2261. lappend widlist [list h__ labfnd2 L 1 1]
  2262. #append binds "
  2263. # bind \[[self] Entfind\] <Return> {[self] findInText}
  2264. # bind \[[self] Entfind\] <KP_Enter> {[self] findInText}
  2265. # bind \[[self] Entfind\] <FocusIn> {\[[self] Entfind\] selection range 0 end}
  2266. # bind $qdlg <F3> {[self] findInText 1}
  2267. # bind $qdlg <Control-f> \"InitFindInText 1; focus \[[self] Entfind\]; break\"
  2268. # bind $qdlg <Control-F> \"InitFindInText 1; focus \[[self] Entfind\]; break\""
  2269. }
  2270. if {$readonly} {
  2271. if {!$hidefind} {
  2272. # append binds "
  2273. # \$pop add separator
  2274. # \$pop add command [iconA find] -accelerator Ctrl+F -label \\
  2275. # \"Find First\" -command \"[self] InitFindInText; focus \[[self] Entfind\]\"
  2276. # \$pop add command $noIMG -accelerator F3 -label \"Find Next\" \\
  2277. # -command \"[self] findInText 1\"
  2278. # $addpopup
  2279. # \$pop add separator
  2280. # \$pop add command [iconA exit] -accelerator Esc -label \"Close\" \\
  2281. # -command \"\[[self] paveoptionValue Defb1\] invoke\"
  2282. # "
  2283. } else {
  2284. set appendHL yes
  2285. }
  2286. } else {
  2287. # make bindings and popup menu for text widget
  2288. #after idle "set_highlight_matches \[TexM\]"
  2289. #append binds "
  2290. # [setTextBinds $wt]
  2291. # menu \$pop
  2292. # \$pop add command [iconA cut] -accelerator Ctrl+X -label \"Cut\" \\
  2293. # -command \"event generate $wt <<Cut>>\"
  2294. # \$pop add command [iconA copy] -accelerator Ctrl+C -label \"Copy\" \\
  2295. # -command \"event generate $wt <<Copy>>\"
  2296. # \$pop add command [iconA paste] -accelerator Ctrl+V -label \"Paste\" \\
  2297. # -command \"event generate $wt <<Paste>>\"
  2298. # [popupBlockCommands \$pop $wt]
  2299. # [popupHighlightCommands \$pop $wt]
  2300. # [popupFindCommands \$pop $wt]
  2301. # $addpopup
  2302. # \$pop add separator
  2303. # \$pop add command [iconA SaveFile] -accelerator Ctrl+W \\
  2304. # -label \"Save and Close\" -command \"[self] res $qdlg 1\"
  2305. # "
  2306. }
  2307. #set onclose [namespace current]::exitEditor
  2308. #oo::objdefine [self] export InitFindInText
  2309. } else {
  2310. lappend widlist [list h__ h_3 L 1 4 {-cw 1}]
  2311. }
  2312. } else {
  2313. lappend widlist [list chb h_3 L 1 1 \
  2314. {-st w} "-t {$chmsg} -var [namespace current]::CheckNomore"]
  2315. lappend widlist [list h_ chb L 1 1]
  2316. lappend widlist [list sev h_ L 1 1 {-st nse -cw 1}]
  2317. lappend widlist [list h__ sev L 1 1]
  2318. set appendHL $textmode
  2319. }
  2320. #if {$appendHL} {
  2321. # after idle "set_highlight_matches $wt"
  2322. # append binds "
  2323. # [popupHighlightCommands \$pop $wt]"
  2324. #}
  2325. # add the buttons
  2326. # xxx
  2327. if {$dlgname eq "RenameFile" || $dlgname eq "RenameFolder" || $dlgname eq "Find" || $dlgname eq "GotoLine"} {
  2328. set buttons [string map {"butOK OK 1" "" "butCANCEL Cancel destroy" ""} $buttons]
  2329. }
  2330. lassign [AppendButtons widlist $buttons h__ L $defb $timeout $qdlg $modal] \
  2331. bhelp bcomm
  2332. # make the dialog's window
  2333. set wtop [makeWindow $qdlg.fra $ttl]
  2334. if {$bhelp ne {}} {
  2335. bind $qdlg <F1> $bcomm
  2336. }
  2337. # pave the dialog's window
  2338. if {$tab2 eq {}} {
  2339. set widlist [rockWindow $qdlg.fra $widlist]
  2340. } else {
  2341. # pave with the notebook tabs (titl1 title2 [title3...] widlist2 [widlist3...])
  2342. lassign $tab2 ttl1 ttl2 widlist2 ttl3 widlist3 ttl4 widlist4 ttl5 widlist5
  2343. foreach nt {3 4 5} {
  2344. set ttl ttl$nt
  2345. set wdl widlist$nt
  2346. if {[set _ [set $ttl]] ne {}} {
  2347. set $ttl [list f$nt "-t {$_}"]
  2348. set $wdl [list $qdlg.fra.nbk.f$nt "[set $wdl]"]
  2349. }
  2350. }
  2351. set widlist0 [list [list nbk - - - - {pack -side top -expand 1 -fill both} [list \
  2352. f1 "-t {$ttl1}" \
  2353. f2 "-t {$ttl2}" \
  2354. {*}$ttl3 \
  2355. {*}$ttl4 \
  2356. {*}$ttl5 \
  2357. ]]]
  2358. set widlist1 [list]
  2359. foreach it $widlist {
  2360. lassign $it w nei pos r c opt atr
  2361. set opt [string map {$qdlg.fra $qdlg.fra.nbk.f1} $opt]
  2362. lappend widlist1 [list $w $nei $pos $r $c $opt $atr]
  2363. }
  2364. set widlist [rockWindow $qdlg.fra $widlist0 \
  2365. $qdlg.fra.nbk.f1 $widlist1 \
  2366. $qdlg.fra.nbk.f2 $widlist2 \
  2367. {*}$widlist3 \
  2368. {*}$widlist4 \
  2369. {*}$widlist5 \
  2370. ]
  2371. set tab2 nbk.f1.
  2372. }
  2373. if {$precom ne {}} {
  2374. {*}$precom ;# actions before showModal
  2375. }
  2376. # if {$themecolors ne {}} {
  2377. # # themed colors are set as sequentional '-theme' args
  2378. # if {[llength $themecolors]==2} {
  2379. # # when only 2 main fb/bg colors are set (esp. for TKE)
  2380. # lassign [::apave::parseOptions $optsMisc -foreground black \
  2381. # -background white -selectforeground black \
  2382. # -selectbackground gray -insertbackground black] v0 v1 v2 v3 v4
  2383. # # the rest colors should be added, namely:
  2384. # # tfg2 tbg2 tfgS tbgS tfgD tbgD tcur bclr help fI bI fM bM fW bW bHL2
  2385. # lappend themecolors $v0 $v1 $v2 $v3 $v3 $v1 $v4 $v4 $v3 $v2 $v3 $v0 $v1 black #ffff9e $v1
  2386. # }
  2387. # catch {
  2388. # my themeWindow $qdlg $themecolors no
  2389. # }
  2390. # }
  2391. # after creating widgets - show dialog texts if any
  2392. SetGetTexts set $qdlg.fra $inopts $widlist
  2393. lassign [LowercaseWidgetName $qdlg.fra.$tab2$defb] focusnow
  2394. if {$textmode} {
  2395. displayTaggedText [TexM] msg $tags
  2396. if {$defb eq "ButTEXT"} {
  2397. if {$readonly} {
  2398. lassign [LowercaseWidgetName $Defb1] focusnow
  2399. } else {
  2400. set focusnow [TexM]
  2401. catch "::tk::TextSetCursor $focusnow $curpos"
  2402. foreach k {w W} \
  2403. {catch "bind $focusnow <Control-$k> {[self] res $qdlg 1; break}"}
  2404. }
  2405. }
  2406. if {$readonly} {
  2407. readonlyWidget ::[TexM] true false
  2408. }
  2409. }
  2410. if {$focusmatch ne {}} {
  2411. foreach w $widlist {
  2412. lassign $w widname
  2413. lassign [LowercaseWidgetName $widname] wn rn
  2414. if {[string match $focusmatch $rn]} {
  2415. lassign [LowercaseWidgetName $qdlg.fra.$wn] focusnow
  2416. break
  2417. }
  2418. }
  2419. }
  2420. catch "$binds"
  2421. set args [removeOptions $args -focus]
  2422. set querydlg $qdlg
  2423. showModal $qdlg -modal $modal -waitvar $waitvar -onclose $onclose \
  2424. -focus $focusnow -geometry $geometry {*}$minsize {*}$args
  2425. if {![winfo exists $qdlg] || (!$modal && !$waitvar)} {
  2426. return 0
  2427. }
  2428. set pdgeometry [wm geometry $qdlg]
  2429. # the dialog's result is defined by "pave res" + checkbox's value
  2430. # xxx
  2431. #tk_messageBox -title $dan(TITLE) -icon info -message $qdlg
  2432. set res [set result [::radxide::win::res $qdlg]]
  2433. #tk_messageBox -title $dan(TITLE) -icon info -message resX=$res
  2434. set chv $CheckNomore
  2435. if { [string is integer $res] } {
  2436. if {$res && $chv} { incr result 10 }
  2437. } else {
  2438. set res [expr {$result ne {} ? 1 : 0}]
  2439. if {$res && $chv} { append result 10 }
  2440. }
  2441. if {$textmode && !$readonly} {
  2442. set focusnow [TexM]
  2443. set textcont [$focusnow get 1.0 end]
  2444. if {$res && $postcom ne {}} {
  2445. {*}$postcom textcont [TexM] ;# actions after showModal
  2446. }
  2447. set textcont " [$focusnow index insert] $textcont"
  2448. } else {
  2449. set textcont {}
  2450. }
  2451. if {$res && $inopts ne {}} {
  2452. SetGetTexts get $qdlg.fra $inopts $widlist
  2453. set inopts " [GetVarsValues $widlist]"
  2454. } else {
  2455. set inopts {}
  2456. }
  2457. if {$textmode && $rotext ne {}} {
  2458. set $rotext [string trimright [TexM] get 1.0 end]]
  2459. }
  2460. if {!$stay} {
  2461. destroy $qdlg
  2462. update
  2463. # pause a bit and restore the old focus
  2464. if {$focusback ne {} && [winfo exists $focusback]} {
  2465. set w ".[lindex [split $focusback .] 1]"
  2466. after 50 [list if "\[winfo exist $focusback\]" "focus -force $focusback" elseif "\[winfo exist $w\]" "focus $w"]
  2467. } else {
  2468. after 50 list focus .
  2469. }
  2470. }
  2471. if {$wasgeo} {
  2472. lassign [splitGeometry $pdgeometry] w h x y
  2473. catch {
  2474. # geometry option can contain pointer/root etc.
  2475. if {abs($x-$gx)<30} {set x $gx}
  2476. if {abs($y-$gy)<30} {set y $gy}
  2477. }
  2478. return [list $result ${w}x$h$x$y $textcont [string trim $inopts]]
  2479. }
  2480. return "$result$textcont$inopts"
  2481. }
  2482. # ________________________ readonlyWidget _________________________ #
  2483. proc readonlyWidget {w {on yes} {popup yes}} {
  2484. # Switches on/off a widget's readonly state for a text widget.
  2485. # w - text widget's path
  2486. # on - "on/off" boolean flag
  2487. # popup - "make popup menu" boolean flag
  2488. # See also:
  2489. # [wiki.tcl-lang.org](https://wiki.tcl-lang.org/page/Read-only+text+widget)
  2490. #my TextCommandForChange $w {} $on
  2491. #if {$popup} {my makePopup $w $on yes}
  2492. return
  2493. }
  2494. proc readTextFile {fileName {varName ""} {doErr 0} args} {
  2495. # Reads a text file.
  2496. # fileName - file name
  2497. # varName - variable name for file content or ""
  2498. # doErr - if 'true', exit at errors with error message
  2499. # Returns file contents or "".
  2500. variable _PU_opts
  2501. if {$varName ne {}} {upvar $varName fvar}
  2502. if {[catch {set chan [open $fileName]} _PU_opts(_ERROR_)]} {
  2503. if {$doErr} {error [::radxide::win::error $fileName]}
  2504. set fvar {}
  2505. } else {
  2506. set enc [getOption -encoding {*}$args]
  2507. set eol [string tolower [getOption -translation {*}$args]]
  2508. if {$eol eq {}} {set eol auto} ;# let EOL be autodetected by default
  2509. textChanConfigure $chan $enc $eol
  2510. set fvar [read $chan]
  2511. close $chan
  2512. logMessage "read $fileName"
  2513. }
  2514. return $fvar
  2515. }
  2516. # ________________________ renameFileOK _________________________ #
  2517. proc renameFileOK {} {
  2518. namespace upvar ::radxide dan dan project project
  2519. variable dlg
  2520. #set t $Dlgpath.fra.fraM.fraent.ent
  2521. set t [dlgPath].fra.[FieldName [lindex [getDialogField 0] 0]]
  2522. #tk_messageBox -title $dan(TITLE) -icon info -message textbox=$t
  2523. set varname [lindex [getDialogField end] 0]
  2524. #tk_messageBox -title $dan(TITLE) -icon info -message varname=$varname
  2525. set oldpath [lindex [getDialogField end] 1]
  2526. #tk_messageBox -title $dan(TITLE) -icon info -message oldpath=$oldpath
  2527. set newpath [string trim [$t get]]
  2528. #tk_messageBox -title $dan(TITLE) -icon info -message newpath=$newpath
  2529. set pathlength [expr [string length $newpath]-1]
  2530. if {[string range $newpath $pathlength $pathlength] eq "/"} {
  2531. tk_messageBox -title $dan(TITLE) -icon info -message "Destination can't be a folder!"
  2532. return 0
  2533. }
  2534. if {[string first $dan(WORKDIR) $newpath] eq -1} {
  2535. tk_messageBox -title $dan(TITLE) -icon info -message "New file path outside the Working Dir!"
  2536. return 0
  2537. }
  2538. if {[string first $project(ROOT) $newpath] eq -1} {
  2539. tk_messageBox -title $dan(TITLE) -icon info -message "New file path outside the Project Dir!"
  2540. return 0
  2541. }
  2542. if {[catch {file rename $oldpath $newpath} e]} {
  2543. set msg "\nERROR in win:"
  2544. puts \n$msg\n\n$e$::errorInfo\n
  2545. set msg "$msg\n\n$e\n\nPlease, inform authors.\nDetails are in stdout."
  2546. tk_messageBox -title $dan(TITLE) -icon error -message $msg
  2547. return 0
  2548. }
  2549. # saving {field oldval newval} for later use
  2550. editDialogField end $varname $oldpath $newpath
  2551. ::radxide::tree::create
  2552. # Workaround for an overwheling activation of the main text editor..
  2553. if {$project(CUR_FILE_PATH) eq ""} {
  2554. $dan(TEXT) configure -state disabled
  2555. }
  2556. catch {destroy [dlgPath]}
  2557. return 1
  2558. }
  2559. # ________________________ renameFileCancel _________________________ #
  2560. proc renameFileCancel {} {
  2561. #catch {[destroy .danwin.diaRenameFile1]}
  2562. catch {[destroy [dlgPath]]}
  2563. return 0
  2564. }
  2565. # ________________________ renameFolderOK _________________________ #
  2566. proc renameFolderOK {} {
  2567. namespace upvar ::radxide dan dan project project
  2568. variable dlg
  2569. #set t $Dlgpath.fra.fraM.fraent.ent
  2570. set t [dlgPath].fra.[FieldName [lindex [getDialogField 0] 0]]
  2571. #tk_messageBox -title $dan(TITLE) -icon info -message textbox=$t
  2572. set varname [lindex [getDialogField end] 0]
  2573. #tk_messageBox -title $dan(TITLE) -icon info -message varname=$varname
  2574. set oldpath [lindex [getDialogField end] 1]
  2575. #tk_messageBox -title $dan(TITLE) -icon info -message oldpath=$oldpath
  2576. set newpath [string trim [$t get]]
  2577. #tk_messageBox -title $dan(TITLE) -icon info -message newpath=$newpath
  2578. set oldparent [string range $oldpath 0 [expr [string last "/" $oldpath]-1]]
  2579. #tk_messageBox -title $dan(TITLE) -icon info -message oldparent=$oldparent
  2580. set newparent [string range $newpath 0 [expr [string last "/" $newpath]-1]]
  2581. #tk_messageBox -title $dan(TITLE) -icon info -message newparent=$newparent
  2582. set pathlength [expr [string length $newpath]-1]
  2583. if {[string range $newpath $pathlength $pathlength] eq "/"} {
  2584. tk_messageBox -title $dan(TITLE) -icon info -message "Please delete the final '\/'!"
  2585. return 0
  2586. }
  2587. if {[string first $dan(WORKDIR) $newpath] eq -1} {
  2588. tk_messageBox -title $dan(TITLE) -icon info -message "New file path outside the Working Dir!"
  2589. return 0
  2590. }
  2591. if {[string first $project(ROOT) $newpath] eq -1} {
  2592. tk_messageBox -title $dan(TITLE) -icon info -message "New file path outside the Project Dir!"
  2593. return 0
  2594. }
  2595. if {$oldparent ne $newparent} {
  2596. tk_messageBox -title $dan(TITLE) -icon info -message "Change of parent folder disallowed!"
  2597. return 0
  2598. }
  2599. if {[catch {file rename $oldpath $newpath} e]} {
  2600. set msg "\nERROR in win:"
  2601. puts \n$msg\n\n$e$::errorInfo\n
  2602. set msg "$msg\n\n$e\n\nPlease, inform authors.\nDetails are in stdout."
  2603. tk_messageBox -title $dan(TITLE) -icon error -message $msg
  2604. return 0
  2605. }
  2606. # savind {field oldval newval} for later use
  2607. editDialogField end $varname $oldpath $newpath
  2608. ::radxide::tree::create
  2609. # Workaround for an overwheling activation of the main text editor..
  2610. if {$project(CUR_FILE_PATH) eq ""} {
  2611. $dan(TEXT) configure -state disabled
  2612. }
  2613. catch {destroy [dlgPath]}
  2614. return 1
  2615. }
  2616. # ________________________ renameFolderCancel _________________________ #
  2617. proc renameFolderCancel {} {
  2618. #catch {[destroy .danwin.diaRenameFolder1]}
  2619. catch {[destroy [dlgPath]]}
  2620. return 0
  2621. }
  2622. # ________________________ Replace_Tcl _________________________ #
  2623. proc Replace_Tcl {r1 r2 r3 args} {
  2624. # Replaces Tcl code with its resulting items in *lwidgets* list.
  2625. # r1 - variable name for a current index in *lwidgets* list
  2626. # r2 - variable name for a length of *lwidgets* list
  2627. # r3 - variable name for *lwidgets* list
  2628. # args - "tcl" and "tcl code" for "tcl" type of widget
  2629. # The code should use the wildcard that goes first at a line:
  2630. # %C - a command for inserting an item into lwidgets list.
  2631. # The "tcl" widget type can be useful to automate the inserting
  2632. # a list of similar widgets to the list of widgets.
  2633. # See tests/test2_pave.tcl where the "tcl" fills "Color schemes" tab.
  2634. lassign $args _name _code
  2635. if {[ownWName $_name] ne {tcl}} {return $args}
  2636. upvar 1 $r1 _ii $r2 _lwlen $r3 _lwidgets
  2637. ; proc lwins {lwName i w} {
  2638. upvar 2 $lwName lw
  2639. set lw [linsert $lw $i $w]
  2640. }
  2641. set _lwidgets [lreplace $_lwidgets $_ii $_ii] ;# removes tcl item
  2642. set _inext [expr {$_ii-1}]
  2643. eval [string map {%C {lwins $r3 [incr _inext] }} $_code]
  2644. return {}
  2645. }
  2646. # ________________________ removeOptions _________________________ #
  2647. proc removeOptions {options args} {
  2648. # Removes some options from a list of options.
  2649. # options - list of options and values
  2650. # args - list of option names to remove
  2651. # The `options` may contain "key value" pairs and "alone" options
  2652. # without values.
  2653. # To remove "key value" pairs, `key` should be an exact name.
  2654. # To remove an "alone" option, `key` should be a glob pattern with `*`.
  2655. foreach key $args {
  2656. while {[incr maxi]<99} {
  2657. if {[set i [lsearch -exact $options $key]]>-1} {
  2658. catch {
  2659. # remove a pair "option value"
  2660. set options [lreplace $options $i $i]
  2661. set options [lreplace $options $i $i]
  2662. }
  2663. } elseif {[string first * $key]>=0 && \
  2664. [set i [lsearch -glob $options $key]]>-1} {
  2665. # remove an option only
  2666. set options [lreplace $options $i $i]
  2667. } else {
  2668. break
  2669. }
  2670. }
  2671. }
  2672. return $options
  2673. }
  2674. # ________________________ res _________________________ #
  2675. proc res {{win {}} {result get}} {
  2676. # Gets/sets a variable for *vwait* command.
  2677. # win - window's path
  2678. # result - value of variable
  2679. # This method is used when
  2680. # - an event cycle should be stopped with changing a variable's value
  2681. # - a result of event cycle (the variable's value) should be got
  2682. # In the first case, *result* is set to an integer. In *apave* dialogs
  2683. # the integer is corresponding a pressed button's index.
  2684. # In the second case, *result* is omitted or equal to "get".
  2685. # Returns a value of variable that controls an event cycle.
  2686. if {$win eq {}} {set win [dlgPath]}
  2687. set varname [WinVarname $win]
  2688. if {$result eq {get}} {
  2689. return [set $varname]
  2690. }
  2691. #CleanUps $win
  2692. return [set $varname $result]
  2693. }
  2694. # ___________________ rockWindow _________________ #
  2695. proc rockWindow {args} {
  2696. # Processes "win / list_of_widgets" pairs.
  2697. # args - list of pairs "win / lwidgets"
  2698. # The *win* is a window's path. The *lwidgets* is a list of widget items.
  2699. # Each widget item contains:
  2700. # name - widget's name (first 3 characters define its type)
  2701. # neighbor - top or left neighbor of the widget
  2702. # posofnei - position of neighbor: T (top) or L (left)
  2703. # rowspan - row span of the widget
  2704. # colspan - column span of the widget
  2705. # options - grid/pack options
  2706. # attrs - attributes of widget
  2707. # First 3 items are mandatory, others are set at need.
  2708. # This method calls *paveWindow* in a cycle, to process a current "win/lwidgets" pair.
  2709. namespace upvar ::radxide dan dan
  2710. #tk_messageBox -title $dan(TITLE) -icon info -message "Start rock-Window!"
  2711. set res [list]
  2712. set wmain [set wdia {}]
  2713. foreach {w lwidgets} $args {
  2714. if {[lindex $lwidgets 0 0] eq {after}} {
  2715. # if 1st item is "after idle" or like "after 1000", layout the window after...
  2716. # (fit for "invisible independent" windows/frames/tabs)
  2717. set what [lindex $lwidgets 0 1]
  2718. if {$what eq {idle} || [string is integer -strict $what]} {
  2719. after $what [rockWindow $w [lrange $lwidgets 1 end]]
  2720. #after $what [list [self] colorWindow $w -doit]
  2721. }
  2722. continue
  2723. }
  2724. lappend res {*}[Window $w $lwidgets]
  2725. if {[set ifnd [regexp -indices -inline {[.]dia\d+} $w]] ne {}} {
  2726. set wdia [string range $w 0 [lindex $ifnd 0 1]]
  2727. } else {
  2728. set wmain .[lindex [split $w .] 1]
  2729. }
  2730. }
  2731. # add a system Menu binding for the created window
  2732. #if {[winfo exists $wdia]} {::apave::initPOP $wdia} elseif {
  2733. # [winfo exists $wmain]} {::apave::initPOP $wmain}
  2734. return $res
  2735. }
  2736. # ________________________ Search _________________________ #
  2737. # proc Search {wtxt} {
  2738. # # Searches a text for a string to find.
  2739. # # wtxt - text widget's path
  2740. #
  2741. # namespace upvar ::alited obPav obPav
  2742. # variable counts
  2743. # variable data
  2744. # set idx [$wtxt index insert]
  2745. # #lassign [FindOptions $wtxt] findstr options
  2746. # set options {}
  2747. # set findstr $data(en1)
  2748. # if {![CheckData find]} {return {}}
  2749. # $obPav set_HighlightedString $findstr
  2750. # SetTags $wtxt
  2751. # lassign [Search1 $wtxt 1.0] err fnd
  2752. # if {$err} {return {}}
  2753. # set i 0
  2754. # set res [list]
  2755. # foreach index1 $fnd {
  2756. # set index2 [$wtxt index "$index1 + [lindex $counts $i]c"]
  2757. # if {[CheckWord $wtxt $index1 $index2]} {
  2758. # lappend res [list $index1 $index2]
  2759. # }
  2760. # incr i
  2761. # }
  2762. # return $res
  2763. # }
  2764. #_______________________ selectedWordText _____________________ #
  2765. proc selectedWordText {txt} {
  2766. # Returns a word under the cursor or a selected text.
  2767. # txt - the text's path
  2768. set seltxt {}
  2769. if {![catch {$txt tag ranges sel} seltxt]} {
  2770. if {$seltxt eq ""} {return ""}
  2771. set forword [expr {$seltxt eq {}}]
  2772. #if {[set forword [expr {$seltxt eq {}}]]} {
  2773. # set pos [$txt index "insert wordstart"]
  2774. # set pos2 [$txt index "insert wordend"]
  2775. # set seltxt [string trim [$txt get $pos $pos2]]
  2776. # if {![string is wordchar -strict $seltxt]} {
  2777. # # when cursor just at the right of word: take the word at the left
  2778. # set pos [$txt index "insert -1 char wordstart"]
  2779. # set pos2 [$txt index "insert -1 char wordend"]
  2780. # }
  2781. #} else {
  2782. lassign $seltxt pos pos2
  2783. #}
  2784. #catch {
  2785. set seltxt [$txt get $pos $pos2]
  2786. if {[set sttrim [string trim $seltxt]] ne {}} {
  2787. if {$forword} {set seltxt $sttrim}
  2788. }
  2789. #}
  2790. }
  2791. return $seltxt
  2792. }
  2793. # ________________________ setAppIcon _________________________ #
  2794. proc setAppIcon {win {winicon ""}} {
  2795. # Sets application's icon.
  2796. # win - path to a window of application
  2797. # winicon - data of icon
  2798. # The *winicon* may be a contents of variable (as supposed by default) or
  2799. # a file's name containing th image data.
  2800. # If it fails to find an image in either, no icon is set.
  2801. set appIcon {}
  2802. if {$winicon ne {}} {
  2803. if {[catch {set appIcon [image create photo -data $winicon]}]} {
  2804. catch {set appIcon [image create photo -file $winicon]}
  2805. }
  2806. }
  2807. if {$appIcon ne {}} {wm iconphoto $win -default $appIcon}
  2808. }
  2809. # ________________________ SetGetTexts _________________________ #
  2810. proc SetGetTexts {oper w iopts lwidgets} {
  2811. # Sets/gets contents of text fields.
  2812. # oper - "set" to set, "get" to get contents of text field
  2813. # w - window's name
  2814. # iopts - equals to "" if no operation
  2815. # lwidgets - list of widget items
  2816. if {$iopts eq {}} return
  2817. foreach widg $lwidgets {
  2818. set wname [lindex $widg 0]
  2819. set name [ownWName $wname]
  2820. if {[string range $name 0 1] eq "te"} {
  2821. set vv [::radxide::win::varName $name]
  2822. if {$oper eq "set"} {
  2823. displayText $w.$wname [set $vv]
  2824. } else {
  2825. set $vv [string trimright [$w.$wname get 1.0 end]]
  2826. }
  2827. }
  2828. }
  2829. return
  2830. }
  2831. # ________________________ set_HighlightedString _________________________ #
  2832. proc set_HighlightedString {sel} {
  2833. # Saves a string got from highlighting by Alt+left/right/q/w.
  2834. # sel - the string to be saved
  2835. set HLstring $sel
  2836. if {$sel ne {}} {set Foundstr $sel}
  2837. }
  2838. # ________________________ set_highlight_matches _________________________ #
  2839. proc set_highlight_matches {w} {
  2840. # Creates bindings to highlight matches in a text.
  2841. # w - path to the text
  2842. }
  2843. # ________________________ setTextBinds _________________________ #
  2844. proc setTextBinds {wt} {
  2845. # Returns bindings for a text widget.
  2846. # wt - the text's path
  2847. set res ""
  2848. return $res
  2849. }
  2850. # ________________________ showModal _________________________ #
  2851. proc showModal {win args} {
  2852. # Shows a window as modal.
  2853. # win - window's name
  2854. # args - attributes of window ("-name value" pairs)
  2855. namespace upvar ::radxide dan dan
  2856. variable MODALWINDOW
  2857. set MODALWINDOW [set Modalwin $win]
  2858. setAppIcon $win
  2859. lassign [extractOptions args -centerme {} -ontop 0 -modal yes -minsize {} \
  2860. -themed {} -input 0 -variable {} -waitvar {} -transient {-} -root {} -parent {}] \
  2861. centerme ontop modal minsize themed input varname waitvar transient root parent
  2862. $win configure -bg $dan(BG) ;# removes blinking by default bg
  2863. #if {$themed in {{} {0}} && [my csCurrent] != [apave::cs_Non]} {
  2864. # my colorWindow $win
  2865. #}
  2866. if {$centerme eq {}} {
  2867. # obsolete options: -root, -parent
  2868. if {$root ne {}} {set centerme $root} {set centerme $parent}
  2869. }
  2870. set root [winfo parent $win]
  2871. set rooted 1
  2872. if {$centerme ne {}} {
  2873. ;# forced centering relative to a caller's window
  2874. lassign [split $centerme x+] rw rh rx ry
  2875. set rooted [expr {![regexp {[+|-]+\d+\++} $centerme]}]
  2876. if {$rooted && [winfo exist $centerme]} {
  2877. set root $centerme
  2878. }
  2879. }
  2880. set decor [expr {$root in {{} .}}]
  2881. foreach {o v} [list -decor $decor -focus {} -onclose {} -geometry {} \
  2882. -resizable {} -ontop 0 -escape 1 -checkgeometry 1] {
  2883. lappend defargs $o [getShowOption $o $v]
  2884. }
  2885. if {$varname ne {}} {
  2886. set waitvar 1
  2887. } else {
  2888. set waitvar [string is true $waitvar] ;# default 1: wait for closing the window
  2889. set varname [WinVarname $win]
  2890. }
  2891. array set opt [list {*}$defargs {*}$args]
  2892. if {$ontop eq {}} {
  2893. if {$opt(-ontop)} {
  2894. set ontop yes
  2895. } else {
  2896. set ontop no
  2897. catch {
  2898. set ontop [wm attributes [winfo parent $win] -topmost]
  2899. }
  2900. if {!$ontop} {
  2901. # find if a window child of "." is topmost
  2902. # if so, let this one be topmost too
  2903. foreach w [winfo children .] {
  2904. catch {set ontop [wm attributes $w -topmost]}
  2905. if {$ontop} break
  2906. }
  2907. }
  2908. }
  2909. }
  2910. if {$rooted} {
  2911. lassign [splitGeometry [wm geometry [winfo toplevel $root]]] rw rh rx ry
  2912. }
  2913. if {$transient ne {-}} {
  2914. wm transient $win $transient
  2915. } elseif {!$opt(-decor)} {
  2916. wm transient $win $root
  2917. }
  2918. if {[set destroy [expr {$opt(-onclose) eq {destroy}}]]} {
  2919. set opt(-onclose) {}
  2920. }
  2921. if {$opt(-onclose) eq {}} {
  2922. set opt(-onclose) "set $varname 0"
  2923. } else {
  2924. set opt(-onclose) "$opt(-onclose) $varname" ;# $opt(-onclose) is a command
  2925. }
  2926. #if {$destroy} {append opt(-onclose) " ; destroy $win"}
  2927. if {$destroy} {append opt(-onclose) " ; destroy $win"}
  2928. if {$opt(-resizable) ne {}} {
  2929. if {[string is boolean $opt(-resizable)]} {
  2930. set opt(-resizable) "$opt(-resizable) $opt(-resizable)"
  2931. }
  2932. wm resizable $win {*}$opt(-resizable)
  2933. }
  2934. if {!($modal || $waitvar)} {
  2935. append opt(-onclose) "; CleanUps $win"
  2936. }
  2937. wm protocol $win WM_DELETE_WINDOW $opt(-onclose)
  2938. # get the window's geometry from its requested sizes
  2939. set inpgeom $opt(-geometry)
  2940. if {$inpgeom eq {}} {
  2941. # this is for less blinking:
  2942. set opt(-geometry) [centeredXY $win $rw $rh $rx $ry \
  2943. [winfo reqwidth $win] [winfo reqheight $win]]
  2944. } elseif {[string first pointer $inpgeom]==0} {
  2945. lassign [split $inpgeom+0+0 +] -> x y
  2946. set inpgeom +[expr {$x+[winfo pointerx .]}]+[expr {$y+[winfo pointery .]}]
  2947. set opt(-geometry) $inpgeom
  2948. } elseif {[string first root $inpgeom]==0} {
  2949. set root .[string trimleft [string range $inpgeom 5 end] .]
  2950. set opt(-geometry) [set inpgeom {}]
  2951. }
  2952. if {$opt(-geometry) ne {}} {
  2953. lassign [splitGeometry $opt(-geometry) {} {}] - - x y
  2954. if {$x ne {}} {wm geometry $win $x$y}
  2955. }
  2956. if {$opt(-focus) eq {}} {
  2957. set opt(-focus) $win
  2958. }
  2959. set $varname {-}
  2960. if {$opt(-escape)} {bind $win <Escape> $opt(-onclose)}
  2961. update
  2962. if {![winfo exists $win]} {
  2963. return 0 ;# looks idiotic, yet possible at sporadic calls
  2964. }
  2965. set w [winfo reqwidth $win]
  2966. set h [winfo reqheight $win]
  2967. if {$inpgeom eq {}} { ;# final geometrizing with actual sizes
  2968. set geo [centeredXY $win $rw $rh $rx $ry $w $h]
  2969. set y [lindex [split $geo +] end]
  2970. if {!$rooted || $root ne {.} && (($h/2-$ry-$rh/2)>30 || [::radxide::iswindows] && $y>0)} {
  2971. # ::tk::PlaceWindow needs correcting in rare cases, namely:
  2972. # when 'root' is of less sizes than 'win' and at screen top
  2973. wm geometry $win $geo
  2974. } else {
  2975. ::tk::PlaceWindow $win widget $root
  2976. }
  2977. } else {
  2978. lassign [splitGeometry $inpgeom {} {}] - - x y
  2979. if {$x ne {} && $y ne {} && [string first x $inpgeom]<0 && $opt(-checkgeometry)} {
  2980. set inpgeom [checkXY $win $w $h $x $y]
  2981. } elseif {$x eq {} && $y eq {} && $centerme ne {} && $opt(-geometry) ne {}} {
  2982. lassign [split $opt(-geometry) x+] w h
  2983. lassign [split [centeredXY $win $rw $rh $rx $ry $w $h] +] -> x y
  2984. set inpgeom ${w}x$h+$x+$y
  2985. }
  2986. wm geometry $win $inpgeom
  2987. }
  2988. after 50 [list if "\[winfo exist $opt(-focus)\]" "focus -force $opt(-focus)"]
  2989. #if {[info exists ::transpops::my::cntwait]} {
  2990. # # this specific bind - for transpops package (to hide a demo message by keys)
  2991. # bind $win <Control-Alt-0> {set ::transpops::my::cntwait 0}
  2992. #}
  2993. showWindow $win $modal $ontop $varname $minsize $waitvar
  2994. set res 0
  2995. #catch {
  2996. if {$modal || $waitvar} {CleanUps $win}
  2997. if {[winfo exists $win]} {
  2998. if {$input} {GetOutputValues}
  2999. set res [set [set _ $varname]]
  3000. }
  3001. #}
  3002. return $res
  3003. }
  3004. # ________________________ showWindow _________________________ #
  3005. proc showWindow {win modal ontop {var ""} {minsize ""} {waitvar 1}} {
  3006. # Displays a windows and goes in tkwait cycle to interact with a user.
  3007. # win - the window's path
  3008. # modal - yes at showing the window as modal
  3009. # ontop - yes at showing the window as topmost
  3010. # var - variable's name to receive a result (tkwait's variable)
  3011. # minsize - list {minwidth minheight} or {}
  3012. # waitvar - if yes, force tkwait variable (mostly for non-modal windows)
  3013. InfoWindow [expr {[InfoWindow] + 1}] $win $modal $var yes
  3014. #::apave::deiconify $win
  3015. if {$minsize eq {}} {
  3016. set minsize [list [winfo width $win] [winfo height $win]]
  3017. }
  3018. wm minsize $win {*}$minsize
  3019. bind $win <Configure> "[namespace current]::WinResize $win"
  3020. if {$ontop} {wm attributes $win -topmost 1}
  3021. if {$modal} {
  3022. # modal window:
  3023. waitWinVar $win $var $modal
  3024. InfoWindow [expr {[InfoWindow] - 1}] $win $modal $var
  3025. } else {
  3026. # non-modal window:
  3027. if {[set wgr [grab current]] ne {}} {
  3028. # otherwise the non-modal window is irresponsive (in Windows even at WM level):
  3029. grab release $wgr
  3030. }
  3031. if {$waitvar && $var ne {}} {
  3032. waitWinVar $win $var $modal ;# show and wait for closing the window
  3033. }
  3034. }
  3035. }
  3036. # ________________________ setShowOption _________________________ #
  3037. proc setShowOption {name args} {
  3038. # Sets / gets a default show option, used in showModal.
  3039. # name - name of option
  3040. # args - value of option
  3041. # See also: showModal
  3042. setProperty [ShowOption $name] {*}$args
  3043. }
  3044. # ________________________ setProperty _________________________ #
  3045. proc setProperty {name args} {
  3046. # Sets a property's value as "application-wide".
  3047. # name - name of property
  3048. # args - value of property
  3049. # If *args* is omitted, the method returns a property's value.
  3050. # If *args* is set, the method sets a property's value as $args.
  3051. variable _AP_Properties
  3052. switch -exact [llength $args] {
  3053. 0 {return [getProperty $name]}
  3054. 1 {return [set _AP_Properties($name) [lindex $args 0]]}
  3055. }
  3056. puts -nonewline stderr \
  3057. "Wrong # args: should be \"::win::setProperty propertyname ?value?\""
  3058. return -code error
  3059. }
  3060. # ________________________ ShowOption _________________________ #
  3061. proc ShowOption {name} {
  3062. # Gets a default show option, used in showModal.
  3063. # name - name of option
  3064. # See also: getShowOption, setShowOption
  3065. return "_SHOWMODAL_$name"
  3066. }
  3067. # ________________________ SpanConfig _________________________ #
  3068. proc SpanConfig {w rcnam rc rcspan opt val} {
  3069. # The method is used by *GetIntOptions* method to configure
  3070. # row/column for their *span* options.
  3071. for {set i $rc} {$i < ($rc + $rcspan)} {incr i} {
  3072. eval [grid ${rcnam}configure $w $i $opt $val]
  3073. }
  3074. return
  3075. }
  3076. # ________________________ splitGeometry _________________________ #
  3077. proc splitGeometry {geom {X +0} {Y +0}} {
  3078. # Gets widget's geometry components.
  3079. # geom - geometry
  3080. # X - default X-coordinate
  3081. # Y - default Y-coordinate
  3082. # Returns a list of width, height, X and Y (coordinates are always with + or -).
  3083. lassign [split $geom x+-] w h
  3084. lassign [regexp -inline -all {([+-][[:digit:]]+)} $geom] -> x y
  3085. if {$geom ne {}} {
  3086. if {$x in {"" 0} || [catch {expr {$x+0}}]} {set x $X}
  3087. if {$y in {"" 0} || [catch {expr {$y+0}}]} {set y $Y}
  3088. }
  3089. return [list $w $h $x $y]
  3090. }
  3091. # ________________________ textChanConfigure _________________________ #
  3092. proc textChanConfigure {channel {coding {}} {eol {}}} {
  3093. # Configures a channel for text file.
  3094. # channel - the channel
  3095. # coding - if set, defines encoding of the file
  3096. # eol - if set, defines EOL of the file
  3097. if {$coding eq {}} {
  3098. chan configure $channel -encoding utf-8
  3099. } else {
  3100. chan configure $channel -encoding $coding
  3101. }
  3102. if {$eol eq {}} {
  3103. chan configure $channel {*}[textEOL translation]
  3104. } else {
  3105. chan configure $channel -translation $eol
  3106. }
  3107. }
  3108. # ________________________ textEOL _________________________ #
  3109. proc textEOL {{EOL "-"}} {
  3110. # Gets/sets End-of-Line for text reqding/writing.
  3111. # EOL - LF, CR, CRLF or {}
  3112. # If EOL omitted or equals to {} or "-", return the current EOL.
  3113. # If EOL equals to "translation", return -translation option or {}.
  3114. variable _PU_opts
  3115. if {$EOL eq "-"} {return $_PU_opts(_EOL_)}
  3116. if {$EOL eq "translation"} {
  3117. if {$_PU_opts(_EOL_) eq ""} {return ""}
  3118. return "-translation $_PU_opts(_EOL_)"
  3119. }
  3120. set _PU_opts(_EOL_) [string trim [string tolower $EOL]]
  3121. }
  3122. # ________________________ TreSelect _________________________ #
  3123. proc TreSelect {w idx} {
  3124. # Selects a treeview item.
  3125. # w - treeview's path
  3126. # idx - item index
  3127. set items [$w children {}]
  3128. catch {
  3129. set it [lindex $items $idx]
  3130. $w see $it
  3131. $w focus $it
  3132. $w selection set $it ;# generates <<TreeviewSelect>>
  3133. }
  3134. }
  3135. # ________________________ varName _________________________ #
  3136. proc varName {wname} {
  3137. # Gets a variable name associated with a widget's name of "input" dialogue.
  3138. # wname - widget's name
  3139. return [namespace current]::var$wname
  3140. }
  3141. # ________________________ waitWinVar _________________________ #
  3142. proc waitWinVar {win var modal} {
  3143. # Tk waiting for variable's change.
  3144. # win - the window's path
  3145. # var - variable's name to receive a result (tkwait's variable)
  3146. # modal - yes at showing the window as modal
  3147. # first of all, wait till the window be visible
  3148. after 1 ;# solves an issue with doubleclicking buttons
  3149. if {![winfo viewable $win]} {
  3150. tkwait visibility $win
  3151. }
  3152. set wmain [winfo parent $win]
  3153. if {$modal} { ;# for modal, grab the window
  3154. set wgr [grab current]
  3155. if {$wmain ne {} && $wmain ne $win} {
  3156. if {[catch {grab set $win} e]} {
  3157. catch {tkwait visibility $win} ;# 2nd attempt to get the window visible, by force
  3158. catch {grab set $win} ;# (not sure, where it can fire, still let it be)
  3159. puts stderr "\n::radxide::win::waitWinVar - please send a note to apave developers on this catch. Error: $e"
  3160. catch {puts stderr "::radxide::win::waitWinVar - [info level -1]\n"}
  3161. }
  3162. }
  3163. }
  3164. # at need, wait till the window associated variable be changed
  3165. if {$var ne {}} {
  3166. tkwait variable $var
  3167. }
  3168. if {$modal} { ;# for modal, release the grab and restore the old one
  3169. catch {grab release $win}
  3170. if {$wgr ne {}} {
  3171. catch {grab set $wgr}
  3172. }
  3173. }
  3174. }
  3175. # ________________________ widgetType _________________________ #
  3176. proc widgetType {wnamefull options attrs} {
  3177. # Gets the widget type based on 3 initial letters of its name. Also
  3178. # fills the grid/pack options and attributes of the widget.
  3179. # wnamefull - path to the widget
  3180. # options - grid/pack options of the widget
  3181. # attrs - attribute of the widget
  3182. # Returns a list of items:
  3183. # widget - Tk/Ttk widget name
  3184. # options - grid/pack options of the widget
  3185. # attrs - attribute of the widget
  3186. # nam3 - 3 initial letters of widget's name
  3187. # disabled - flag of *disabled* state
  3188. set disabled [expr {[getOption -state {*}$attrs] eq {disabled}}]
  3189. set pack $options
  3190. set name [ownWName $wnamefull]
  3191. #if {[info exists ::apave::_AP_VARS(ProSplash,type)] && \
  3192. #$::apave::_AP_VARS(ProSplash,type) eq {}} {
  3193. # set val [my progress_Go [incr ::apave::_AP_VARS(ProSplash,curvalue)] {} $name]
  3194. #}
  3195. set nam3 [string tolower [string index $name 0]][string range $name 1 2]
  3196. if {[string index $nam3 1] eq "_"} {set k [string range $nam3 0 1]} {set k $nam3}
  3197. lassign [defaultATTRS $k] defopts defattrs newtype
  3198. set options "$defopts $options"
  3199. set attrs "$defattrs $attrs"
  3200. switch -glob -- $nam3 {
  3201. #bts {
  3202. # set widget ttk::frame
  3203. # if {![info exists ::bartabs::NewBarID]} {package require bartabs}
  3204. # set attrs "-bartabs {$attrs}"
  3205. #}
  3206. but {
  3207. set widget ttk::button
  3208. AddButtonIcon $name attrs
  3209. }
  3210. buT - btT {
  3211. set widget button
  3212. AddButtonIcon $name attrs
  3213. }
  3214. can {set widget canvas}
  3215. chb {set widget ttk::checkbutton}
  3216. swi {
  3217. set widget ttk::checkbutton
  3218. #if {![my apaveTheme]} {
  3219. # set attrs "$attrs -style Switch.TCheckbutton"
  3220. #}
  3221. }
  3222. chB {set widget checkbutton}
  3223. cbx - fco {
  3224. set widget ttk::combobox
  3225. if {$nam3 eq {fco}} { ;# file content combobox
  3226. set attrs [FCfieldValues $wnamefull $attrs]
  3227. }
  3228. set attrs [FCfieldAttrs $wnamefull $attrs -tvar]
  3229. }
  3230. ent {set widget ttk::entry}
  3231. enT {set widget entry}
  3232. fil - fiL -
  3233. fis - fiS -
  3234. dir - diR -
  3235. fon - foN -
  3236. clr - clR -
  3237. dat - daT -
  3238. sta -
  3239. too -
  3240. fra {
  3241. # + frame for choosers and bars
  3242. set widget ttk::frame
  3243. }
  3244. frA {
  3245. set widget frame
  3246. if {$disabled} {set attrs [removeOptions $attrs -state]}
  3247. }
  3248. ftx {set widget ttk::labelframe}
  3249. gut {set widget canvas}
  3250. lab {
  3251. set widget ttk::label
  3252. if {$disabled} {
  3253. set grey lightgray
  3254. set attrs "-foreground $grey $attrs"
  3255. }
  3256. lassign [parseOptions $attrs -link {} -style {} -font {}] \
  3257. cmd style font
  3258. if {$cmd ne {}} {
  3259. set attrs "-linkcom {$cmd} $attrs"
  3260. set attrs [removeOptions $attrs -link]
  3261. }
  3262. if {$style eq {} && $font eq {}} {
  3263. set attrs "-font {$::radxide::dan(CHARFAMILY)} $attrs"
  3264. } elseif {$style ne {}} {
  3265. # some themes stumble at ttk styles, so bring their attrs directly
  3266. set attrs [removeOptions $attrs -style]
  3267. set attrs "[ttk::style configure $style] $attrs"
  3268. }
  3269. }
  3270. laB {set widget label}
  3271. lfr {set widget ttk::labelframe}
  3272. lfR {
  3273. set widget labelframe
  3274. if {$disabled} {set attrs [removeOptions $attrs -state]}
  3275. }
  3276. lbx - flb {
  3277. set widget listbox
  3278. if {$nam3 eq {flb}} { ;# file content listbox
  3279. set attrs [FCfieldValues $wnamefull $attrs]
  3280. }
  3281. set attrs "[FCfieldAttrs $wnamefull $attrs -lvar]"
  3282. set attrs "[ListboxesAttrs $wnamefull $attrs]"
  3283. AddPopupAttr $wnamefull attrs -entrypop 1
  3284. foreach {ev com} {Home {LbxSelect %w 0} End {LbxSelect %w end}} {
  3285. append attrs " -bindEC {<$ev> {$com}} "
  3286. }
  3287. }
  3288. meb {set widget ttk::menubutton}
  3289. meB {set widget menubutton}
  3290. nbk {
  3291. set widget ttk::notebook
  3292. set attrs "-notebazook {$attrs}"
  3293. }
  3294. opc {
  3295. # tk_optionCascade - example of "my method" widget
  3296. # arguments: vname items mbopts precom args
  3297. #set widget {tk_optionCascade}
  3298. #set imax [expr {min(4,[llength $attrs])}]
  3299. #for {set i 0} {$i<$imax} {incr i} {
  3300. # set atr [lindex $attrs $i]
  3301. # if {$i!=1} {
  3302. # lset attrs $i \{$atr\}
  3303. # } elseif {[llength $atr]==1 && [info exist $atr]} {
  3304. # lset attrs $i [set $atr] ;# items stored in a variable
  3305. # }
  3306. #}
  3307. }
  3308. pan {set widget ttk::panedwindow
  3309. if {[string first -w $attrs]>-1 && [string first -h $attrs]>-1} {
  3310. # important for panes with fixed (customized) dimensions
  3311. set attrs "-propagate {$options} $attrs"
  3312. }
  3313. }
  3314. pro {set widget ttk::progressbar}
  3315. rad {set widget ttk::radiobutton}
  3316. raD {set widget radiobutton}
  3317. sca {set widget ttk::scale}
  3318. scA {set widget scale}
  3319. sbh {set widget ttk::scrollbar}
  3320. sbH {set widget scrollbar}
  3321. sbv {set widget ttk::scrollbar}
  3322. sbV {set widget scrollbar}
  3323. scf {
  3324. # if {![namespace exists ::apave::sframe]} {
  3325. # namespace eval ::apave {
  3326. # source [file join $::apave::apaveDir sframe.tcl]
  3327. # }
  3328. # }
  3329. # # scrolledFrame - example of "my method" widget
  3330. # set widget {my scrolledFrame}
  3331. }
  3332. seh {set widget ttk::separator}
  3333. sev {set widget ttk::separator}
  3334. siz {set widget ttk::sizegrip}
  3335. spx - spX {
  3336. if {$nam3 eq {spx}} {set widget ttk::spinbox} {set widget spinbox}
  3337. lassign [::apave::parseOptions $attrs \
  3338. -command {} -com {} -from {} -to {}] cmd cmd2 from to
  3339. append cmd $cmd2
  3340. lassign [::apave::extractOptions attrs -tip {} -tooltip {}] t1 t2
  3341. set t2 "$t1$t2"
  3342. if {$from ne {} || $to ne {}} {
  3343. if {$t2 ne {}} {set t2 "\n $t2"}
  3344. set t2 " $from .. $to $t2"
  3345. }
  3346. if {$t2 ne {}} {set t2 "-tip {$t2}"}
  3347. append attrs " -onReturn {$UFF{$cmd} {$from} {$to}$UFF} $t2"
  3348. }
  3349. tbl { ;# tablelist
  3350. package require tablelist
  3351. set widget tablelist::tablelist
  3352. set attrs "[FCfieldAttrs $wnamefull $attrs -lvar]"
  3353. set attrs "[ListboxesAttrs $wnamefull $attrs]"
  3354. }
  3355. tex {set widget text
  3356. if {[getOption -textpop {*}$attrs] eq {}} {
  3357. AddPopupAttr $wnamefull attrs -textpop \
  3358. [expr {[getOption -rotext {*}$attrs] ne {}}] -- disabled
  3359. }
  3360. lassign [parseOptions $attrs -ro {} -readonly {} -rotext {} \
  3361. -gutter {} -gutterwidth 5 -guttershift 6] r1 r2 r3 g1 g2 g3
  3362. set b1 [expr [string is boolean -strict $r1]]
  3363. set b2 [expr [string is boolean -strict $r2]]
  3364. if {($b1 && $r1) || ($b2 && $r2) || \
  3365. ($r3 ne {} && !($b1 && !$r1) && !($b2 && !$r2))} {
  3366. set attrs "-takefocus 0 $attrs"
  3367. }
  3368. set attrs [removeOptions $attrs -gutter -gutterwidth -guttershift]
  3369. if {$g1 ne {}} {
  3370. set attrs "$attrs -gutter {-canvas $g1 -width $g2 -shift $g3}"
  3371. }
  3372. }
  3373. tre {
  3374. set widget ttk::treeview
  3375. foreach {ev com} {Home {TreSelect %w 0} End {TreSelect %w end}} {
  3376. append attrs " -bindEC {<$ev> {$com}} "
  3377. }
  3378. }
  3379. h_* {set widget ttk::frame}
  3380. v_* {set widget ttk::frame}
  3381. default {set widget $newtype}
  3382. }
  3383. #set attrs [GetMC $attrs]
  3384. if {$nam3 in {cbx ent enT fco spx spX}} {
  3385. # entry-like widgets need their popup menu
  3386. set clearcom [lindex [parseOptions $attrs -clearcom -] 0]
  3387. if {$clearcom eq {-}} {
  3388. AddPopupAttr $wnamefull attrs -entrypop 0 readonly disabled
  3389. }
  3390. }
  3391. if {[string first pack [string trimleft $pack]]==0} {
  3392. catch {
  3393. # try to expand -after option (if set as WidgetName instead widgetName)
  3394. if {[set i [lsearch -exact $pack {-after}]]>=0} {
  3395. set aft [lindex $pack [incr i]]
  3396. if {[regexp {^[A-Z]} $aft]} {
  3397. set aft [my $aft]
  3398. set pack [lreplace $pack $i $i $aft]
  3399. }
  3400. }
  3401. }
  3402. set options $pack
  3403. }
  3404. set options [string trim $options]
  3405. set attrs [list {*}$attrs]
  3406. return [list $widget $options $attrs $nam3 $disabled]
  3407. }
  3408. # ________________________ WidgetNameFull _________________________ #
  3409. proc WidgetNameFull {w name {an {}}} {
  3410. # Gets a full name of a widget.
  3411. # w - name of root widget
  3412. # name - name of widget
  3413. # an - additional prefix for name
  3414. # See also: apave::sframe::content
  3415. set wn [string trim [parentWName $name].$an[ownWName $name] .]
  3416. set wnamefull $w.$wn
  3417. set wcc canvas.container.content ;# sframe.tcl may be not sourced
  3418. if {[set i1 [string first .scf $wnamefull]]>0 && \
  3419. [set i2 [string first . $wnamefull $i1+1]]>0 && \
  3420. [string first .$wcc. $wnamefull]<0} {
  3421. # insert a container's name into a scrolled frame's child
  3422. set wend [string range $wnamefull $i2 end]
  3423. set wnamefull [string range $wnamefull 0 $i2]
  3424. append wnamefull $wcc $wend
  3425. }
  3426. return $wnamefull
  3427. }
  3428. # ________________________ Window _________________________ #
  3429. proc Window {w inplists} {
  3430. # Paves the window with widgets.
  3431. # w - window's name (path)
  3432. # inplists - list of widget items (lists of widget data)
  3433. # Contents of a widget's item:
  3434. # name - widget's name (first 3 characters define its type)
  3435. # neighbor - top (T) or left (L) neighbor of the widget
  3436. # posofnei - position of neighbor: T (top) or L (left)
  3437. # rowspan - row span of the widget
  3438. # colspan - column span of the widget
  3439. # options - grid/pack options
  3440. # attrs - attributes of widget
  3441. # First 3 items are mandatory, others are set at need.
  3442. # Called by *paveWindow* method to process a portion of widgets.
  3443. # The "portion" refers to a separate block of widgets such as
  3444. # notebook's tabs or frames.
  3445. namespace upvar ::radxide dan dan
  3446. #tk_messageBox -title $dan(TITLE) -icon info -message "Start Window!"
  3447. set lwidgets [list]
  3448. # comments be skipped
  3449. foreach lst $inplists {
  3450. if {[string index $lst 0] ne {#}} {
  3451. lappend lwidgets $lst
  3452. }
  3453. }
  3454. set lused [list]
  3455. set lwlen [llength $lwidgets]
  3456. if {$lwlen<2 && [string trim $lwidgets "{} "] eq {}} {
  3457. set lwidgets [list {fra - - - - {pack -padx 99 -pady 99}}]
  3458. set lwlen 1
  3459. }
  3460. for {set i 0} {$i < $lwlen} {} {
  3461. set lst1 [lindex $lwidgets $i]
  3462. if {[Replace_Tcl i lwlen lwidgets {*}$lst1] ne {}} {incr i}
  3463. }
  3464. # firstly, normalize all names that are "subwidgets" (.lab for fra.lab)
  3465. # also, "+" for previous neighbors
  3466. set i [set lwlen [llength $lwidgets]]
  3467. while {$i>1} {
  3468. incr i -1
  3469. set lst1 [lindex $lwidgets $i]
  3470. lassign $lst1 name neighbor
  3471. if {$neighbor eq {+}} {set neighbor [lindex $lwidgets $i-1 0]}
  3472. lassign [NormalizeName name i lwidgets] name wname
  3473. set neighbor [lindex [NormalizeName neighbor i lwidgets] 0]
  3474. set lst1 [lreplace $lst1 0 1 $wname $neighbor]
  3475. set lwidgets [lreplace $lwidgets $i $i $lst1]
  3476. }
  3477. for {set i 0} {$i < $lwlen} {} {
  3478. # List of widgets contains data per widget:
  3479. # widget's name,
  3480. # neighbor widget, position of neighbor (T, L),
  3481. # widget's rowspan and columnspan (both optional),
  3482. # grid options, widget's attributes (both optional)
  3483. set lst1 [lindex $lwidgets $i]
  3484. #set lst1 [my Replace_chooser w i lwlen lwidgets {*}$lst1]
  3485. #if {[set lst1 [my Replace_bar w i lwlen lwidgets {*}$lst1]] eq {}} {
  3486. # incr i
  3487. # continue
  3488. #}
  3489. lassign $lst1 name neighbor posofnei rowspan colspan options1 attrs1
  3490. lassign [NormalizeName name i lwidgets] name wname
  3491. set wname [MakeWidgetName $w $wname]
  3492. if {$colspan eq {} || $colspan eq {-}} {
  3493. set colspan 1
  3494. if {$rowspan eq {} || $rowspan eq {-}} {
  3495. set rowspan 1
  3496. }
  3497. }
  3498. foreach ao {attrs options} {
  3499. if {[catch {set $ao [uplevel 2 subst -nocommand -nobackslashes [list [set ${ao}1]]]}]} {
  3500. set $ao [set ${ao}1]
  3501. }
  3502. }
  3503. lassign [widgetType $wname $options $attrs] widget options attrs nam3 dsbl
  3504. # The type of widget (if defined) means its creation
  3505. # (if not defined, it was created after "makewindow" call
  3506. # and before "window" call)
  3507. if { !($widget eq {} || [winfo exists $widget])} {
  3508. set attrs [GetAttrs $attrs $nam3 $dsbl]
  3509. set attrs [ExpandOptions $attrs]
  3510. # for scrollbars - set up the scrolling commands
  3511. if {$widget in {ttk::scrollbar scrollbar}} {
  3512. set neighbor [lindex [LowercaseWidgetName $neighbor] 0]
  3513. set wneigb [WidgetNameFull $w $neighbor]
  3514. if {$posofnei eq {L}} {
  3515. $wneigb config -yscrollcommand "$wname set"
  3516. set attrs "$attrs -com \\\{$wneigb yview\\\}"
  3517. append options { -side right -fill y} ;# -after $wneigb"
  3518. } elseif {$posofnei eq {T}} {
  3519. $wneigb config -xscrollcommand "$wname set"
  3520. set attrs "$attrs -com \\\{$wneigb xview\\\}"
  3521. append options { -side bottom -fill x} ;# -before $wneigb"
  3522. }
  3523. set options [string map [list %w $wneigb] $options]
  3524. }
  3525. #% doctest 1
  3526. #% set a "123 \\\\\\\\ 45"
  3527. #% eval append b {*}$a
  3528. #% set b
  3529. #> 123\45
  3530. #> doctest
  3531. Pre attrs
  3532. #set addcomms [my AdditionalCommands $w $wname attrs]
  3533. eval $widget $wname {*}$attrs
  3534. #my Post $wname $attrs
  3535. #foreach acm $addcomms {{*}$acm}
  3536. # for buttons and entries - set up the hotkeys (Up/Down etc.)
  3537. #my DefineWidgetKeys $wname $widget
  3538. }
  3539. if {$neighbor eq {-} || $row < 0} {
  3540. set row [set col 0]
  3541. }
  3542. # check for simple creation of widget (without pack/grid)
  3543. if {$neighbor ne {#}} {
  3544. set options [GetIntOptions $w $options $row $rowspan $col $colspan]
  3545. set pack [string trim $options]
  3546. if {[string first add $pack]==0} {
  3547. set comm "[winfo parent $wname] add $wname [string range $pack 4 end]"
  3548. {*}$comm
  3549. } elseif {[string first pack $pack]==0} {
  3550. set opts [string trim [string range $pack 5 end]]
  3551. if {[string first forget $opts]==0} {
  3552. pack forget {*}[string range $opts 6 end]
  3553. } else {
  3554. pack $wname {*}$opts
  3555. }
  3556. } else {
  3557. grid $wname -row $row -column $col -rowspan $rowspan \
  3558. -columnspan $colspan -padx 1 -pady 1 {*}$options
  3559. }
  3560. }
  3561. lappend lused [list $name $row $col $rowspan $colspan]
  3562. if {[incr i] < $lwlen} {
  3563. lassign [lindex $lwidgets $i] name neighbor posofnei
  3564. set neighbor [lindex [LowercaseWidgetName $neighbor] 0]
  3565. set row -1
  3566. foreach cell $lused {
  3567. lassign $cell uname urow ucol urowspan ucolspan
  3568. if {[lindex [LowercaseWidgetName $uname] 0] eq $neighbor} {
  3569. set col $ucol
  3570. set row $urow
  3571. if {$posofnei eq {T} || $posofnei eq {}} {
  3572. incr row $urowspan
  3573. } elseif {$posofnei eq {L}} {
  3574. incr col $ucolspan
  3575. }
  3576. }
  3577. }
  3578. }
  3579. }
  3580. return $lwidgets
  3581. }
  3582. # ________________________ WindowStatus _________________________ #
  3583. proc WindowStatus {w name {val ""} {defval ""}} {
  3584. # Sets/gets a status of window. The status is a value assigned to a name.
  3585. # w - window's path
  3586. # name - name of status
  3587. # val - if blank, to get a value of status; otherwise a value to set
  3588. # defval - default value (actual if the status not set beforehand)
  3589. # Returns a value of status.
  3590. # See also: IntStatus
  3591. variable _AP_VARS
  3592. if {$val eq {}} { ;# getting
  3593. if {[info exist _AP_VARS($w,$name)]} {
  3594. return $_AP_VARS($w,$name)
  3595. }
  3596. return $defval
  3597. }
  3598. return [set _AP_VARS($w,$name) $val] ;# setting
  3599. }
  3600. # ________________________ WinResize _________________________ #
  3601. proc WinResize {win} {
  3602. # Restricts the window's sizes (thus fixing Tk's issue with a menubar)
  3603. # win - path to a window to be of restricted sizes
  3604. if {[$win cget -menu] ne {}} {
  3605. lassign [splitGeometry [wm geometry $win]] w h
  3606. lassign [wm minsize $win] wmin hmin
  3607. if {$w<$wmin && $h<$hmin} {
  3608. set corrgeom ${wmin}x$hmin
  3609. } elseif {$w<$wmin} {
  3610. set corrgeom ${wmin}x$h
  3611. } elseif {$h<$hmin} {
  3612. set corrgeom ${w}x$hmin
  3613. } else {
  3614. return
  3615. }
  3616. wm geometry $win $corrgeom
  3617. }
  3618. return
  3619. }
  3620. # ________________________ WinVarname _________________________ #
  3621. proc WinVarname {win} {
  3622. # Gets a unique varname for a window.
  3623. # win - window's path
  3624. return [namespace current]::PV(_WIN_,$win)
  3625. }
  3626. # ________________________ withdraw _________________________ #
  3627. proc withdraw {w} {
  3628. # Does 'withdraw' for a window.
  3629. # w - the window's path
  3630. # See also: iconifyOption
  3631. switch -- [iconifyOption] {
  3632. none { ; # no withdraw/deiconify actions
  3633. }
  3634. Linux { ; # do it for Linux
  3635. wm withdraw $w
  3636. }
  3637. Windows { ; # do it for Windows
  3638. wm withdraw $w
  3639. wm attributes $w -alpha 0.0
  3640. }
  3641. default { ; # do it depending on the platform
  3642. wm withdraw $w
  3643. if {[::radxide::iswindows]} {
  3644. wm attributes $w -alpha 0.0
  3645. }
  3646. }
  3647. }
  3648. }
  3649. # ________________________ #
  3650. }