123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719 |
- #!/usr/bin/perl
- # Copyright (C) 2004 Erik Zachte , email xxx\@chello.nl (nospam: xxx=epzachte)
- # This program is free software; you can redistribute it and/or
- # modify it under the terms of the GNU General Public License version 2
- # as published by the Free Software Foundation.
- # This program is distributed in the hope that it will be useful,
- # but WITHOUT ANY WARRANTY; without even the implied warranty of
- # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- # See the GNU General Public License for more details, at
- # http://www.fsf.org/licenses/gpl.html
- # history:
- # 1.5 May 27 2004 :
- # - when a chart contains only one bar this bar was always centered in the image
- # now AlignBars works well in this case aslo ("justify" treated as "center")
- # - interwiki links reinstalled e.g. [[de:Gorbachev]]
- # - error msgs corrected
- # - minimum image size fixed
- # - line numbering adapted <timeline>spaces<br> does not count as line one in Wikipedia
- # - line breaks in wiki links parsed correctly [[Vladimir~Ilyich~Lenin]]
- # - partial url shown as hint for external link (in GIF/PNG)
- # - BarData: no attribute 'text:..' supplied -> default to space = show no text on axis
- # - PlotData: new attribute 'anchor:..'
- # - revert html encoding of '<' & '>' by MediaWiki
- # 1.6 May 28 2004 :
- # - SVG decode special chars in SVG input fixed
- # - BarData: new attributes 'barset:..' and 'barcount:..' # autoincrement bar id
- # - PlotData: new attribute 'barset:..'
- # - LineData: new attribute 'layer:..', draw lines to back or front of bars and texts
- # 1.7
- # - EscapeShellArg (Tim Starling)
- # 1.8 June .. 2004 :
- # - optional autosizing of image (implied when auto incrementing bar count (also new))
- # - presentation left-right order of bars reversed on TimeAxis = orientation:vertical
- # - TimeAxis option 'order:[normal|reverse]' added
- # - BarData: option barcount replaced by auto incrementing bar count and 'break' and 'skip' attributes
- # - DrawLines -> LineData (command renamed, but also restructured like PlotData, TextData)
- # - new drawing options for LineData, now also lines parallel to time axis, or between arbitrary points
- # - Preset command added (specify default settings with 'Preset =', two sets to start with)
- # - 'text' attribute parsing bugs (# or : in text gave problems, spaces got lost)
- # - PlotArea new attributes 'top' and 'right' make it possible to define plot area margins only
- # so resizing image does not imply adjusting PlotArea 'width' and 'height'
- # - PlotData option 'shift': only changing x or y value is now possible, e.g. shift=(,10)
- # - command ScaleMajor: subs for time axis can now be specified verbatim in option 'text'
- # - extra validation checks, defaults, etc
- # - function PlotScale now provides workaround for Ploticus bug: auto incrementing dates failed
- # 1.9 June 2004
- # - stub display order fixed on non time axis
- # 1.10 July 2004
- # - tempory debug code (removed)
- # 1.11 August 2004
- # - dot in folder name in input path was misunderstood as start of file extension
- # - utf-8 chars within 160-255 range are translated to extended ascii
- # however internal font used by Ploticus has strange mapping so some are replaced
- # by undercore or unaccented version of character
- # this is a make do solution until full unicode support with external fonts will be added
- $version = "1.9" ;
- use Time::Local ;
- use Getopt::Std ;
- use Cwd ;
- $| = 1; # flush screen output
- print "EasyTimeline version $version\n" .
- "Copyright (C) 2004 Erik Zachte\n" .
- "Email xxx\@chello.nl (nospam: xxx=epzachte)\n\n" .
- "This program is free software; you can redistribute it\n" .
- "and/or modify it under the terms of the \n" .
- "GNU General Public License version 2 as published by\n" .
- "the Free Software Foundation\n" .
- "------------------------------------------------------\n" ;
- &SetImageFormat ;
- &ParseArguments ;
- &InitFiles ;
- open "FILE_IN", "<", $file_in ;
- @lines = <FILE_IN> ;
- close "FILE_IN" ;
- &InitVars ;
- &ParseScript ;
- if ($CntErrors == 0)
- { &WritePlotFile ; }
- if ($CntErrors == 1)
- { &Abort ("1 error found") ; }
- elsif ($CntErrors > 1)
- { &Abort ("$CntErrors errors found") ; }
- else
- {
- if (defined @Info)
- {
- print "\nINFO\n" ;
- print @Info ;
- print "\n" ;
- }
- if (defined @Warnings)
- {
- print "\nWARNING(S)\n" ;
- print @Warnings ;
- print "\n" ;
- }
- if (! (-e $file_bitmap))
- {
- print "\nImage $file_bitmap not created.\n" ;
- if ((! (-e "pl.exe")) && (! (-e "pl")))
- { print "\nPloticus not found in local folder. Is it on your system path?\n" ; }
- }
- elsif (! (-e $file_vector))
- {
- print "\nImage $file_vector not created.\n" ;
- }
- else
- { print "\nREADY\nNo errors found.\n" ; }
- }
- exit ;
- sub ParseArguments
- {
- my $options ;
- getopt ("iTAPe", \%options) ;
- &Abort ("Specify input file as: -i filename") if (! defined (@options {"i"})) ;
- $file_in = @options {"i"} ;
- $listinput = @options {"l"} ; # list all input lines (not recommended)
- $linkmap = @options {"m"} ; # make clickmap for inclusion in html
- $makehtml = @options {"h"} ; # make test html file with gif/png + svg output
- $bypass = @options {"b"} ; # do not use in Wikipedia:bypass some checks
- $showmap = @options {"d"} ; # debug: shows clickable areas in gif/png
- # The following parameters are used by MediaWiki
- # to pass config settings from LocalSettings.php to
- # the perl script
- $tmpdir = @options {"T"} ; # For MediaWiki: temp directory to use
- $plcommand = @options {"P"} ; # For MediaWiki: full path of ploticus command
- $articlepath=@options {"A"} ; # For MediaWiki: Path of an article, relative to this servers root
- if (! defined @options {"A"} )
- { $articlepath="http://en.wikipedia.org/wiki/\$1"; }
- if (! -e $file_in)
- { &Abort ("Input file '" . $file_in . "' not found.") ; }
- }
- sub InitVars
- {
- $true = 1 ;
- $false = 0 ;
- $CntErrors = 0 ;
- $LinkColor = "brightblue" ;
- $MapPNG = $false ; # switched when link or hint found
- $MapSVG = $false ; # switched when link found
- $WarnTextOutsideArea = 0 ;
- $WarnOnRightAlignedText = 0 ;
- $hPerc = &EncodeInput ("\%") ;
- $hAmp = &EncodeInput ("\&") ;
- $hAt = &EncodeInput ("\@") ;
- $hDollar = &EncodeInput ("\$") ;
- $hBrO = &EncodeInput ("\(") ;
- $hBrC = &EncodeInput ("\)") ;
- $hSemi = &EncodeInput ("\;") ;
- $hIs = &EncodeInput ("\=") ;
- $hLt = &EncodeInput ("\<") ;
- $hGt = &EncodeInput ("\>") ;
- }
- sub InitFiles
- {
- print "\nInput: Script file $file_in\n" ;
- $file = $file_in ;
- # 1.10 dot ignore dots in folder names ->
- $file =~ s/\.[^\\\/\.]*$// ; # remove extension
- $file_name = $file ;
- $file_bitmap = $file . "." . $fmt ;
- $file_vector = $file . ".svg" ;
- $file_png = $file . ".png" ;
- $file_htmlmap = $file . ".map" ;
- $file_html = $file . ".html" ;
- $file_errors = $file . ".err" ;
- # $file_pl_info = $file . ".inf" ;
- # $file_pl_err = $file . ".err" ;
- print "Output: Image files $file_bitmap & $file_vector\n" ;
- if ($linkmap)
- { print " Map file $file_htmlmap (add to html for clickable map)\n" ; }
- if ($makehtml)
- { print " HTML test file $file_html\n" ; }
- # remove previous output
- if (-e $file_bitmap) { unlink $file_bitmap ; }
- if (-e $file_vector) { unlink $file_vector ; }
- if (-e $file_png) { unlink $file_png ; }
- if (-e $file_htmlmap) { unlink $file_htmlmap ; }
- if (-e $file_html) { unlink $file_html ; }
- if (-e $file_errors) { unlink $file_errors ; }
- }
- sub SetImageFormat
- {
- $env = "" ;
- # $dir = cwd() ; # is there a better way to detect OS?
- # if ($dir =~ /\//) { $env = "Linux" ; $fmt = "png" ; $pathseparator = "/";}
- # if ($dir =~ /\\/) { $env = "Windows" ; $fmt = "gif" ; $pathseparator = "\\";}
- # cwd always to returns '/'s ? ->
- $OS = $^O ;
- if ($OS =~ /darwin/i)
- { $env = "Linux"; $fmt = "png" ; $pathseparator = "/";}
- elsif ($OS =~ /win/i)
- { $env = "Windows" ; $fmt = "gif" ; $pathseparator = "\\";}
- else
- { $env = "Linux" ; $fmt = "png" ; $pathseparator = "/";}
- if ($env ne "")
- { print "\nOS $env detected -> create image in $fmt format.\n" ; }
- else
- {
- print "\nOS not detected. Assuming Windows -> create image in $fmt format.\n" ;
- $env = "Windows" ;
- }
- }
- sub ParseScript
- {
- my $command ; # local version, $Command = global
- $LineNo = 0 ;
- $InputParsed = $false ;
- $CommandNext = "" ;
- $DateFormat = "x.y" ;
- $firstcmd = $true ;
- &GetCommand ;
- &StoreColor ("white", &EncodeInput ("gray(0.999)"), "") ;
- &StoreColor ("barcoldefault", &EncodeInput ("rgb(0,0.6,0)"), "") ;
- while (! $InputParsed)
- {
- if ($Command =~ /^\s*$/)
- { &GetCommand ; next ; }
- if (! ($Command =~ /$hIs/))
- { &Error ("Invalid statement. No '=' found.") ;
- &GetCommand ; next ; }
- if ($Command =~ /$hIs.*$hIs/)
- { &Error ("Invalid statement. Multiple '=' found.") ;
- &GetCommand ; next ; }
- my ($name, $value) = split ($hIs, $Command) ;
- $name =~ s/^\s*(.*?)\s*$/$1/ ;
- if ($name =~ /PlotDividers/i)
- { &Error ("Command 'PlotDividers' has been renamed to 'LineData', please adjust.") ;
- &GetCommand ; next ; }
- if ($name =~ /DrawLines/i)
- { &Error ("Command 'DrawLines' has been renamed to 'LineData', please adjust.\n" .
- " Reason for change is consistency: LineData now follows the same syntax rules as PlotData and TextData.") ;
- &GetCommand ; next ; }
- if ((! ($name =~ /^(?:Define)\s/)) &&
- (! ($name =~ /^(?:AlignBars|BarData|
- BackgroundColors|Colors|DateFormat|LineData|
- ScaleMajor|ScaleMinor|
- LegendLeft|LegendTop|
- ImageSize|PlotArea|Legend|
- Period|PlotData|Preset|
- TextData|TimeAxis)$/xi)))
- { &ParseUnknownCommand ;
- &GetCommand ; next ; }
- $value =~ s/^\s*(.*?)\s*// ;
- if (! ($name =~ /^(?:BarData|Colors|LineData|PlotData|TextData)$/i))
- {
- if ((! (defined ($value))) || ($value eq ""))
- {
- if ($name =~ /Preset/i)
- {
- &Error ("$name definition incomplete. No value specified\n" .
- " At the moment only one preset exists: 'TimeVertical_OneBar_UnitYear'.\n" .
- " See also meta.wikipedia.org/wiki/EasyTimeline/Presets") ;
- }
- else
- { &Error ("$name definition incomplete. No attributes specified") ; }
- &GetCommand ; next ; }
- }
- if ($name =~ /^(?:BackgroundColors|Colors|Period|ScaleMajor|ScaleMinor|TimeAxis)$/i)
- {
- my @attributes = split (" ", $value) ;
- foreach $attribute (@attributes)
- {
- my ($attrname, $attrvalue) = split ("\:", $attribute) ;
- if (! ($name."-".$attrname =~ /^(?:Colors-Value|Colors-Legend|
- Period-From|Period-Till|
- ScaleMajor-Color|ScaleMajor-Unit|ScaleMajor-Increment|ScaleMajor-Start|
- ScaleMinor-Color|ScaleMinor-Unit|ScaleMinor-Increment|ScaleMinor-Start|
- BackgroundColors-Canvas|BackgroundColors-Bars|
- TimeAxis-Orientation|TimeAxis-Format)$/xi))
- { &Error ("$name definition invalid. Unknown attribute '$attrname'.") ;
- &GetCommand ; next ; }
- if ((! defined ($attrvalue)) || ($attrvalue eq ""))
- { &Error ("$name definition incomplete. No value specified for attribute '$attrname'.") ;
- &GetCommand ; next ; }
- }
- }
- if ($Command =~ /^AlignBars/i) { &ParseAlignBars ; }
- elsif ($Command =~ /^BackgroundColors/i) { &ParseBackgroundColors ; }
- elsif ($Command =~ /^BarData/i) { &ParseBarData ; }
- elsif ($Command =~ /^Colors/i) { &ParseColors ; }
- elsif ($Command =~ /^DateFormat/i) { &ParseDateFormat ; }
- elsif ($Command =~ /^Define/i) { &ParseDefine ; }
- elsif ($Command =~ /^ImageSize/i) { &ParseImageSize ; }
- elsif ($Command =~ /^Legend/i) { &ParseLegend ; }
- elsif ($Command =~ /^LineData/i) { &ParseLineData ; }
- elsif ($Command =~ /^Period/i) { &ParsePeriod ; }
- elsif ($Command =~ /^PlotArea/i) { &ParsePlotArea ; }
- elsif ($Command =~ /^PlotData/i) { &ParsePlotData ; }
- elsif ($Command =~ /^Preset/i) { &ParsePreset ; }
- elsif ($Command =~ /^Scale/i) { &ParseScale ; }
- elsif ($Command =~ /^TextData/i) { &ParseTextData ; }
- elsif ($Command =~ /^TimeAxis/i) { &ParseTimeAxis ; }
- &GetCommand ;
- $firstcmd = $false ;
- }
- if ($CntErrors == 0)
- { &DetectMissingCommands ; }
- if ($CntErrors == 0)
- { &ValidateAndNormalizeDimensions ; }
- }
- sub GetLine
- {
- if ($#lines < 0)
- { $InputParsed = $true ; return ("") ; }
- # running in Wikipedia context and first line empty ?
- # skip first line without incrementing line count
- # this is part behind <timeline> and will not be thought of as line 1
- if (defined @options {"A"})
- {
- if (($#lines >= 0) && (@lines [0] =~ /^\s*$/))
- { $Line = shift (@lines) ; }
- }
- $Line = "" ;
- while (($#lines >= 0) && ($Line =~ /^\s*$/))
- {
- $LineNo ++ ;
- $Line = shift (@lines) ;
- chomp ($Line) ;
- if ($listinput)
- { print "$LineNo: " . &DecodeInput ($Line) . "\n" ; }
- # preserve '#' within double quotes
- $Line =~ s/(\"[^\"]*\")/$a=$1,$a=~s^\#^\%\?\+^g,$a/ge ;
- $Line =~ s/#>.*?<#//g ;
- if ($Line =~ /#>/)
- {
- $commentstart = $LineNo ;
- $Line =~ s/#>.*?$// ;
- }
- elsif ($Line =~ /<#/)
- {
- undef $commentstart ;
- $Line =~ s/^.*?<#//x ;
- }
- elsif (defined ($commentstart))
- { $Line = "" ; next ; }
- # remove single line comments (keep html char tags, like  )
- $Line =~ s/\&\#/\&\$\%/g ;
- $Line =~ s/\#.*$// ;
- $Line =~ s/\&\$\%/\&\#/g ;
- $Line =~ s/\%\?\+/\#/g ;
- $Line =~ s/\s*$//g ;
- $Line =~ s/\t/ /g ;
- }
- if ($Line !~ /^\s*$/)
- {
- $Line = &EncodeInput ($Line) ;
- if (! ($Line =~ /^\s*Define/i))
- { $Line =~ s/($hDollar[a-zA-Z0-9]+)/&GetDefine($Line,$1)/ge ; }
- }
- if (($#lines < 0) && (defined ($commentstart)))
- { &Error2 ("No matching end of comment found for comment block starting at line $commentstart.\n" .
- "Text between \#> and <\# (multiple lines) or following \# (single line) will be treated as comment.") ; }
- return ($Line) ;
- }
- sub GetCommand
- {
- undef (%Attributes) ;
- $Command = "" ;
- if ($CommandNext ne "")
- {
- $Command = $CommandNext ;
- $CommandNext = "" ;
- }
- else
- { $Command = &GetLine ; }
- if ($Command =~ /^\s/)
- {
- &Error ("New command expected instead of data line (= line starting with spaces). Data line(s) ignored.\n") ;
- $Command = &GetLine ;
- while (($#lines >= 0) && ($Command =~ /^\s/))
- { $Command = &GetLine ; }
- }
- if ($Command =~ /^[^\s]/)
- {
- $line = $Command ;
- $line =~ s/^.*$hIs\s*// ;
- &CollectAttributes ($line) ;
- }
- }
- sub GetData
- {
- undef (%Attributes) ;
- $Command = "" ;
- $NoData = $false ;
- my $line = &GetLine ;
- if ($line =~ /^[^\s]/)
- {
- $CommandNext = $line ;
- $NoData = $true ;
- return ("") ;
- }
- if ($line =~ /^\s*$/)
- {
- $NoData = $true ;
- return ("") ;
- }
- $line =~ s/^\s*//g ;
- &CollectAttributes ($line) ;
- }
- sub CollectAttributes
- {
- my $line = shift ;
- $line =~ s/(\slink\:[^\s\:]*)\:/$1'colon'/i ; # replace colon (:), would conflict with syntax
- $line =~ s/(\stext\:[^\s\:]*)\:/$1'colon'/i ; # replace colon (:), would conflict with syntax
- $line =~ s/(https?)\:/$1'colon'/i ; # replace colon (:), would conflict with syntax
- my $text ;
- ($line, $text) = &ExtractText ($line) ;
- $text =~ s/'colon'/:/ ;
- $line =~ s/( $hBrO .+? $hBrC )/&RemoveSpaces($1)/gxe ;
- $line =~ s/\s*\:\s*/:/g ;
- $line =~ s/([a-zA-Z0-9\_]+)\:/lc($1) . ":"/gxe ;
- @Fields = split (" ", $line) ;
- $name = "" ;
- foreach $field (@Fields)
- {
- if ($field =~ /\:/)
- {
- ($name, $value) = split (":", $field) ;
- $name =~ s/^\s*(.*)\s*$/lc($1)/gxe ;
- $value =~ s/^\s*(.*)\s*$/$1/gxe ;
- if (($name ne "bar") && ($name ne "text") && ($name ne "link") && ($name ne "legend")) # && ($name ne "hint")
- { $value = lc ($value) ; }
- if ($name eq "link") # restore colon
- { $value =~ s/'colon'/:/ ; }
- if ($value eq "")
- {
- if ($name =~ /Text/i)
- { $value = " " ; }
- else
- { &Error ("No value specified for attribute '$name'. Attribute ignored.") ; }
- }
- else
- { @Attributes {$name} = $value ; }
- }
- else
- {
- if (defined (@Attributes {"single"}))
- { &Error ("Invalid attribute '$field' ignored.\nSpecify attributes as 'name:value' pair(s).") ; }
- else
- {
- $field =~ s/^\s*(.*)\s*$/$1/gxe ;
- @Attributes {"single"} = $field ;
- }
- }
- }
- if (($name ne "") && (@Attributes {"single"} ne ""))
- {
- &Error ("Invalid attribute '" . @Attributes {"single"} . "' ignored.\nSpecify attributes as 'name:value' pairs.") ;
- delete (@Attributes {"single"}) ;
- }
- if ((defined ($text)) && ($text ne ""))
- { @Attributes {"text"} = &ParseText ($text) ; }
- }
- sub GetDefine
- {
- my $command = shift ;
- my $const = shift ;
- $const = lc ($const) ;
- my $value = @Consts {lc ($const)} ;
- if (! defined ($value))
- {
- &Error ("Unknown constant. 'Define $const = ... ' expected.") ;
- return ($const);
- }
- return ($value) ;
- }
- sub ParseAlignBars
- {
- &CheckPreset ("AlignBars") ;
- $align = @Attributes {"single"} ;
- if (! ($align =~ /^(?:justify|early|late)$/i))
- { &Error ("AlignBars value '$align' invalid. Specify 'justify', 'early' or 'late'.") ; return ; }
- $AlignBars = lc ($align) ;
- }
- sub ParseBackgroundColors
- {
- if (! &ValidAttributes ("BackgroundColors"))
- { &GetData ; next ;}
- &CheckPreset ("BackGroundColors") ;
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($attribute =~ /Canvas/i)
- {
- if (! &ColorPredefined ($attrvalue))
- {
- if (! defined (@Colors {lc ($attrvalue)}))
- { &Error ("BackgroundColors definition invalid. Attribute '$attribute': unknown color '$attrvalue'.\n" .
- " Specify command 'Color' before this command.") ; return ; }
- }
- if (defined (@Colors {lc ($attrvalue)}))
- { @Attributes {"canvas"} = @Colors { lc ($attrvalue) } ; }
- else
- { @Attributes {"canvas"} = lc ($attrvalue) ; }
- }
- elsif ($attribute =~ /Bars/i)
- {
- if (! defined (@Colors {lc ($attrvalue)}))
- { &Error ("BackgroundColors definition invalid. Attribute '$attribute' unknown color '$attrvalue'.\n" .
- " Specify command 'Color' before this command.") ; return ; }
- @Attributes {"bars"} = lc ($attrvalue) ;
- }
- }
- %BackgroundColors = %Attributes ;
- }
- sub ParseBarData
- {
- &GetData ;
- if ($NoData)
- { &Error ("Data expected for command 'BarData', but line is not indented.\n") ; return ; }
- my ($bar, $text, $link, $hint, $barset) ; # , $barcount) ;
- BarData:
- while ((! $InputParsed) && (! $NoData))
- {
- if (! &ValidAttributes ("BarData"))
- { &GetData ; next ;}
- $bar = "" ; $link = "" ; $hint = "" ; $barset = "" ; # $barcount = "" ;
- my $data2 = $data ;
- ($data2, $text) = &ExtractText ($data2) ;
- @Attributes = split (" ", $data2) ;
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($attribute =~ /^Bar$/i)
- {
- $bar = $attrvalue ;
- }
- elsif ($attribute =~ /^BarSet$/i)
- {
- $barset = $attrvalue ;
- }
- # elsif ($attribute =~ /^BarCount$/i)
- # {
- # $barcount = $attrvalue ;
- # if (($barcount !~ /^\d?\d?\d$/) || ($barcount < 2) || ($barcount > 200))
- # { &Error ("BarData attribute 'barcount' invalid. Specify a number between 2 and 200\n") ;
- # &GetData ; next BarData ; }
- # }
- elsif ($attribute =~ /^Text$/i)
- {
- $text = $attrvalue ;
- $text =~ s/\\n/~/gs ;
- if ($text =~ /\~/)
- { &Warning ("BarData attribute 'text' contains ~ (tilde).\n" .
- "Tilde will not be translated into newline character (only in PlotData)") ; }
- if ($text =~ /\^/)
- { &Warning ("BarData attribute 'text' contains ^ (caret).\n" .
- "Caret will not be translated into tab character (only in PlotData)") ; }
- }
- elsif ($attribute =~ /^Link$/i)
- {
- $link = &ParseText ($attrvalue) ;
- if ($link =~ /\[.*\]/)
- { &Error ("BarData attribute 'link' contains implicit (wiki style) link.\n" .
- "Use implicit link style with attribute 'text' only.\n") ;
- &GetData ; next BarData ; }
- $link = &EncodeURL (&NormalizeURL ($link)) ;
- $MapPNG = $true ;
- }
- }
- if (($bar eq "") && ($barset eq ""))
- { &Error ("BarData attribute missing. Specify either 'bar' of 'barset'.\n") ;
- &GetData ; next BarData ; }
- if (($bar ne "") && ($barset ne ""))
- { &Error ("BarData attributes 'bar' and 'barset' are mutually exclusive.\nSpecify one of these per data line\n") ;
- &GetData ; next BarData ; }
- # if (($barset ne "") && ($barcount eq ""))
- # { &Error ("BarData attribute 'barset' specified without attribute 'barcount'.\n") ;
- # &GetData ; next BarData ; }
- # if (($barset eq "") && ($barcount ne ""))
- # { &Error ("BarData attribute 'barcount' specified without attribute 'barset'.\n") ;
- # &GetData ; next BarData ; }
- if (($barset ne "") && ($link ne ""))
- { &Error ("BarData attribute 'link' not valid in combination with attribute 'barset'.\n") ;
- &GetData ; next BarData ; }
- if ($link ne "")
- {
- if ($text =~ /\[.*\]/)
- {
- &Warning ("BarData contains implicit link(s) in attribute 'text' and explicit attribute 'link'.\n" .
- "Implicit link(s) ignored.") ;
- $text =~ s/\[+ (?:[^\|]* \|)? ([^\]]*) \]+/$1/gx ;
- }
- if ($hint eq "")
- { $hint = &ExternalLinkToHint ($link) ; }
- }
- if (($bar ne "") && ($bar !~ /[a-zA-Z0-9\_]+/))
- { &Error ("BarData attribute bar:'$bar' invalid.\nUse only characters 'a'-'z', 'A'-'Z', '0'-'9', '_'\n") ;
- &GetData ; next BarData ; }
- if ($bar ne "")
- {
- if (@Axis {"time"} eq "x")
- { push @Bars, $bar ; }
- else
- { unshift @Bars, $bar ; }
- if ($text ne "")
- { @BarLegend {lc ($bar)} = $text ; }
- else
- { @BarLegend {lc ($bar)} = " " ; }
- if ($link ne "")
- { @BarLink {lc ($bar)} = $link ; }
- }
- else
- {
- # for ($b = 1 ; $b <= $barcount ; $b++)
- # {
- # $bar = $barset . "#" . $b ;
- $bar = $barset . "#1" ;
- if (@Axis {"time"} eq "x")
- { push @Bars, $bar ; }
- else
- { unshift @Bars, $bar ; }
- if ($text ne "")
- { @BarLegend {lc ($bar)} = $text . " - " . $b ; }
- else
- { @BarLegend {lc ($bar)} = " " ; }
- # }
- }
- &GetData ;
- }
- }
- sub ParseColors
- {
- &GetData ;
- if ($NoData)
- { &Error ("Data expected for command 'Colors', but line is not indented.\n") ; return ; }
- Colors:
- while ((! $InputParsed) && (! $NoData))
- {
- if (! &ValidAttributes ("Colors"))
- { &GetData ; next ;}
- &CheckPreset ("Colors") ;
- my $addtolegend = $false ;
- my $legendvalue = "" ;
- my $colorvalue = "" ;
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($attribute =~ /Id/i)
- {
- $colorname = $attrvalue ;
- }
- elsif ($attribute =~ /Legend/i)
- {
- $addtolegend = $true ;
- $legendvalue = $attrvalue ;
- if ($legendvalue =~ /^[yY]$/)
- { push @LegendData, $colorname ; }
- elsif (! ($attrvalue =~ /^[nN]$/))
- {
- $legendvalue = &ParseText ($legendvalue) ;
- push @LegendData, $legendvalue ;
- }
- }
- elsif ($attribute =~ /Value/i)
- {
- $colorvalue = $attrvalue ;
- if ($colorvalue =~ /^white$/i)
- { $colorvalue = "gray" . $hBrO . "0.999" . $hBrC ; }
- }
- }
- if (&ColorPredefined ($colorvalue))
- {
- &StoreColor ($colorname, $colorvalue, $legendvalue) ;
- &GetData ; next Colors ;
- }
- if ($colorvalue =~ /^[a-z]+$/i)
- {
- if (! ($colorvalue =~ /^(?:gray|rgb|hsb)/i))
- { &Error ("Color value invalid: unknown constant '$colorvalue'.") ;
- &GetData ; next Colors ; }
- }
- if (! ($colorvalue =~ /^(?:gray|rgb|hsb) $hBrO .+? $hBrC/xi))
- { &Error ("Color value invalid. Specify constant or 'gray/rgb/hsb(numeric values)' ") ;
- &GetData ; next Colors ; }
- if ($colorvalue =~ /^gray/i)
- {
- if ($colorvalue =~ /gray $hBrO (?:0|1|0\.\d+) $hBrC/xi)
- { &StoreColor ($colorname, $colorvalue, $legendvalue) ; }
- else
- { &Error ("Color value invalid. Specify 'gray(x) where 0 <= x <= 1' ") ; }
- &GetData ; next Colors ;
- }
- if ($colorvalue =~ /^rgb/i)
- {
- my $colormode = substr ($colorvalue,0,3) ;
- if ($colorvalue =~ /rgb $hBrO
- (?:0|1|0\.\d+) \,
- (?:0|1|0\.\d+) \,
- (?:0|1|0\.\d+)
- $hBrC/xi)
- { &StoreColor ($colorname, $colorvalue, $legendvalue) ; }
- else
- { &Error ("Color value invalid. Specify 'rgb(r,g,b) where 0 <= r,g,b <= 1' ") ; }
- &GetData ; next Colors ;
- }
- if ($colorvalue =~ /^hsb/i)
- {
- my $colormode = substr ($colorvalue,0,3) ;
- if ($colorvalue =~ /hsb $hBrO
- (?:0|1|0\.\d+) \,
- (?:0|1|0\.\d+) \,
- (?:0|1|0\.\d+)
- $hBrC/xi)
- { &StoreColor ($colorname, $colorvalue, $legendvalue) ; }
- else
- { &Error ("Color value invalid. Specify 'hsb(h,s,b) where 0 <= h,s,b <= 1' ") ; }
- &GetData ; next Colors ;
- }
- &Error ("Color value invalid.") ;
- &GetData ;
- }
- }
- sub StoreColor
- {
- my $colorname = shift ;
- my $colorvalue = shift ;
- my $legendvalue = shift ;
- if (defined (@Colors {lc ($colorname)}))
- { &Warning ("Color '$colorname' redefined.") ; }
- @Colors {lc ($colorname)} = lc ($colorvalue) ;
- if ((defined ($legendvalue)) && ($legendvalue ne ""))
- { @ColorLabels {lc ($colorname)} = $legendvalue ; }
- }
- sub ParseDateFormat
- {
- &CheckPreset ("DateFormat") ;
- my $datevalue = lc (@Attributes {"single"}) ;
- $datevalue =~ s/\s//g ;
- $datevalue = lc ($datevalue) ;
- if (($datevalue ne "dd/mm/yyyy") && ($datevalue ne "mm/dd/yyyy") && ($datevalue ne "yyyy") && ($datevalue ne "x.y"))
- { &Error ("Invalid DateFormat. Specify as 'dd/mm/yyyy', 'mm/dd/yyyy', 'yyyy' or 'x.y'\n" .
- " (use first two only for years >= 1800)\n") ; return ; }
- $DateFormat = $datevalue ;
- }
- sub ParseDefine
- {
- my $command = $Command ;
- my $command2 = $command ;
- $command2 =~ s/^Define\s*//i ;
- my ($name, $value) = split ($hIs, $command2) ;
- $name =~ s/^\s*(.*?)\s*$/$1/g ;
- $value =~ s/^\s*(.*?)\s*$/$1/g ;
- if (! ($name =~ /^$hDollar/))
- { &Error ("Define '$name' invalid. Name does not start with '\$'.") ; return ; }
- if (! ($name =~ /^$hDollar[a-zA-Z0-9\_]+$/))
- { &Error ("Define '$name' invalid. Valid characters are 'a'-'z', 'A'-'Z', '0'-'9', '_'.") ; return ; }
- $value =~ s/($hDollar[a-zA-Z0-9]+)/&GetDefine($command,$1)/ge ;
- @Consts {lc ($name)} = $value ;
- }
- sub ParseLineData
- {
- &GetData ;
- if ($NoData)
- { &Error ("Data expected for command 'LineData', but line is not indented.\n") ; return ; }
- if ((! (defined ($DateFormat))) || (! (defined (@Period {"from"}))))
- {
- if (! (defined ($DateFormat)))
- { &Error ("LineData invalid. No (valid) command 'DateFormat' specified in previous lines.") ; }
- else
- { &Error ("LineData invalid. No (valid) command 'Period' specified in previous lines.") ; }
- while ((! $InputParsed) && (! $NoData))
- { &GetData ; }
- return ;
- }
- my ($at, $from, $till, $atpos, $frompos, $tillpos, $color, $layer, $width, $points, $explanation) ;
- $layer = "front" ;
- $width = 2.0 ;
- my $data2 = $data ;
- LineData:
- while ((! $InputParsed) && (! $NoData))
- {
- $at = "" ; $from = "" ; $till = "" ; $atpos = "" ; $frompos = "" ; $tillpos = "" ; $points = "" ;
- &CheckPreset ("LineData") ;
- if (! &ValidAttributes ("LineData"))
- { &GetData ; next ;}
- if (defined (@LineDefs {"color"})) { $color = @LineDefs {"color"} ; }
- if (defined (@LineDefs {"layer"})) { $layer = @LineDefs {"layer"} ; }
- if (defined (@LineDefs {"width"})) { $width = @LineDefs {"width"} ; }
- if (defined (@LineDefs {"frompos"})) { $frompos = @LineDefs {"frompos"} ; }
- if (defined (@LineDefs {"tillpos"})) { $tillpos = @LineDefs {"tillpos"} ; }
- if (defined (@LineDefs {"atpos"})) { $atpos = @LineDefs {"atpos"} ; }
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($attribute =~ /^(?:At|From|Till)$/i)
- {
- if ($attrvalue =~ /^Start$/i)
- { $attrvalue = @Period {"from"} ; }
- if ($attrvalue =~ /^End$/i)
- { $attrvalue = @Period {"till"} ; }
- if (! &ValidDateFormat ($attrvalue))
- { &Error ("LineData attribute '$attribute' invalid.\n" .
- "Date does not conform to specified DateFormat '$DateFormat'.") ;
- &GetData ; next LineData ; }
- if (! &ValidDateRange ($attrvalue))
- { &Error ("LineData attribute '$attribute' invalid.\n" .
- "Date '$attrvalue' not within range as specified by command Period.") ;
- &GetData ; next LineData ; }
- # if (substr ($attrvalue,6,4) < 1800)
- # { &Error ("LineData attribute '$attribute' invalid. Specify year >= 1800.") ;
- # &GetData ; next LineData ; }
- if ($attribute =~ /At/i)
- {
- $at = $attrvalue ; $from = "" ; $till = "" ; }
- elsif ($attribute =~ /From/i)
- { $from = $attrvalue ; $at = "" ; }
- else
- { $till = $attrvalue ; $at = "" ; }
- }
- elsif ($attribute =~ /^(?:atpos|frompos|tillpos)$/i)
- {
- if ($attrvalue =~ /^(?:Start|End)$/i)
- { $attrvalue = lc ($attrvalue) ; }
- elsif (! &ValidAbs ($attrvalue))
- { &Error ("LineData attribute '$attribute' invalid.\n" .
- "Specify value as x[.y][px, in, cm] examples: '200', '20px', '1.3in'") ;
- &GetData ; next LineData ; }
- if ($attribute =~ /atpos/i)
- { $atpos = &Normalize ($attrvalue) ; }
- elsif ($attribute =~ /frompos/i)
- { $frompos = &Normalize ($attrvalue) ; }
- else
- { $tillpos = &Normalize ($attrvalue) ; }
- }
- elsif ($attribute =~ /Color/i)
- {
- if ((! &ColorPredefined ($attrvalue)) && (! defined (@Colors {lc ($attrvalue)})))
- { &Error ("LineData attribute '$attribute' invalid. Unknown color '$attrvalue'.\n" .
- " Specify command 'Color' before this command.") ;
- &GetData ; next LineData ; }
- if (! &ColorPredefined ($attrvalue))
- { $attrvalue = @Colors {lc ($attrvalue)} ; }
- $color = $attrvalue ;
- }
- elsif ($attribute =~ /Layer/i)
- {
- if (! ($attrvalue =~ /^(?:back|front)$/i))
- { &Error ("LineData attribute '$attrvalue' invalid.\nSpecify back(default) or front") ;
- &GetData ; next LineData ; }
- $layer = $attrvalue ;
- }
- elsif ($attribute =~ /Points/i)
- {
- $attribute =~ s/\s//g ;
- if ($attrvalue !~ /^$hBrO\d+\,\d+$hBrC$hBrO\d+\,\d+$hBrC$/)
- { &Error ("LineData attribute '$attrvalue' invalid.\nSpecify 'points:(x1,y1)(x2,y2)'") ;
- &GetData ; next LineData ; }
- $attrvalue =~ s/^$hBrO(\d+)\,(\d+)$hBrC$hBrO(\d+)\,(\d+)$hBrC$/$1,$2,$3,$4/ ;
- $points = $attrvalue ;
- }
- elsif ($attribute =~ /Width/i)
- {
- if (! &ValidAbs ($attrvalue))
- { &Error ("LineData attribute '$attribute' invalid.\n" .
- "Specify value as x[.y][px, in, cm] examples: '200', '20px', '1.3in'") ;
- &GetData ; next LineData ; }
- if (($attrvalue < 0.1) || ($attrvalue > 10))
- { &Error ("LineData attribute '$attribute' invalid.\n" .
- "Specify value as between 0.1 and 10") ;
- &GetData ; next LineData ; }
- $width = $attrvalue ;
- }
- }
- if (($at eq "") && ($from eq "") && ($till eq "") && ($points eq "")) # upd defaults
- {
- if ($color ne "") { @LineDefs {"color"} = $color ; }
- if ($layer ne "") { @LineDefs {"layer"} = $layer ; }
- if ($width ne "") { @LineDefs {"width"} = $width ; }
- if ($atpos ne "") { @LineDefs {"atpos"} = $atpos ; }
- if ($frompos ne "") { @LineDefs {"frompos"} = $frompos ; }
- if ($tillpos ne "") { @LineDefs {"tillpos"} = $tillpos ; }
- }
- if ($layer eq "")
- { $layer = "back" ; }
- if ($color eq "")
- { $color = "black" ; }
- $explanation = "\nA line is defined as follows:\n" .
- " Perpendicular to the time axis: 'at frompos tillpos'\n" .
- " Parralel to the time axis: 'from till atpos'\n" .
- " Any direction: points(x1,y1)(x2,y2)\n" .
- " at,from,till expect date/time values, just like with command PlotData\n" .
- " frompos,tillpos,atpos,x1,x2,y1,y2 expect coordinates (e.g. pixels values)\n" ;
- if (($at ne "") && (($from ne "") || ($till ne "") || ($points ne "")))
- { &Error ("LineData attribute 'at' can not be combined with 'from', 'till' or 'points'\n" . $explanation) ;
- $explanation = "" ;
- &GetData ; next LineData ; }
- if ((($from ne "") && ($till eq "")) || (($from eq "") && ($till ne "")))
- { &Error ("LineData attributes 'from' and 'till' should always be specified together\n" . $explanation) ;
- $explanation = "" ;
- &GetData ; next LineData ; }
- if (($points ne "") && (($from ne "") || ($till ne "") || ($at ne "")))
- { &Error ("LineData attribute 'points' can not be combined with 'at', 'from' or 'till'\n" . $explanation) ;
- $explanation = "" ;
- &GetData ; next LineData ; }
- if ($at ne "")
- { push @DrawLines, sprintf ("1|%s|%s|%s|%s|%s|%s\n", $at, $frompos, $tillpos, lc ($color), $width, lc ($layer)) ; }
- if ($from ne "")
- { push @DrawLines, sprintf ("2|%s|%s|%s|%s|%s|%s\n", $atpos, $from, $till, lc ($color), $width, lc ($layer)) ; }
- if ($points ne "")
- { push @DrawLines, sprintf ("3|%s|%s|%s|%s\n", $points, lc ($color), $width, lc ($layer)) ; }
- &GetData ;
- }
- }
- sub ParseImageSize
- {
- if (! &ValidAttributes ("ImageSize")) { return ; }
- &CheckPreset ("ImageSize") ;
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($attribute =~ /Width|Height/i)
- {
- if ($attrvalue !~ /auto/i)
- {
- if (! &ValidAbs ($attrvalue))
- { &Error ("ImageSize attribute '$attribute' invalid.\n" .
- "Specify value as x[.y][px, in, cm] examples: '200', '20px', '1.3in'") ; return ; }
- }
- }
- elsif ($attribute =~ /BarIncrement/i)
- {
- if (! &ValidAbs ($attrvalue))
- { &Error ("ImageSize attribute '$attribute' invalid.\n" .
- "Specify value as x[.y][px, in, cm] examples: '200', '20px', '1.3in'") ; return ; }
- @Attributes {"barinc"} = $attrvalue ;
- }
- # if ($attribute =~ /Width/i)
- # { @Attributes {"width"} = $attrvalue ; }
- # elsif ($attribute =~ /Height/i)
- # { @Attributes {"height"} = $attrvalue ; }
- }
- if ((@Attributes {"width"} =~ /auto/i) || (@Attributes {"height"} =~ /auto/i))
- {
- if (@Attributes {"barinc"} eq "")
- { &Error ("ImageSize attribute 'barincrement' missing.\n" .
- "Automatic determination of image width or height implies specification of this attribute") ; return ; }
- }
- if ((@Attributes {"width"} !~ /auto/i) && (@Attributes {"height"} !~ /auto/i))
- {
- if (@Attributes {"barinc"} ne "")
- { &Error ("ImageSize attribute 'barincrement' not valid now.\n" .
- "This attribute is only valid (and mandatory) in combination with 'width:auto' or 'height:auto'") ; return ; }
- }
- %Image = %Attributes ;
- }
- sub ParseLegend
- {
- if (! &ValidAttributes ("Legend")) { return ; }
- &CheckPreset ("Legend") ;
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($attribute =~ /Columns/i)
- {
- if (($attrvalue < 1) || ($attrvalue > 4))
- { &Error ("Legend attribute 'columns' invalid. Specify 1,2,3 or 4") ; return ; }
- }
- elsif ($attribute =~ /Orientation/i)
- {
- if (! ($attrvalue =~ /^(?:hor|horizontal|ver|vertical)$/i))
- { &Error ("Legend attribute '$attrvalue' invalid. Specify hor[izontal] or ver[tical]") ; return ; }
- @Attributes {"orientation"} = substr ($attrvalue,0,3) ;
- }
- elsif ($attribute =~ /Position/i)
- {
- if (! ($attrvalue =~ /^(?:top|bottom|right)$/i))
- { &Error ("Legend attribute '$attrvalue' invalid.\nSpecify top, bottom or right") ; return ; }
- }
- elsif ($attribute =~ /Left/i)
- {
- if (! &ValidAbsRel ($attrvalue))
- { &Error ("Legend attribute '$attribute' invalid.\nSpecify value as x[.y][px, in, cm] examples: '200', '20px', '1.3in'") ; return ; } }
- elsif ($attribute =~ /Top/i)
- {
- if (! &ValidAbsRel ($attrvalue))
- { &Error ("Legend attribute '$attribute' invalid.\nSpecify value as x[.y][px, in, cm] examples: '200', '20px', '1.3in'") ; return ; } }
- elsif ($attribute =~ /ColumnWidth/i)
- {
- if (! &ValidAbsRel ($attrvalue))
- { &Error ("Legend attribute '$attribute' invalid.\nSpecify value as x[.y][px, in, cm] examples: '200', '20px', '1.3in'") ; return ; }
- }
- }
- if (defined (@Attributes {"position"}))
- {
- if (defined (@Attributes {"left"}))
- { &Error ("Legend definition invalid. Attributes 'position' and 'left' are mutually exclusive.") ; return ; }
- }
- else
- {
- if ((! defined (@Attributes {"left"})) && (! defined (@Attributes {"top"})))
- {
- &Info ("Legend definition: none of attributes 'position', 'left' or 'top' have been defined. Position 'bottom' assumed.") ;
- @Attributes {"position"} = "bottom" ;
- }
- elsif ((! defined (@Attributes {"left"})) || (! defined (@Attributes {"top"})))
- { &Error ("Legend definition invalid. Specify 'position', or 'left' & 'top'.") ; return ; }
- }
- if (@Attributes {"position"} =~ /right/i)
- {
- if (defined (@Attributes {"columns"}))
- { &Error ("Legend definition invalid.\nAttribute 'columns' and 'position:right' are mutually exclusive.") ; return ; }
- if (defined (@Attributes {"columnwidth"}))
- { &Error ("Legend definition invalid.\nAttribute 'columnwidth' and 'position:right' are mutually exclusive.") ; return ; }
- }
- if (@Attributes {"orientation"} =~ /hor/i)
- {
- if (@Attributes {"position"} =~ /right/i)
- { &Error ("Legend definition invalid.\n'position:right' and 'orientation:horizontal' are mutually exclusive.") ; return ; }
- if (defined (@Attributes {"columns"}))
- { &Error ("Legend definition invalid.\nAttribute 'columns' and 'orientation:horizontal' are mutually exclusive.") ; return ; }
- if (defined (@Attributes {"columnwidth"}))
- { &Error ("Legend definition invalid.\nAttribute 'columnwidth' and 'orientation:horizontal' are mutually exclusive.") ; return ; }
- }
- if ((@Attributes {"orientation"} =~ /hor/i) && (defined (@Attributes {"columns"})))
- { &Error ("Legend definition invalid.\nDo not specify attribute 'columns' with 'orientation:horizontal'.") ; return ; }
- if (@Attributes {"columns"} > 1)
- {
- if ((defined (@Attributes {"left"})) && (! defined (@Attributes {"columnwidth"})))
- { &Error ("Legend attribute 'columnwidth' not defined.\nThis is needed when attribute 'left' is specified.") ; return ; }
- }
- if (! defined (@Attributes {"orientation"}))
- { @Attributes {"orientation"} = "ver" ; }
- %Legend = %Attributes ;
- }
- sub ParsePeriod
- {
- if (! defined ($DateFormat))
- { &Error ("Period definition ambiguous. No (valid) command 'DateFormat' specified in previous lines.") ; return ; }
- if (! ValidAttributes ("Period")) { return ; }
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($DateFormat eq "yyyy")
- {
- if ($attrvalue !~ /^\-?\d+$/)
- { &Error ("Period definition invalid.\nInvalid year '$attrvalue' specified for attribute '$attribute'.") ; return ; }
- }
- elsif ($DateFormat eq "x.y")
- {
- if (! ($attrvalue =~ /^\-?\d+(?:\.\d+)?$/))
- { &Error ("Period definition invalid.\nInvalid year '$attrvalue' specified for attribute '$attribute'.") ; return ; }
- }
- else
- {
- if (($attrvalue =~ /^\d+$/) && ($attrvalue >= 1800) && ($attrvalue <= 2030))
- {
- if ($attribute =~ /^From$/i)
- { $attrvalue = "01/01/" . $attrvalue ; }
- if ($attribute =~ /^Till$/i)
- {
- if ($DateFormat eq "dd/mm/yyyy")
- { $attrvalue = "31/12/" . $attrvalue ; }
- else
- { $attrvalue = "12/31/" . $attrvalue ; }
- }
- }
- $ValidDate = &ValidDateFormat ($attrvalue) ;
- if (! $ValidDate)
- { &Error ("Period attribute '$attribute' invalid.\n" .
- "Date does not conform to specified DateFormat '$DateFormat'.") ; return ; }
- if (substr ($attrvalue,6,4) < 1800)
- { &Error ("Period attribute '$attribute' invalid. Specify year >= 1800.") ; return ; }
- @Attributes {$attribute} = $attrvalue ;
- }
- }
- %Period = %Attributes ;
- }
- sub ParsePlotArea
- {
- if (! &ValidAttributes ("PlotArea")) { return ; }
- &CheckPreset ("PlotArea") ;
- foreach $attribute (@Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if (! &ValidAbsRel ($attrvalue))
- { &Error ("PlotArea attribute '$attribute' invalid.\n" .
- "Specify value as x[.y][px, in, cm, %] examples: '200', '20px', '1.3in', '80%'") ; return ; }
- }
- if ((@Attributes {"top"} ne "") && (@Attributes {"height"} ne ""))
- { &Error ("PlotArea attributes 'top' and 'height' are mutually exclusive. Specify only one of them.") ; return ; }
- if ((@Attributes {"right"} ne "") && (@Attributes {"width"} ne ""))
- { &Error ("PlotArea attributes 'right' and 'width' are mutually exclusive. Specify only one of them.") ; return ; }
- if ((@Attributes {"top"} eq "") && (@Attributes {"height"} eq ""))
- { &Error ("PlotArea definition incomplete. Either attribute 'top' (advised) or 'height' should be specified") ; return ; }
- if ((@Attributes {"right"} eq "") && (@Attributes {"width"} eq ""))
- { &Error ("PlotArea definition incomplete. Either attribute 'right' (advised) or 'width' should be specified") ; return ; }
- %PlotArea = %Attributes ;
- }
- # command Bars found ?
- # Y | N
- # bar: found ? | bar: found ?
- # Y | N | Y | N
- # validate | previous bar: found? | @Bars contains | previous bar: found?
- # bar:.. | | bar: ? | Y | N
- # | Y | N | | copy | assume
- # | copy | $#Bars .. | Y | N | bar: | bar:---
- # | bar: |== 0 | - | assume | |
- # | | assume bar:--- | | bar:--- | |
- # | |== 1 |
- # | | assume @Bar[0] |
- # | |> 1 |
- # | | err |
- sub ParsePlotData
- {
- if (defined (@Bars))
- { $BarsCommandFound = $true ; }
- else
- { $BarsCommandFound = $false ; }
- $prevbar = "" ;
- if ((! (defined ($DateFormat))) || (@Period {"from"} eq "") || (@Axis {"time"} eq ""))
- {
- if (! (defined ($DateFormat)))
- { &Error ("PlotData invalid. No (valid) command 'DateFormat' specified in previous lines.") ; }
- elsif (@Period {"from"} eq "")
- { &Error ("PlotData invalid. No (valid) command 'Period' specified in previous lines.") ; }
- else
- { &Error ("PlotData invalid. No (valid) command 'TimeAxis' specified in previous lines.") ; }
- &GetData ;
- while ((! $InputParsed) && (! $NoData))
- { &GetData ; }
- return ;
- }
- &GetData ;
- if ($NoData)
- { &Error ("Data expected for command 'PlotData', but line is not indented.\n") ; return ; }
- my ($bar, $at, $from, $till, $color, $bgcolor, $textcolor, $fontsize, $width,
- $text, $anchor, $align, $shift, $shiftx, $shifty, $mark, $markcolor, $link, $hint) ;
- @PlotDefs {"anchor"} = "middle" ;
- PlotData:
- while ((! $InputParsed) && (! $NoData))
- {
- if (! &ValidAttributes ("PlotData"))
- { &GetData ; next ;}
- $bar = "" ; # $barset = "" ;
- $at = "" ; $from = "" ; $till = "" ;
- $color = "barcoldefault" ; $bgcolor = "" ; $textcolor = "black" ; $fontsize = "S" ; $width = "0.25" ;
- $text = "" ; $align = "left" ; $shift = "" ; $shiftx = "" ; $shifty = "" ; $anchor = "" ;
- $mark = "" ; $markcolor = "" ;
- $link = "" ; $hint = "" ;
- &CheckPreset ("PlotData") ;
- if (defined (@PlotDefs {"bar"})) { $bar = @PlotDefs {"bar"} ; }
- # if (defined (@PlotDefs {"barset"})) { $barset = @PlotDefs {"barset"} ; }
- if (defined (@PlotDefs {"color"})) { $color = @PlotDefs {"color"} ; }
- if (defined (@PlotDefs {"bgcolor"})) { $bgcolor = @PlotDefs {"bgcolor"} ; }
- if (defined (@PlotDefs {"textcolor"})) { $textcolor = @PlotDefs {"textcolor"} ; }
- if (defined (@PlotDefs {"fontsize"})) { $fontsize = @PlotDefs {"fontsize"} ; }
- if (defined (@PlotDefs {"width"})) { $width = @PlotDefs {"width"} ; }
- if (defined (@PlotDefs {"anchor"})) { $anchor = @PlotDefs {"anchor"} ; }
- if (defined (@PlotDefs {"align"})) { $align = @PlotDefs {"align"} ; }
- if (defined (@PlotDefs {"shiftx"})) { $shiftx = @PlotDefs {"shiftx"} ; }
- if (defined (@PlotDefs {"shifty"})) { $shifty = @PlotDefs {"shifty"} ; }
- if (defined (@PlotDefs {"mark"})) { $mark = @PlotDefs {"mark"} ; }
- if (defined (@PlotDefs {"markcolor"})) { $markcolor = @PlotDefs {"markcolor"} ; }
- # if (defined (@PlotDefs {"link"})) { $link = @PlotDefs {"link"} ; }
- # if (defined (@PlotDefs {"hint"})) { $hint = @PlotDefs {"hint"} ; }
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($attribute =~ /^Bar$/i)
- {
- if (! ($attrvalue =~ /[a-zA-Z0-9\_]+/))
- { &Error ("PlotData attribute '$attribute' invalid.\n" .
- "Use only characters 'a'-'z', 'A'-'Z', '0'-'9', '_'\n") ;
- &GetData ; next PlotData ; }
- $attrvalue2 = $attrvalue ;
- if ($BarsCommandFound)
- {
- if (! &BarDefined ($attrvalue2))
- { &Error ("PlotData invalid. Bar '$attrvalue' not (properly) defined.") ;
- &GetData ; next PlotData ; }
- }
- else
- {
- if (! &BarDefined ($attrvalue2))
- {
- if (@Axis {"time"} eq "x")
- { push @Bars, $attrvalue2 ; }
- else
- { unshift @Bars, $attrvalue2 ; }
- }
- }
- $bar = $attrvalue2 ;
- $prevbar = $bar ;
- }
- elsif ($attribute =~ /^BarSet$/i)
- {
- if (! ($attrvalue =~ /[a-zA-Z0-9\_]+/))
- { &Error ("PlotData attribute '$attribute' invalid.\n" .
- "Use only characters 'a'-'z', 'A'-'Z', '0'-'9', '_'\n") ;
- &GetData ; next PlotData ; }
- $attrvalue2 = $attrvalue ;
- if ($attrvalue =~ /break/i)
- { $barndx = 0 ; }
- elsif ($attrvalue =~ /skip/i)
- {
- $barndx ++ ;
- &BarDefined ($prevbar . "#" . $barndx) ;
- }
- else
- {
- if ($BarsCommandFound)
- {
- if (! &BarDefined ($attrvalue2 . "#1"))
- { &Error ("PlotData invalid. BarSet '$attrvalue' not (properly) defined with command BarData.") ;
- &GetData ; next PlotData ; }
- }
- $bar = $attrvalue2 ;
- if ($bar ne $prevbar)
- { $barndx = 0 ; }
- $prevbar = $bar ;
- }
- }
- elsif ($attribute =~ /^(?:At|From|Till)$/i)
- {
- if ($attrvalue =~ /^Start$/i)
- { $attrvalue = @Period {"from"} ; }
- if ($attrvalue =~ /^End$/i)
- { $attrvalue = @Period {"till"} ; }
- if (! &ValidDateFormat ($attrvalue))
- {
- &Error ("PlotData attribute '$attribute' invalid.\n" .
- "Date '$attrvalue' does not conform to specified DateFormat $DateFormat.") ;
- &GetData ; next PlotData ; }
- if (! &ValidDateRange ($attrvalue))
- { &Error ("Plotdata attribute '$attribute' invalid.\n" .
- "Date '$attrvalue' not within range as specified by command Period.") ;
- &GetData ; next PlotData ; }
- if ($attribute =~ /^At$/i)
- { $at = $attrvalue ; }
- elsif ($attribute =~ /^From$/i)
- { $from = $attrvalue ; }
- else
- { $till = $attrvalue ; }
- }
- # elsif ($attribute =~ /^From$/i)
- # {
- # if ($attrvalue =~ /^Start$/i)
- # { $attrvalue = @Period {"from"} ; }
- # if (! &ValidDateFormat ($attrvalue))
- # { &Error ("PlotData invalid.\nDate '$attrvalue' does not conform to specified DateFormat $DateFormat.") ;
- # &GetData ; next PlotData ; }
- # if (! &ValidDateRange ($attrvalue))
- # { &Error ("Plotdata attribute 'from' invalid.\n" .
- # "Date '$attrvalue' not within range as specified by command Period.") ;
- # &GetData ; next PlotData ; }
- # $from = $attrvalue ;
- # }
- # elsif ($attribute =~ /^Till$/i)
- # {
- # if ($attrvalue =~ /^End$/i)
- # { $attrvalue = @Period {"till"} ; }
- # if (! &ValidDateFormat ($attrvalue))
- # { &Error ("PlotData invalid. Date '$attrvalue' does not conform to specified DateFormat $DateFormat.") ;
- # &GetData ; next PlotData ; }
- # if (! &ValidDateRange ($attrvalue))
- # { &Error ("Plotdata attribute 'till' invalid.\n" .
- # "Date '$attrvalue' not within range as specified by command Period.") ;
- # &GetData ; next PlotData ; }
- # $till = $attrvalue ;
- # }
- elsif ($attribute =~ /^Color$/i)
- {
- if (! &ColorPredefined ($attrvalue))
- {
- if (! defined (@Colors {lc ($attrvalue)}))
- { &Error ("PlotData invalid. Attribute '$attribute' has unknown color '$attrvalue'.\n" .
- " Specify command 'Color' before this command.") ;
- &GetData ; next PlotData ; }
- }
- if (defined (@Colors {lc ($attrvalue)}))
- { $color = @Colors { lc ($attrvalue) } ; }
- else
- { $color = lc ($attrvalue) ; }
- $color = $attrvalue ;
- }
- elsif ($attribute =~ /^BgColor$/i)
- {
- if (! &ColorPredefined ($attrvalue))
- {
- if (! defined (@Colors {lc ($attrvalue)}))
- { &Error ("PlotData invalid. Attribute '$attribute' has unknown color '$attrvalue'.\n" .
- " Specify command 'Color' before this command.") ;
- &GetData ; next PlotData ; }
- }
- if (defined (@Colors {lc ($attrvalue)}))
- { $bgcolor = @Colors { lc ($attrvalue) } ; }
- else
- { $bgcolor = lc ($attrvalue) ; }
- }
- elsif ($attribute =~ /^TextColor$/i)
- {
- if (! &ColorPredefined ($attrvalue))
- {
- if (! defined (@Colors {lc ($attrvalue)}))
- { &Error ("PlotData invalid. Attribute '$attribute' contains unknown color '$attrvalue'.\n" .
- " Specify command 'Color' before this command.") ;
- &GetData ; next PlotData ; }
- }
- if (defined (@Colors {lc ($attrvalue)}))
- { $textcolor = @Colors { lc ($attrvalue) } ; }
- else
- { $textcolor = lc ($attrvalue) ; }
- }
- elsif ($attribute =~ /^Width$/i)
- {
- $width = &Normalize ($attrvalue) ;
- if ($width > $MaxBarWidth)
- { $MaxBarWidth = $width ; }
- }
- elsif ($attribute =~ /^FontSize$/i)
- {
- if (($attrvalue !~ /\d+(?:\.\d)?/) && ($attrvalue !~ /xs|s|m|l|xl/i))
- { &Error ("PlotData invalid. Specify for attribute '$attribute' a number of XS,S,M,L,XL.") ;
- &GetData ; next PlotData ; }
- $fontsize = $attrvalue ;
- if ($fontsize =~ /(?:XS|S|M|L|XL)/i)
- {
- if ($fontsize !~ /(?:xs|s|m|l|xl)/i)
- {
- if ($fontsize < 6)
- { &Warning ("TextData attribute 'fontsize' value too low. Font size 6 assumed.\n") ;
- $fontsize = 6 ; }
- if ($fontsize > 30)
- { &Warning ("TextData attribute 'fontsize' value too high. Font size 30 assumed.\n") ;
- $fontsize = 30 ; }
- }
- }
- }
- elsif ($attribute =~ /^Anchor$/i)
- {
- if (! ($attrvalue =~ /^(?:from|till|middle)$/i))
- { &Error ("PlotData value '$attribute' invalid. Specify 'from', 'till' or 'middle'.") ;
- &GetData ; next PlotData ; }
- $anchor = lc ($attrvalue) ;
- }
- elsif ($attribute =~ /^Align$/i)
- {
- if (! ($attrvalue =~ /^(?:left|right|center)$/i))
- { &Error ("PlotData value '$attribute' invalid. Specify 'left', 'right' or 'center'.") ;
- &GetData ; next PlotData ; }
- $align = lc ($attrvalue) ;
- }
- elsif ($attribute =~ /^Shift$/i)
- {
- $shift = $attrvalue ;
- $shift =~ s/$hBrO(.*?)$hBrC/$1/ ;
- $shift =~ s/\s//g ;
- ($shiftx2,$shifty2) = split (",", $shift) ;
- if ($shiftx2 ne "")
- { $shiftx = &Normalize ($shiftx2) ; }
- if ($shifty2 ne "")
- { $shifty = &Normalize ($shifty2) ; }
- if (($shiftx < -10) || ($shiftx > 10) || ($shifty < -10) || ($shifty > 10))
- { &Error ("PlotData invalid. Attribute '$shift', specify value(s) between -1000 and 1000 pixels = -10 and 10 inch.") ;
- &GetData ; next PlotData ; }
- }
- elsif ($attribute =~ /^Text$/i)
- {
- $text = &ParseText ($attrvalue) ;
- $text =~ s/\\n/\n/g ;
- if ($text =~ /\^/)
- { &Warning ("TextData attribute 'text' contains ^ (caret).\n" .
- "Caret symbol will not be translated into tab character (use TextData when tabs are needed)") ; }
- # $text=~ s/(\[\[ [^\]]* \n [^\]]* \]\])/&NormalizeWikiLink($1)/gxe ;
- $text=~ s/(\[\[? [^\]]* \n [^\]]* \]?\])/&NormalizeWikiLink($1)/gxe ;
- }
- elsif ($attribute =~ /^Link$/i)
- {
- $link = &ParseText ($attrvalue) ;
- $link = &EncodeURL (&NormalizeURL ($link)) ;
- }
- # elsif ($attribute =~ /^Hint$/i)
- # {
- # $hint = &ParseText ($attrvalue) ;
- # $hint =~ s/\\n/\n/g ;
- # }
- elsif ($attribute =~ /^Mark$/i)
- {
- $attrvalue =~ s/$hBrO (.*) $hBrC/$1/x ;
- (@suboptions) = split (",", $attrvalue) ;
- $mark = @suboptions [0] ;
- if (! ($mark =~ /^(?:Line|None)$/i))
- { &Error ("PlotData invalid. Value '$mark' for attribute 'mark' unknown.") ;
- &GetData ; next PlotData ; }
- if (defined (@suboptions [1]))
- {
- $markcolor = @suboptions [1] ;
- if (! &ColorPredefined ($markcolor))
- {
- if (! defined (@Colors {lc ($markcolor)}))
- { &Error ("PlotData invalid. Attribute 'mark': unknown color '$markcolor'.\n" .
- " Specify command 'Color' before this command.") ;
- &GetData ; next PlotData ; }
- }
- $markcolor = lc ($markcolor) ;
- }
- else
- { $markcolor = "black" ; }
- }
- else
- { &Error ("PlotData invalid. Unknown attribute '$attribute' found.") ;
- &GetData ; next PlotData ; }
- }
- # if ($text =~ /\[\[.*\[\[/s)
- # { &Error ("PlotData invalid. Text segment '$text' contains more than one wiki link. Only one allowed.") ;
- # &GetData ; next PlotData ; }
- # if (($text ne "") || ($link ne ""))
- # { ($text, $link, $hint) = &ProcessWikiLink ($text, $link, $hint) ; }
- $shift = $shiftx . "," . $shifty ;
- if ($MaxBarWidth eq "")
- { $MaxBarWidth = $width - 0.001 ; }
- if ($bar ne "")
- {
- if (! defined (@BarLegend {lc($bar)}))
- { @BarLegend {lc($bar)} = $bar ; }
- if (! defined (@BarWidths {$bar}))
- { @BarWidths {$bar} = $width ; } # was 0 ??
- }
- if (($at eq "") && ($from eq "") && ($till eq "")) # upd defaults
- {
- if ($bar ne "") { @PlotDefs {"bar"} = $bar ; }
- # if ($barset ne "") { @PlotDefs {"barset"} = $barset ; }
- if ($color ne "") { @PlotDefs {"color"} = $color ; }
- if ($bgcolor ne "") { @PlotDefs {"bgcolor"} = $bgcolor ; }
- if ($textcolor ne "") { @PlotDefs {"textcolor"} = $textcolor ; }
- if ($fontsize ne "") { @PlotDefs {"fontsize"} = $fontsize ; }
- if ($width ne "") { @PlotDefs {"width"} = $width ; }
- if ($anchor ne "") { @PlotDefs {"anchor"} = $anchor ; }
- if ($align ne "") { @PlotDefs {"align"} = $align ; }
- if ($shiftx ne "") { @PlotDefs {"shiftx"} = $shiftx ; }
- if ($shifty ne "") { @PlotDefs {"shifty"} = $shifty ; }
- if ($mark ne "") { @PlotDefs {"mark"} = $mark ; }
- if ($markcolor ne "") { @PlotDefs {"markcolor"} = $markcolor ; }
- # if ($link ne "") { @PlotDefs {"link"} = $link ; }
- # if ($hint ne "") { @PlotDefs {"hint"} = $hint ; }
- &GetData ; next PlotData ;
- }
- if ($bar eq "")
- {
- if ($prevbar ne "")
- { $bar = $prevbar ; }
- else
- {
- # if ($BarsCommandFound)
- # {
- if ($#Bars > 0)
- { &Error ("PlotData invalid. Specify attribute 'bar'.") ;
- &GetData ; next PlotData ; }
- elsif ($#Bars == 0)
- {
- $bar = @Bars [0] ;
- &Info ($data, "PlotData incomplete. Attribute 'bar' missing, value '" . @Bars [0] . "' assumed.") ;
- }
- else
- { $bar = "1" ; }
- # }
- # else
- # {
- # if ($#Bars > 0)
- # { &Error ("PlotData invalid. Attribute 'bar' missing.") ;
- # &GetData ; next PlotData ; }
- # elsif ($#Bars == 0)
- # {
- # $bar = @Bars [0] ;
- # &Info ($data, "PlotData incomplete. Attribute 'bar' missing, value '" . @Bars [0] . "' assumed.") ;
- # }
- # else { $bar = "1" ; }
- # }
- $prevbar = $bar ;
- }
- }
- if (&BarDefined ($bar . "#1")) # bar is actually a bar set
- {
- if (($from ne "") || ($at ne "") || ($text eq " ")) # data line ?
- {
- $barndx++ ;
- if (! &BarDefined ($bar . "#" . $barndx))
- { $barndx = 1 ; }
- $bar = $bar . "#" . $barndx ;
- # $text = $bar ;
- }
- }
- if (($at ne "") && (($from ne "") || ($till ne "")))
- { &Error ("PlotData invalid. Attributes 'at' and 'from/till' are mutually exclusive.") ;
- &GetData ; next PlotData ; }
- if ((($from eq "") && ($till ne "")) || (($from ne "") && ($till eq "")))
- { &Error ("PlotData invalid. Specify attribute 'at' or 'from' + 'till'.") ;
- &GetData ; next PlotData ; }
- if ($at ne "")
- {
- if ($text ne "")
- {
- if ($align eq "")
- { &Error ("PlotData invalid. Attribute 'align' missing.") ;
- &GetData ; next PlotData ; }
- if ($fontsize eq "")
- { &Error ("PlotData invalid. Attribute '[font]size' missing.") ;
- &GetData ; next PlotData ; }
- if ($text eq "")
- { &Error ("PlotData invalid. Attribute 'text' missing.") ;
- &GetData ; next PlotData ; }
- }
- }
- else
- {
- if (($text ne "") && ($anchor eq ""))
- { &Error ("PlotData invalid. Attribute 'anchor' missing.") ;
- &GetData ; next PlotData ; }
- if ($color eq "")
- { &Error ("PlotData invalid. Attribute 'color' missing.") ;
- &GetData ; next PlotData ; }
- if ($width eq "")
- { &Error ("PlotData invalid. Attribute 'width' missing.") ;
- &GetData ; next PlotData ; }
- }
- if ($from ne "")
- {
- if (($link ne "") && ($hint eq ""))
- { $hint = &ExternalLinkToHint ($link) ; }
- if (($link ne "") || ($hint ne ""))
- { $MapPNG = $true ; }
- if ($link ne "")
- { $MapSVG = $true ; }
- push @PlotBars, sprintf ("%6.3f,%s,%s,%s,%s,%s,%s,\n", $width, $bar, $from, $till, lc ($color),$link,$hint) ;
- if ($width > @BarWidths {$bar})
- { @BarWidths {$bar} = $width ; }
- if ($text ne "")
- {
- if ($anchor eq "from")
- { $at = $from ; }
- elsif ($anchor eq "till")
- { $at = $till ; }
- else
- { $at = &DateMedium ($from, $till) ; }
- }
- if (($mark ne "") && ($mark !~ /none/i))
- {
- push @PlotLines, sprintf ("%s,%s,%s,%s,,,\n", $bar, $from, $from, lc ($markcolor)) ;
- push @PlotLines, sprintf ("%s,%s,%s,%s,,,\n", $bar, $till, $till, lc ($markcolor)) ;
- $mark = "" ;
- }
- }
- if ($at ne "")
- {
- if (($mark ne "") && ($mark !~ /none/i))
- { push @PlotLines, sprintf ("%s,%s,%s,%s,,,\n", $bar, $at, $at, lc ($markcolor)) ; }
- if ($text ne "")
- {
- my $textdetails = "" ;
- if ($link ne "")
- {
- if ($text =~ /\[.*\]/)
- {
- &Warning ("PlotData contains implicit link(s) in attribute 'text' and explicit attribute 'link'. " .
- "Implicit link(s) ignored.") ;
- $text =~ s/\[+ (?:[^\|]* \|)? ([^\]]*) \]+/$1/gx ;
- }
- if ($hint eq "")
- { $hint = &ExternalLinkToHint ($link) ; }
- }
- if ($anchor eq "")
- { $anchor = "middle" ; }
- if ($align eq "")
- { $align = "center" ; }
- if ($color eq "")
- { $color = "black" ; }
- if ($fontsize eq "")
- { $fontsize = "S" ; }
- if ($adjust eq "")
- { $adjust = "0,0" ; }
- # $textdetails = " textdetails: align=$align size=$size" ;
- # if ($textcolor eq "")
- # { $textcolor = "black" ; }
- # if ($color ne "")
- # { $textdetails .= " color=$textcolor" ; }
- # my ($xpos, $ypos) ;
- # my $barcnt = 0 ;
- # for ($b = 0 ; $b <= $#Bars ; $b++)
- # {
- # if (lc(@Bars [$b]) eq lc($bar))
- # { $barcnt = ($b + 1) ; last ; }
- # }
- # if (@Axis {"time"} eq "x")
- # { $xpos = "$at(s)" ; $ypos = "[$barcnt](s)" ; }
- # else
- # { $ypos = "$at(s)" ; $xpos = "[$barcnt](s)" ; }
- # if ($shift ne "")
- # {
- # my ($shiftx, $shifty) = split (",", $shift) ;
- # if ($shiftx > 0)
- # { $xpos .= "+$shiftx" ; }
- # if ($shiftx < 0)
- # { $xpos .= "$shiftx" ; }
- # if ($shifty > 0)
- # { $ypos .= "+$shifty" ; }
- # if ($shifty < 0)
- # { $ypos .= "$shifty" ; }
- # }
- $text =~ s/\,/\#\%\$/g ;
- $link =~ s/\,/\#\%\$/g ;
- $hint =~ s/\,/\#\%\$/g ;
- $shift =~ s/\,/\#\%\$/g ;
- $textcolor =~ s/\,/\#\%\$/g ;
- push @PlotText, sprintf ("%s,%s,%s,%s,%s,%s,%s,%s,%s", $at, $bar, $text, $textcolor, $fontsize, $align, $shift, $link, $hint) ;
- }
- }
- &GetData ;
- }
- if ((! $BarsCommandFound) && ($#Bars > 1))
- { &Info2 ("PlotBars definition: no (valid) command 'BarData' found in previous lines.\nBars will presented in order of appearance in PlotData.") ; }
- $maxwidth = 0 ;
- foreach $key (keys %BarWidths)
- {
- if (@BarWidths {$key} == 0)
- { &Warning ("PlotData incomplete. No bar width defined for bar '$key', assume width from widest bar (used for line marks).") ; }
- elsif (@BarWidths {$key} > $maxwidth)
- { $maxwidth = @BarWidths {$key} ; }
- }
- foreach $key (keys %BarWidths)
- {
- if (@BarWidths {$key} == 0)
- { @BarWidths {$key} = $maxwidth ; }
- }
- }
- sub ParsePreset
- {
- if (! $firstcmd)
- { &Error ("Specify 'Preset' command before any other commands, if desired at all.\n") ; return ; }
- $preset = @Attributes {"single"} ;
- if ($preset !~ /^(?:TimeVertical_OneBar_UnitYear|TimeHorizontal_AutoPlaceBars_UnitYear)$/i)
- { &Error ("Preset value invalid.\n" .
- " At the moment two presets are available:\n" .
- " TimeVertical_OneBar_UnitYear and TimeHorizontal_AutoPlaceBars_UnitYear\n" .
- " See also meta.wikipedia.org/wiki/EasyTimeline/Presets") ; return ; }
- $Preset = $preset ;
- if ($Preset =~ /^TimeVertical_OneBar_UnitYear/i)
- {
- $DateFormat = "yyyy" ;
- $AlignBars = "early" ;
- @Axis {"format"} = "yyyy" ;
- @Axis {"time"} = "y" ;
- @PlotArea {"left"} = 45 ;
- @PlotArea {"right"} = 10 ;
- @PlotArea {"top"} = 10 ;
- @PlotArea {"bottom"} = 10 ;
- push @PresetList, "PlotArea|+|left|" . @PlotArea {"left"} ;
- push @PresetList, "PlotArea|+|right|" . @PlotArea {"right"};
- push @PresetList, "PlotArea|+|top|" . @PlotArea {"top"} ;
- push @PresetList, "PlotArea|+|bottom|" . @PlotArea {"bottom"} ;
- push @PresetList, "PlotArea|-|width" ;
- push @PresetList, "PlotArea|-|height" ;
- push @PresetList, "Dateformat|-||yyyy" ;
- push @PresetList, "TimeAxis|=|format|" . @Axis {"format"} ;
- push @PresetList, "TimeAxis|=|orientation|vertical" ;
- push @PresetList, "ScaleMajor|=|unit|year" ;
- push @PresetList, "ScaleMinor|=|unit|year" ;
- push @PresetList, "AlignBars|=||early" ;
- push @PresetList, "PlotData|+|mark|" . $hBrO . "line,white" . $hBrC ;
- push @PresetList, "PlotData|+|align|left" ;
- push @PresetList, "PlotData|+|fontsize|S" ;
- push @PresetList, "PlotData|+|width|20" ;
- push @PresetList, "PlotData|+|shift|" . $hBrO . "20,0" . $hBrC ;
- }
- elsif ($Preset =~ /TimeHorizontal_AutoPlaceBars_UnitYear/i)
- {
- $DateFormat = "yyyy" ;
- $AlignBars = "justify" ;
- @Axis {"format"} = "yyyy" ;
- @Axis {"time"} = "x" ;
- @PlotArea {"left"} = 25 ;
- @PlotArea {"right"} = 25 ;
- @PlotArea {"top"} = 15 ;
- @PlotArea {"bottom"} = 30 ;
- @Image {"height"} = "auto" ;
- @Image {"barinc"} = 20 ;
- @BackgroundColors {"canvas"} = "gray(0.7)" ;
- @Legend {"orientation"} = "ver" ;
- @Legend {"left"} = @PlotArea {"left"}+10 ;
- @Legend {"top"} = @PlotArea {"bottom"}+100 ;
- &StoreColor ("canvas", &EncodeInput ("gray(0.7)"), "") ;
- &StoreColor ("grid1", &EncodeInput ("gray(0.4)"), "") ;
- &StoreColor ("grid2", &EncodeInput ("gray(0.2)"), "") ;
- push @PresetList, "ImageSize|=|height|auto" ;
- push @PresetList, "ImageSize|+|barincrement|20" ;
- push @PresetList, "PlotArea|+|left|" . @PlotArea {"left"} ;
- push @PresetList, "PlotArea|+|right|" . @PlotArea {"right"};
- push @PresetList, "PlotArea|+|top|" . @PlotArea {"top"} ;
- push @PresetList, "PlotArea|+|bottom|" . @PlotArea {"bottom"} ;
- push @PresetList, "PlotArea|-|width" ;
- push @PresetList, "PlotArea|-|height" ;
- push @PresetList, "Dateformat|-||yyyy" ;
- push @PresetList, "TimeAxis|=|format|" . @Axis {"format"} ;
- push @PresetList, "TimeAxis|=|orientation|horizontal" ;
- push @PresetList, "ScaleMajor|=|unit|year" ;
- push @PresetList, "ScaleMajor|+|grid|grid1" ;
- push @PresetList, "ScaleMinor|=|unit|year" ;
- push @PresetList, "AlignBars|=||justify" ;
- push @PresetList, "Legend|+|orientation|" . @Legend {"orientation"} ;
- push @PresetList, "Legend|+|left|" . @Legend {"left"} ;
- push @PresetList, "Legend|+|top|" . @Legend {"top"} ;
- push @PresetList, "PlotData|+|align|left" ;
- push @PresetList, "PlotData|+|anchor|from" ;
- push @PresetList, "PlotData|+|fontsize|M" ;
- push @PresetList, "PlotData|+|width|15" ;
- push @PresetList, "PlotData|+|textcolor|black" ;
- push @PresetList, "PlotData|+|shift|" . $hBrO . "4,-6" . $hBrC ;
- }
- }
- sub ParseScale
- {
- my ($scale) ;
- if ($Command =~ /ScaleMajor/i)
- { $scale .= 'Major' ; }
- else
- { $scale .= 'Minor' ; }
- if (! ValidAttributes ("Scale" . $scale)) { return ; }
- &CheckPreset (Scale . $scale) ;
- @Scales {$scale} = $true ;
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($attribute =~ /Grid/i) # preferred gridcolor instead of grid, grid allowed for compatability
- {
- if ((! &ColorPredefined ($attrvalue)) && (! defined (@Colors {lc ($attrvalue)})))
- { &Error ("Scale attribute '$attribute' invalid. Unknown color '$attrvalue'.\n" .
- " Specify command 'Color' before this command.") ; return ; }
- @Attributes {$scale . " grid"} = $attrvalue ;
- delete (@Attributes {"grid"}) ;
- }
- elsif ($attribute =~ /Text/i)
- {
- $attrvalue =~ s/\~/\\n/g ;
- $attrvalue =~ s/^\"//g ;
- $attrvalue =~ s/\"$//g ;
- @Attributes {$scale . " stubs"} = $attrvalue ;
- }
- elsif ($attribute =~ /Unit/i)
- {
- if ($DateFormat eq "yyyy")
- {
- if (! ($attrvalue =~ /^(?:year|years)$/i))
- { &Error ("Scale attribute '$attribute' invalid. DateFormat 'yyyy' implies 'unit:year'.") ; return ; }
- }
- else
- {
- if (! ($attrvalue =~ /^(?:year|month|day)s?$/i))
- { &Error ("Scale attribute '$attribute' invalid. Specify year, month or day.") ; return ; }
- }
- $attrvalue =~ s/s$// ;
- @Attributes {$scale . " unit"} = $attrvalue ;
- delete (@Attributes {"unit"}) ;
- }
- elsif ($attribute =~ /Increment/i)
- {
- if ((! ($attrvalue =~ /^\d+$/i)) || ($attrvalue == 0))
- { &Error ("Scale attribute '$attribute' invalid. Specify positive integer.") ; return ; }
- @Attributes {$scale . " inc"} = $attrvalue ;
- delete (@Attributes {"increment"}) ;
- }
- elsif ($attribute =~ /Start/i)
- {
- if (! (defined ($DateFormat)))
- { &Error ("Scale attribute '$attribute' invalid.\n" .
- "No (valid) command 'DateFormat' specified in previous lines.") ; return ; }
- if (($DateFormat eq "dd/mm/yyyy") || ($DateFormat eq "mm/dd/yyyy"))
- {
- if (($attrvalue =~ /^\d+$/) && ($attrvalue >= 1800) && ($attrvalue <= 2030))
- { $attrvalue = "01/01/" . $attrvalue ; }
- }
- if (! &ValidDateFormat ($attrvalue))
- { &Error ("Scale attribute '$attribute' invalid.\n" .
- "Date does not conform to specified DateFormat '$DateFormat'.") ; return ; }
- if (($DateFormat =~ /\d\d\/\d\d\/\d\d\d\d/) && (substr ($attrvalue,6,4) < 1800))
- { &Error ("Scale attribute '$attribute' invalid.\n" .
- " Specify year >= 1800.") ; return ; }
- if (! &ValidDateRange ($attrvalue))
- { &Error ("Scale attribute '$attribute' invalid.\n" .
- "Date '$attrvalue' not within range as specified by command Period.") ; return ; }
- @Attributes {$scale . " start"} = $attrvalue ;
- delete (@Attributes {"start"}) ;
- }
- if ($DateFormat eq "yyyy") { @Attributes {$scale . " unit"} = "year" ; }
- }
- foreach $attribute (keys %Attributes)
- { @Scales {$attribute} = @Attributes {$attribute} ; }
- }
- sub ParseTextData
- {
- &GetData ;
- if ($NoData)
- { &Error ("Data expected for command 'TextData', but line is not indented.\n") ; return ; }
- my ($pos, $tabs, $fontsize, $lineheight, $textcolor, $text, $link, $hint) ;
- TextData:
- while ((! $InputParsed) && (! $NoData))
- {
- if (! &ValidAttributes ("TextData"))
- { &GetData ; next ;}
- &CheckPreset ("TextData") ;
- $pos = "" ; $tabs = "" ; $fontsize = "" ; $lineheight = "" ; $textcolor = "" ; $link = "" ; $hint = "" ;
- if (defined (@TextDefs {"tabs"})) { $tabs = @TextDefs {"tabs"} ; }
- if (defined (@TextDefs {"fontsize"})) { $fontsize = @TextDefs {"fontsize"} ; }
- if (defined (@TextDefs {"lineheight"})) { $lineheight = @TextDefs {"lineheight"} ; }
- if (defined (@TextDefs {"textcolor"})) { $textcolor = @TextDefs {"textcolor"} ; }
- my $data2 = $data ;
- ($data2, $text) = &ExtractText ($data2) ;
- @Attributes = split (" ", $data2) ;
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($attribute =~ /^FontSize$/i)
- {
- if (($attrvalue !~ /\d+(?:\.\d)?/) && ($attrvalue !~ /^(?:xs|s|m|l|xl)$/i))
- { &Error ("TextData invalid. Attribute '$attribute': specify number of XS,S,M,L,XL.") ;
- &GetData ; next TextData ; }
- $fontsize = $attrvalue ;
- if ($fontsize !~ /^(?:xs|s|m|l|xl)$/i)
- {
- if ($fontsize < 6)
- { &Warning ("TextData attribute 'fontsize' value too low. Font size 6 assumed.\n") ;
- $fontsize = 6 ; }
- if ($fontsize > 30)
- { &Warning ("TextData attribute 'fontsize' value too high. Font size 30 assumed.\n") ;
- $fontsize = 30 ; }
- }
- }
- elsif ($attribute =~ /^LineHeight$/i)
- {
- $lineheight = &Normalize ($attrvalue) ;
- if (($lineheight < -0.4) || ($lineheight > 0.4))
- {
- if (! $bypass)
- { &Error ("TextData attribute 'lineheight' invalid.\n" .
- "Specify value up to 40 pixels = 0.4 inch\n" .
- "Run with option -b (bypass checks) when this is correct.\n") ; }
- }
- }
- elsif ($attribute =~ /^Pos$/i)
- {
- $attrvalue =~ s/\s*$hBrO (.*) $hBrC\s*/$1/x ;
- ($posx,$posy) = split (",", $attrvalue) ;
- $posx = &Normalize ($posx) ;
- $posy = &Normalize ($posy) ;
- $pos = "$posx,$posy" ;
- }
- elsif ($attribute =~ /^Tabs$/i)
- {
- $tabs = $attrvalue ;
- }
- elsif ($attribute =~ /^(?:Color|TextColor)$/i)
- {
- if (! &ColorPredefined ($attrvalue))
- {
- if (! defined (@Colors {lc ($attrvalue)}))
- { &Error ("TextData invalid. Attribute '$attribute' contains unknown color '$attrvalue'.\n" .
- " Specify command 'Color' before this command.") ;
- &GetData ; next TextData ; }
- }
- if (defined (@Colors {lc ($attrvalue)}))
- { $textcolor = @Colors { lc ($attrvalue) } ; }
- else
- { $textcolor = lc ($attrvalue) ; }
- }
- elsif ($attribute =~ /^Text$/i)
- {
- $text = $attrvalue ;
- $text =~ s/\\n/~/gs ;
- if ($text =~ /\~/)
- { &Warning ("TextData attribute 'text' contains ~ (tilde).\n" .
- "Tilde will not be translated into newline character (only in PlotData)") ; }
- }
- elsif ($attribute =~ /^Link$/i)
- {
- $link = &ParseText ($attrvalue) ;
- $link = &EncodeURL (&NormalizeURL ($link)) ;
- }
- }
- if ($fontsize eq "")
- { $fontsize = "S" ; }
- if ($lineheight eq "")
- {
- if ($fontsize =~ /^(?:XS|S|M|L|XL)$/i)
- {
- if ($fontsize =~ /XS/i) { $lineheight = 0.11 ; }
- elsif ($fontsize =~ /S/i) { $lineheight = 0.13 ; }
- elsif ($fontsize =~ /M/i) { $lineheight = 0.155 ; }
- elsif ($fontsize =~ /XL/i) { $lineheight = 0.24 ; }
- else { $lineheight = 0.19 ; }
- }
- else
- {
- $lineheight = sprintf ("%.2f", (($fontsize * 1.2) / 100)) ;
- if ($lineheight < $fontsize/100 + 0.02)
- { $lineheight = $fontsize/100 + 0.02 ; }
- }
- }
- if ($textcolor eq "")
- { $textcolor = "black" ; }
- if ($pos eq "")
- {
- $pos = @TextDefs {"pos"} ;
- ($posx,$posy) = split (",", $pos) ;
- $posy -= $lineheight ;
- if ($posy < 0)
- { $posy = 0 ; }
- $pos = "$posx,$posy" ;
- @TextDefs {"pos"} = $pos ;
- }
- # if ($link ne "")
- # { ($text, $link, $hint) = &ProcessWikiLink ($text, $link, $hint) ; }
- if ($text eq "") # upd defaults
- {
- if ($pos ne "") { @TextDefs {"pos"} = $pos ; }
- if ($tabs ne "") { @TextDefs {"tabs"} = $tabs ; }
- if ($fontsize ne "") { @TextDefs {"fontsize"} = $fontsize ; }
- if ($textcolor ne "") { @TextDefs {"textcolor"} = $textcolor ; }
- if ($lineheight ne "") { @TextDefs {"lineheight"} = $lineheight ; }
- &GetData ; next TextData ;
- }
- if ($link ne "")
- {
- if ($text =~ /\[.*\]/)
- {
- &Warning ("TextData contains implicit link(s) in attribute 'text' and explicit attribute 'link'.\n" .
- "Implicit link(s) ignored.") ;
- $text =~ s/\[+ (?:[^\|]* \|)? ([^\]]*) \]+/$1/gx ;
- }
- if ($hint eq "")
- { $hint = &ExternalLinkToHint ($link) ; }
- }
- if ($text =~ /\[ [^\]]* \^ [^\]]* \]/x)
- {
- &Warning ("TextData attribute 'text' contains tab character (^) inside implicit link ([[..]]). Tab ignored.") ;
- $text =~ s/(\[+ [^\]]* \^ [^\]]* \]+)/($a = $1), ($a =~ s+\^+ +g), $a/gxe ;
- }
- if (defined ($tabs) && ($tabs ne ""))
- {
- $tabs =~ s/^\s*$hBrO (.*) $hBrC\s*$/$1/x ;
- @Tabs = split (",", $tabs) ;
- foreach $tab (@Tabs)
- {
- $tab =~ s/\s* (.*) \s*$/$1/x ;
- if (! ($tab =~ /\d+\-(?:center|left|right)$/))
- { &Error ("Specify attribute 'tabs' as 'n-a,n-a,n-a,.. where n = numeric value, a = left|right|center.") ;
- while ((! $InputParsed) && (! $NoData)) { &GetData ; } return ; }
- }
- @Text = split ('\^', $text) ;
- if ($#Text > $#Tabs + 1)
- { &Error ("TextData invalid. " . $#Text . " tab characters ('^') in text, only " . ($#Tabs+1) . " tab(s) defined.") ;
- &GetData ; next TextData ; }
- }
- &WriteText ("^", "", 0, $posx, $posy, $text, $textcolor, $fontsize, "left", $link, $hint, $tabs) ;
- &GetData ;
- }
- }
- sub ParseTimeAxis
- {
- if (! &ValidAttributes ("TimeAxis")) { return ; }
- &CheckPreset ("TimeAxis") ;
- foreach $attribute (keys %Attributes)
- {
- my $attrvalue = @Attributes {$attribute} ;
- if ($attribute =~ /Format/i)
- {
- if ($attrvalue =~ /^yy$/i)
- { &Error ("TimeAxis attribute '$attribute' valid but not available, waiting for bug fix.\n" .
- "Please specify 'format:yyyy' instead of 'format:yy'.") ; return ; }
- if ($DateFormat eq "yyyy")
- {
- if (! ($attrvalue =~ /^(?:yy|yyyy)$/i))
- { &Error ("TimeAxis attribute '$attribute' invalid.\n" .
- "DateFormat 'yyyy' implies 'format:yy' or 'format:yyyy'.") ; return ; }
- }
- }
- elsif ($attribute =~ /Order/i)
- {
- if ($attrvalue !~ /^(?:normal|reverse)$/i)
- { &Error ("TimeAxis attribute '$attribute' invalid.\n" .
- " Specify 'order:normal' (default) or 'order:reverse'\n" .
- " normal =\n" .
- " vertical axis: highest date on top,\n" .
- " horizontal axis: highest date at right side\n" ) ; return ; }
- if (($attrvalue =~ /reverse/i) && ($DateFormat ne "yyyy"))
- { &Error ("TimeAxis attribute '$attribute' invalid.\n" .
- " 'order:reverse' is only possible with DateFormat=yyyy (sorry)\n") ; return ; }
- @Attributes {"order"} = lc ($attrvalue) ;
- }
- elsif ($attribute =~ /Orientation/i)
- {
- if ($attrvalue =~ /^hor(?:izontal)?$/i)
- { @Attributes {"time"} = "x" ; }
- elsif ($attrvalue =~ /^ver(?:tical)?$/i)
- { @Attributes {"time"} = "y" ; }
- else
- { &Error ("TimeAxis attribute '$attribute' invalid.\n" .
- "Specify hor[izontal] or ver[tical]") ; return ; }
- delete (@Attributes {"orientation"}) ;
- }
- }
- if (! defined (@Attributes {"format"}))
- { @Attributes {"format"} = "yyyy" ; }
- %Axis = %Attributes ;
- }
- sub ParseUnknownCommand
- {
- $name = $Command ;
- $name =~ s/[^a-zA-Z].*$// ;
- &Error ("Command '$name' unknown.") ;
- }
- sub RemoveSpaces
- {
- my $text = shift ;
- $text =~ s/\s//g ;
- return ($text) ;
- }
- sub DetectMissingCommands
- {
- if (! defined (%Image)) { &Error2 ("Command ImageSize missing or invalid") ; }
- if (! defined (%PlotArea)) { &Error2 ("Command PlotArea missing or invalid") ; }
- if (! defined ($DateFormat)) { &Error2 ("Command DateFormat missing or invalid") ; }
- if (! defined (@Axis {"time"})) { &Error2 ("Command TimeAxis missing or invalid") ; }
- if ((@Image {"width"} =~ /auto/i) && (@Axis {"time"} =~ /x/i))
- { &Error2 ("ImageSize value 'width:auto' only allowed with TimeAxis value 'orientation:vertical'") ; }
- if ((@Image {"height"} =~ /auto/i) && (@Axis {"time"} =~ /y/i))
- { &Error2 ("ImageSize value 'height:auto' only allowed with TimeAxis value 'orientation:horizontal'") ; }
- }
- sub Normalize
- {
- my $number = shift ;
- my $reference = shift ;
- my ($val, $dim) ;
- if (($number eq "") || ($number =~ /auto/i))
- { return ($number) ; }
- $val = $number ; $val =~ s/[^\d\.\-].*$//g ;
- $dim = $number ; $dim =~ s/\d//g ;
- if ($dim =~ /in/i) { $number = $val ; }
- elsif ($dim =~ /cm/i) { $number = $val / 2.54 ; }
- elsif ($dim =~ /%/) { $number = $reference * $val / 100 ; }
- else { $number = $val / 100 ; }
- return (sprintf ("%.3f", $number)) ;
- }
- sub ValidateAndNormalizeDimensions
- {
- my ($val, $dim) ;
- if (@Image {"width"} =~ /auto/i)
- {
- foreach $attribute ("width","left","right")
- { if (@PlotArea {$attribute} =~ /\%/)
- { &Error2 ("You specified 'ImageSize = width:auto'.\n" .
- " This implies absolute values in PlotArea attributes 'left', 'right' and/or 'width' (no \%).\n") ; return ; }
- }
- if ((@PlotArea {"width"} ne "") || (@PlotArea {"left"} eq "") || (@PlotArea {"right"} eq ""))
- { &Error2 ("You specified 'ImageSize = width:auto'.\n" .
- " This implies 'PlotArea = width:auto'.\n" .
- " Instead of 'width' specify plot margins with PlotArea attributes 'left' and 'right'.\n") ; return ; }
- }
- if (@Image {"height"} =~ /auto/i)
- {
- foreach $attribute ("height","top","bottom")
- { if (@PlotArea {$attribute} =~ /\%/)
- { &Error2 ("You specified 'ImageSize = height:auto'.\n" .
- " This implies absolute values in PlotArea attributes 'top', 'bottom' and/or 'height' (no \%).\n") ; return ; }
- }
- if ((@PlotArea {"height"} ne "") || (@PlotArea {"top"} eq "") || (@PlotArea {"bottom"} eq ""))
- { &Error2 ("You specified 'ImageSize = height:auto'.\n" .
- " This implies 'PlotArea = height:auto'.\n" .
- " Instead of 'height' specify plot margins with PlotArea attributes 'top' and 'bottom'.\n") ; return ; }
- }
- @Image {"width"} = &Normalize (@Image {"width"}) ;
- @Image {"height"} = &Normalize (@Image {"height"}) ;
- @Image {"barinc"} = &Normalize (@Image {"barinc"}) ;
- @PlotArea {"width"} = &Normalize (@PlotArea {"width"}, @Image {"width"}) ;
- @PlotArea {"height"} = &Normalize (@PlotArea {"height"}, @Image {"height"}) ;
- @PlotArea {"left"} = &Normalize (@PlotArea {"left"}, @Image {"width"}) ;
- @PlotArea {"right"} = &Normalize (@PlotArea {"right"}, @Image {"width"}) ;
- @PlotArea {"bottom"} = &Normalize (@PlotArea {"bottom"}, @Image {"height"}) ;
- @PlotArea {"top"} = &Normalize (@PlotArea {"top"}, @Image {"height"}) ;
- if (@Image {"width"} =~ /auto/i)
- {
- @PlotArea {"width"} = $#Bars * @Image {"barinc"} ;
- @Image {"width"} = @PlotArea {"left"} + @PlotArea {"width"} + @PlotArea {"right"} ;
- }
- elsif (@Image {"height"} =~ /auto/i)
- {
- @PlotArea {"height"} = $#Bars * @Image {"barinc"} ;
- @Image {"height"} = @PlotArea {"top"} + @PlotArea {"height"} + @PlotArea {"bottom"} ;
- }
- if (@PlotArea {"right"} ne "")
- { @PlotArea {"width"} = @Image {"width"} - @PlotArea {"left"} - @PlotArea {"right"} ; }
- if (@PlotArea {"top"} ne "")
- { @PlotArea {"height"} = @Image {"height"} - @PlotArea {"top"} - @PlotArea {"bottom"} ; }
- if ((@Image {"width"} > 16) || (@Image {"height"} > 20))
- {
- if (! $bypass)
- { &Error2 ("Maximum image size is 1600x2000 pixels = 16x20 inch\n" .
- " Run with option -b (bypass checks) when this is correct.\n") ; return ; }
- }
- if ((@Image {"width"} < 0.25) || (@Image {"height"} < 0.25))
- {
- &Error2 ("Minimum image size is 25x25 pixels = 0.25x0.25 inch\n") ;
- return ;
- }
- if (@PlotArea {"width"} > @Image {"width"})
- { &Error2 ("Plot width larger than image width. Please adjust.\n") ; return ; }
- if (@PlotArea {"width"} < 0.2)
- { &Error2 ("Plot width less than 20 pixels = 0.2 inch. Please adjust.\n") ; return ; }
- if (@PlotArea {"height"} > @Image {"height"})
- { &Error2 ("Plot height larger than image height. Please adjust.\n") ; return ; }
- if (@PlotArea {"height"} < 0.2)
- { &Error2 ("Plot height less than 20 pixels = 0.2 inch. Please adjust.\n") ; return ; }
- if (@PlotArea {"left"} + @PlotArea {"width"} > @Image {"width"})
- { &Error2 ("Plot width + margins larger than image width. Please adjust.\n") ; return ; }
- # @PlotArea {"left"} = @Image {"width"} - @PlotArea {"width"} ; }
- if (@PlotArea {"left"} < 0)
- { @PlotArea {"left"} = 0 ; }
- if (@PlotArea {"bottom"} + @PlotArea {"height"} > @Image {"height"})
- { &Error2 ("Plot height + margins larger than image height. Please adjust.\n") ; return ; }
- # @PlotArea {"bottom"} = @Image {"height"} - @PlotArea {"height"} ; }
- if (@PlotArea {"bottom"} < 0)
- { @PlotArea {"bottom"} = 0 ; }
- if ((defined (@Scales {"Major"})) ||
- (defined (@Scales {"Minor"})))
- {
- if (defined (@Scales {"Major"}))
- { $margin = 0.2 ; }
- else
- { $margin = 0.05 ; }
- if (@Axis {"time"} eq "x")
- {
- if (@PlotArea {"bottom"} < $margin)
- { &Error2 ("Not enough space below plot area for plotting time axis\n" .
- " Specify 'PlotArea = bottom:x', where x is at least " . (100 * $margin) . " pixels = $margin inch\n") ; return ; }
- }
- else
- {
- if (@PlotArea {"left"} < $margin)
- { &Error2 ("Not enough space outside plot area for plotting time axis\n" .
- " Specify 'PlotArea = left:x', where x is at least " . (100 * $margin) . " pixels = $margin inch\n") ; return ; }
- }
- }
- if (defined (@Legend {"orientation"}))
- {
- if (defined (@Legend {"left"}))
- { @Legend {"left"} = &Normalize (@Legend {"left"}, @Image {"width"}) ; }
- if (defined (@Legend {"top"}))
- { @Legend {"top"} = &Normalize (@Legend {"top"}, @Image {"height"}) ; }
- if (defined (@Legend {"columnwidth"}))
- { @Legend {"columnwidth"} = &Normalize (@Legend {"columnwidth"}, @Image {"width"}) ; }
- if (! defined (@Legend {"columns"}))
- {
- @Legend {"columns"} = 1 ;
- if ((@Legend {"orientation"} =~ /ver/i) &&
- (@Legend {"position"} =~ /^(?:top|bottom)$/i))
- {
- if ($#LegendData > 10)
- {
- @Legend {"columns"} = 3 ;
- &Info2 ("Legend attribute 'columns' not defined. 3 columns assumed.") ;
- }
- elsif ($#LegendData > 5)
- {
- @Legend {"columns"} = 2 ;
- &Info2 ("Legend attribute 'columns' not defined. 2 columns assumed.") ;
- }
- }
- }
- if (@Legend {"position"} =~ /top/i)
- {
- if (! defined (@Legend {"left"}))
- { @Legend {"left"} = @PlotArea {"left"} ; }
- if (! defined (@Legend {"top"}))
- { @Legend {"top"} = (@Image {"height"} - 0.2) ; }
- if ((! defined (@Legend {"columnwidth"})) && (@Legend {"columns"} > 1))
- { @Legend {"columnwidth"} = sprintf ("%02f", ((@PlotArea {"left"} + @PlotArea {"width"} - 0.2) / @Legend {"columns"})) ; }
- }
- elsif (@Legend {"position"} =~ /bottom/i)
- {
- if (! defined (@Legend {"left"}))
- { @Legend {"left"} = @PlotArea {"left"} ; }
- if (! defined (@Legend {"top"}))
- { @Legend {"top"} = (@PlotArea {"bottom"} - 0.4) ; }
- if ((! defined (@Legend {"columnwidth"})) && (@Legend {"columns"} > 1))
- { @Legend {"columnwidth"} = sprintf ("%02f", ((@PlotArea {"left"} + @PlotArea {"width"} - 0.2) / @Legend {"columns"})) ; }
- }
- elsif (@Legend {"position"} =~ /right/i)
- {
- if (! defined (@Legend {"left"}))
- { @Legend {"left"} = (@PlotArea {"left"} + @PlotArea {"width"} + 0.2) ; }
- if (! defined (@Legend {"top"}))
- { @Legend {"top"} = (@PlotArea {"bottom"} + @PlotArea {"height"} - 0.2) ; }
- }
- }
- if (! defined (@Axis {"order"}))
- { @Axis {"order"} = "normal" ; }
- }
- sub WriteProcAnnotate
- {
- my $bar = shift ;
- my $shiftx = shift ;
- my $xpos = shift ;
- my $ypos = shift ;
- my $text = shift ;
- my $textcolor = shift ;
- my $fontsize = shift ;
- my $align = shift ;
- my $link = shift ;
- my $hint = shift ;
- if (length ($text) > 250)
- { &Error ("Text segments can be up to 250 characters long. This segment is " . length ($text) . " chars.\n" .
- " You can either shorten the text or\n" .
- " - PlotData: insert line breaks (~)\n" .
- " - TextData: insert tabs (~) to produce columns\n") ; return ; }
- if ($textcolor eq "")
- { $textcolor = "black" ; }
- my $textdetails = " textdetails: align=$align size=$fontsize color=$textcolor" ;
- push @PlotTextsPng, "#proc annotate\n" ;
- push @PlotTextsSvg, "#proc annotate\n" ;
- push @PlotTextsPng, " location: $xpos $ypos\n" ;
- push @PlotTextsSvg, " location: $xpos $ypos\n" ;
- push @PlotTextsPng, $textdetails . "\n" ;
- push @PlotTextsSvg, $textdetails . "\n" ;
- $text2 = $text ;
- $text2 =~ s/\[\[//g ;
- $text2 =~ s/\]\]//g ;
- if ($text2 =~ /^\s/)
- { push @PlotTextsPng, " text: \n\\$text2\n\n" ; }
- else
- { push @PlotTextsPng, " text: $text2\n\n" ; }
- $text2 = $text ;
- if ($link ne "")
- {
- # put placeholder in Ploticus input file
- # will be replaced by real link after SVG generation
- # this allows adding color info
- push @linksSVG, &DecodeInput ($link) ;
- my $lcnt = $#linksSVG ;
- $text2 =~ s/\[\[ ([^\]]+) \]\]/\[$lcnt\[$1\]$lcnt\]/x ;
- $text2 =~ s/\[\[ ([^\]]+) $/\[$lcnt\[$1\]$lcnt\]/x ;
- $text2 =~ s/^ ([^\[]+) \]\]/\[$lcnt\[$1\]$lcnt\]/x ;
- }
- $text3 = &EncodeHtml ($text2) ;
- if ($text2 ne $text3)
- {
- # put placeholder in Ploticus input file
- # will be replaced by real text after SVG generation
- # Ploticus would autoscale image improperly when text contains &#xxx; tags
- # because this would count as 5 chars
- push @textsSVG, &DecodeInput ($text3) ;
- $text3 = "{{" . $#textsSVG . "}}" ;
- while (length ($text3) < length ($text2)) { $text3 .= "x" ; }
- }
- if ($text3 =~ /^\s/)
- { push @PlotTextsSvg, " text: \n\\$text3\n\n" ; }
- else
- { push @PlotTextsSvg, " text: $text3\n\n" ; }
- if ($link ne "")
- {
- $MapPNG = $true ;
- push @PlotTextsPng, "#proc annotate\n" ;
- push @PlotTextsPng, " location: $xpos $ypos\n" ;
- # push @PlotTextsPng, " boxmargin: 0.01\n" ;
- if ($align ne "right")
- {
- push @PlotTextsPng, " clickmapurl: $link\n" ;
- if ($hint ne "")
- { push @PlotTextsPng, " clickmaplabel: $hint\n" ; }
- }
- else
- {
- if ($bar eq "")
- {
- if ($WarnOnRightAlignedText ++ == 0)
- { &Warning2 ("Links on right aligned texts are only supported for svg output,\npending Ploticus bug fix.") ; }
- return ;
- }
- else
- {
- push @PlotTextsPng, " clickmapurl: $link\&\&$shiftx\n" ;
- if ($hint ne "")
- { push @PlotTextsPng, " clickmaplabel: $hint\n" ; }
- }
- }
- $textdetails =~ s/color=[^\s]+/color=$LinkColor/ ;
- push @PlotTextsPng, $textdetails . "\n" ;
- $text = &DecodeInput ($text) ;
- if ($text =~ /^[^\[]+\]\]/)
- { $text = "[[" . $text ; }
- if ($text =~ /\[\[[^\]]+$/)
- { $text .= "]]" ; }
- my $pos1 = index ($text, "[[") ;
- my $pos2 = index ($text, "]]") + 1 ;
- if (($pos1 > -1) && ($pos2 > -1))
- {
- for (my $i = 0 ; $i < length ($text) ; $i++)
- {
- $c = substr ($text, $i, 1) ;
- if ($c ne "\n")
- {
- if (($i < $pos1) || ($i > $pos2))
- { substr ($text, $i, 1) = " " ; }
- }
- }
- }
- $text =~ s/\[\[(.*?)\]\]/$1/s ;
- if ($text =~ /^\s/)
- { push @PlotTextsPng, " text: \n\\$text\n\n" ; }
- else
- { push @PlotTextsPng, " text: $text\n\n" ; }
- # push @PlotTextsPng, "#proc rect\n" ;
- # push @PlotTextsPng, " color: green\n" ;
- # push @PlotTextsPng, " rectangle: 1(s)+0.25 1937.500(s)+0.06 1(s)+0.50 1937.500(s)+0.058\n" ;
- # push @PlotTextsPng, "\n\n" ;
- }
- }
- sub WriteText
- {
- my $mode = shift ;
- my $bar = shift ;
- my $shiftx = shift ;
- my $posx = shift ;
- my $posy = shift ;
- my $text = shift ;
- my $textcolor = shift ;
- my $fontsize = shift ;
- my $align = shift ;
- my $link = shift ;
- my $hint = shift ;
- my $tabs = shift ;
- my ($link2, $hint2, $tab) ;
- my $outside = $false ;
- if (@Axis {"order"} =~ /reverse/i)
- {
- if (@Axis {"time"} eq "y")
- { $posy =~ s/(.*)(\(s\))/(-$1).$2/xe ; }
- else
- { $posx =~ s/(.*)(\(s\))/(-$1).$2/xe ; }
- }
- if ($posx !~ /\(s\)/)
- {
- if ($posx < 0)
- { $outside = $true ; }
- if (@Image {"width"} !~ /auto/i)
- {
- if ($posx > @Image {"width"}/100)
- { $outside = $true ; }
- }
- }
- if ($posy !~ /\(s\)/)
- {
- if ($posy < 0)
- { $outside = $true ; }
- if (@Image {"height"} !~ /auto/i)
- {
- if ($posy > @Image {"height"}/100)
- { $outside = $true ; }
- }
- }
- if ($outside)
- {
- if ($WarnTextOutsideArea++ < 5)
- { $text =~ s/\n/~/g ;
- &Error ("Text segment '$text' falls outside image area. Text ignored.") ; }
- return ;
- }
- my @Tabs = split (",", $tabs) ;
- foreach $tab (@Tabs)
- { $tab =~ s/\s* (.*) \s*$/$1/x ; }
- $posx0 = $posx ;
- my @Text ;
- my $dy = 0 ;
- if ($text =~ /\[\[.*\]\]/)
- {
- $link = "" ; $hint = "" ;
- }
- my @Text ;
- if ($mode eq "^")
- { @Text = split ('\^', $text) ; }
- elsif ($mode eq "~")
- {
- @Text = split ('\n', $text) ;
- if ($fontsize =~ /^(?:XS|S|M|L|XL)$/i)
- {
- if ($fontsize =~ /XS/i) { $dy = 0.09 ; }
- elsif ($fontsize =~ /S/i) { $dy = 0.11 ; }
- elsif ($fontsize =~ /M/i) { $dy = 0.135 ; }
- elsif ($fontsize =~ /XL/i) { $dy = 0.21 ; }
- else { $dy = 0.16 ; }
- }
- else
- {
- $dy = sprintf ("%.2f", (($fontsize * 1.2) / 100)) ;
- if ($dy < $fontsize/100 + 0.02)
- { $dy = $fontsize/100 + 0.02 ; }
- }
- }
- else
- { push @Text, $text ; }
- foreach $text (@Text)
- {
- if ($text !~ /^[\n\s]*$/)
- {
- $link2 = "" ;
- $hint2 = "" ;
- ($text, $link2, $hint2) = &ProcessWikiLink ($text, $link2, $hint2) ;
- if ($link2 eq "")
- {
- $link2 = $link ;
- if (($link ne "") && ($text !~ /\[\[.*\]\]/))
- { $text = "[[" . $text . "]]" ;}
- }
- if ($hint2 eq "")
- { $hint2 = $hint ; }
- &WriteProcAnnotate ($bar, $shiftx, $posx, $posy, $text, $textcolor, $fontsize, $align, $link2, $hint2) ;
- }
- if ($#Tabs >= 0)
- {
- $tab = shift (@Tabs) ;
- ($dx,$align) = split ("\-", $tab) ;
- $posx = $posx0 + &Normalize ($dx) ;
- }
- if ($posy =~ /\+/)
- { ($posy1, $posy2) = split ('\+', $posy) ; }
- elsif ($posy =~ /.+\-/)
- {
- if ($posy =~ /^\-/)
- {
- ($sign, $posy1, $posy2) = split ('\-', $posy) ; $posy2 = -$posy2 ;
- $posy1 = "-" . $posy1 ;
- }
- else
- { ($posy1, $posy2) = split ('\-', $posy) ; $posy2 = -$posy2 ; }
- }
- else
- { $posy1 = $posy ; $posy2 = 0 ; }
- $posy2 -= $dy ;
- if ($posy2 == 0)
- { $posy = $posy1 ; }
- elsif ($posy2 < 0)
- { $posy = $posy1 . "$posy2" ; }
- else
- { $posy = $posy1 . "+" . $posy2 ; }
- }
- }
- sub WriteProcDrawCommandsOld
- {
- my $posx = shift ;
- my $posy = shift ;
- my $text = shift ;
- my $textcolor = shift ;
- my $fontsize = shift ;
- my $link = shift ;
- my $hint = shift ;
- $posx0 = $posx ;
- my @Text = split ('\^', $text) ;
- my $align = "text" ;
- foreach $text (@Text)
- {
- push @TextData, " mov $posx $posy\n" ;
- push @TextData, " textsize $fontsize\n" ;
- push @TextData, " color $textcolor\n" ;
- push @TextData, " $align $text\n" ;
- $tab = shift (@Tabs) ;
- ($dx,$align) = split ("\-", $tab) ;
- $posx = $posx0 + &Normalize ($dx) ;
- if ($align =~ /left/i) { $align = "text" ; }
- elsif ($align =~ /right/i) { $align = "rightjust" ; }
- else { $align = "centext" ; }
- }
- }
- sub WritePlotFile
- {
- &WriteTexts ;
- $script = "" ;
- my ($color) ;
- if (@Axis {"time"} eq "x")
- { $AxisBars = "y" ; }
- else
- { $AxisBars = "x" ; }
- # if ((@Axis {"time"} eq "y") && ($#Bars > 0))
- # {
- # undef @BarsTmp ;
- # while ($#Bars >= 0)
- # { push @BarsTmp, pop @Bars ; }
- # @Bars = @BarsTmp ;
- # }
- if ($tmpdir ne "")
- { $file_script = $tmpdir.$pathseparator."EasyTimeline.txt.$$" ; }
- else
- { $file_script = "EasyTimeline.txt" ; }
- print "Ploticus input file = ".$file_script."\n";
- # $fmt = "gif" ;
- open "FILE_OUT", ">", $file_script ;
- #proc settings
- # $script .= "#proc settings\n" ;
- # $script .= " xml_encoding: utf-8\n" ;
- # $script .= "\n" ;
- # proc page
- $script .= "#proc page\n" ;
- $script .= " dopagebox: no\n" ;
- $script .= " pagesize: ". @Image {"width"} . " ". @Image {"height"} . "\n" ;
- if (defined (@BackgroundColors {"canvas"}))
- { $script .= " backgroundcolor: " . @BackgroundColors {"canvas"} . "\n" ; }
- $script .= "\n" ;
- $barcnt = $#Bars + 1 ;
- # if ($AlignBars eq "justify") && ($#Bars > 0)
- #
- # given P = plotwidth in pixels
- # given B = half bar width in pixels
- # get U = plotwidth in units
- # get x = half bar width in units
- #
- # first bar plotted at unit 1
- # last bar plotted at unit c
- # let C = c - 1 (units between centers of lowest and highest bar) -> x = (U-C) / 2
- #
- # Justify: calculate range for axis in units:
- # axis starts at 1-x and ends at c+x =
- # x/B = U/P -> x = BU/P (1)
- # U = c+x - (1-x) = (c-1) + 2x -> x = (U-(c-1))/2 (2)
- #
- # (1) & (2) -> BU/P = (U-(c-1))/2
- # -> 2BU/P = U-(c-1)
- # -> 2BU/P = U - C
- # -> 2BU = PU - PC
- # -> U (2B-P) = -PC
- # -> U = -PC/(2B-P)
- # P = @PlotArea {$extent}
- # C = c - 1 = $#Bars
- # 2B = $MaxBarWidth
- if (! defined ($AlignBars))
- {
- &Info2 ("AlignBars not defined. Alignment 'early' assumed.") ;
- $AlignBars = "early" ;
- }
- if (@Axis {"time"} eq "x")
- { $extent = "height" ; }
- else
- { $extent = "width" ; }
- if ($MaxBarWidth > @PlotArea {$extent})
- { &Error2 ("Maximum bar width exceeds plotarea " . $extent . ".") ; return ; }
- if ($MaxBarWidth == @PlotArea {$extent})
- { @PlotArea {$extent} += 0.01 ; }
- if ($MaxBarWidth == @PlotArea {$extent})
- {
- $till = 1 ;
- $from = 1 ;
- }
- else
- {
- if ($AlignBars eq "justify")
- {
- if ($#Bars > 0)
- {
- $U = - (@PlotArea {$extent} * $#Bars) / ($MaxBarWidth - @PlotArea {$extent}) ;
- $x = ($U - $#Bars) / 2 ;
- $from = 1 - $x ;
- $till = 1 + $#Bars + $x ;
- }
- else # one bar-> "justify" is misnomer here, treat as "center"
- {
- # $x = ($MaxBarWidth /2) / @PlotArea {$extent} ;
- # $from = 0.5 - $x ;
- # $till = $from + 1 ;
- $from = 0.5 ;
- $till = 1.5 ;
- }
- }
- elsif ($AlignBars eq "early")
- {
- $U = $#Bars + 1 ;
- if ($U == 0)
- { $U = 1 ; }
- $x = (($MaxBarWidth /2) * $U) / @PlotArea {$extent} ;
- $from = 1 - $x ;
- $till = $from + $U ;
- }
- elsif ($AlignBars eq "late")
- {
- $U = $#Bars + 1 ;
- $x = (($MaxBarWidth /2) * $U) / @PlotArea {$extent} ;
- $till = $U + $x ;
- $from = $till - $U ;
- }
- }
- # if ($#Bars == 0)
- # {
- # $from = 1 - $MaxBarWidth ;
- # $till = 1 + $MaxBarWidth ;
- # }
- if ($from eq $till)
- { $till = $from + 1 ; }
- #proc areadef
- $script .= "#proc areadef\n" ;
- $script .= " rectangle: " . @PlotArea {"left"} . " " . @PlotArea {"bottom"} . " " .
- sprintf ("%.2f", @PlotArea {"left"} + @PlotArea {"width"}). " " . sprintf ("%.2f", @PlotArea {"bottom"} + @PlotArea {"height"}) . "\n" ;
- if (($DateFormat eq "yyyy") || ($DateFormat eq "x.y"))
- { $script .= " " . @Axis {"time"} . "scaletype: linear\n" ; } # date yyyy
- else
- { $script .= " " . @Axis {"time"} . "scaletype: date $DateFormat\n" ; }
- if (@Axis {"order"} !~ /reverse/i)
- { $script .= " " . @Axis {"time"} . "range: " . @Period{"from"} . " " . @Period{"till"} . "\n" ; }
- else
- { $script .= " " . @Axis {"time"} . "range: " . (-@Period{"till"}) . " " . (-@Period{"from"}) . "\n" ; }
- $script .= " " . $AxisBars . "scaletype: linear\n" ;
- $script .= " " . $AxisBars . "range: " . sprintf ("%.3f", $from-0.001) . " " . sprintf ("%.3f", $till) . "\n" ;
- $script .= " #saveas: A\n" ;
- $script .= "\n" ;
- #proc rect (test)
- # $script .= "#proc rect\n" ;
- # $script .= " rectangle 1.0 1.0 1.4 1.4\n" ;
- # $script .= " color gray(0.95)\n" ;
- # $script .= " clickmaplabel: Vladimir Ilyich Lenin\n" ;
- # $script .= " clickmapurl: http://www.wikipedia.org/wiki/Vladimir_Lenin\n" ;
- #proc legendentry
- foreach $color (sort keys %Colors)
- {
- $script .= "#proc legendentry\n" ;
- $script .= " sampletype: color\n" ;
- if ((defined (@ColorLabels {$color})) && (@ColorLabels {$color} ne ""))
- { $script .= " label: " . @ColorLabels {$color} . "\n" ; }
- $script .= " details: " . @Colors {$color} . "\n" ;
- $script .= " tag: $color\n" ;
- $script .= "\n" ;
- }
- if (defined (@BackgroundColors {"bars"}))
- {
- #proc getdata / #proc bars
- $script .= "#proc getdata\n" ;
- $script .= " delim: comma\n" ;
- $script .= " data:\n" ;
- $maxwidth = 0 ;
- foreach $entry (@PlotBars)
- {
- ($width) = split (",", $entry) ;
- if ($width > $maxwidth)
- { $maxwidth = $width ; }
- }
- for ($b = 0 ; $b <= $#Bars ; $b++)
- { $script .= ($b+1) . "," . @Period {"from"} . "," . @Period {"till"} . ",".
- @BackgroundColors {"bars"} . "\n" ; }
- $script .= "\n" ;
- #proc bars
- $script .= "#proc bars\n" ;
- $script .= " axis: " . @Axis {"time"} . "\n" ;
- $script .= " barwidth: $maxwidth\n" ;
- $script .= " outline: no\n" ;
- if (@Axis {"time"} eq "x")
- { $script .= " horizontalbars: yes\n" ; }
- $script .= " locfield: 1\n" ;
- $script .= " segmentfields: 2 3\n" ;
- $script .= " colorfield: 4\n" ;
- # $script .= " clickmaplabel: Vladimir Ilyich Lenin\n" ;
- # $script .= " clickmapurl: http://www.wikipedia.org/wiki/Vladimir_Lenin\n" ;
- $script .= "\n" ;
- }
- #proc axis
- if (defined (@Scales {"Minor grid"}))
- { &PlotScale ("Minor", $true) ; }
- if (defined (@Scales {"Major grid"}))
- { &PlotScale ("Major", $true) ; }
- &PlotLines ("back") ;
- @PlotBarsNow = @PlotBars ;
- &PlotBars ;
- $script .= "\n([inc3])\n\n" ; # will be replace by rects
- %x = %BarWidths ;
- foreach $entry (@PlotLines)
- {
- ($bar) = split (",", $entry) ;
- $bar =~ s/\#.*// ;
- $width = @BarWidths {$bar} ;
- $entry = sprintf ("%6.3f",$width) . "," . $entry ;
- }
- @PlotBarsNow = @PlotLines ;
- &PlotBars ;
- #proc axis
- if ($#Bars > 0)
- {
- $scriptPng2 = "#proc " . $AxisBars . "axis\n" ;
- $scriptSvg2 = "#proc " . $AxisBars . "axis\n" ;
- if ($AxisBars eq "x")
- {
- $scriptPng2 .= " stubdetails: adjust=0,0.09\n" ;
- $scriptSvg2 .= " stubdetails: adjust=0,0.09\n" ;
- }
- else
- {
- $scriptPng2 .= " stubdetails: adjust=0.09,0\n" ;
- $scriptSvg2 .= " stubdetails: adjust=0.09,0\n" ;
- }
- $scriptPng2 .= " tics: none\n" ;
- $scriptSvg2 .= " tics: none\n" ;
- $scriptPng2 .= " stubrange: 1\n" ;
- $scriptSvg2 .= " stubrange: 1\n" ;
- if ($AxisBars eq "y")
- {
- $scriptPng2 .= " stubslide: -" . sprintf ("%.2f", $MaxBarWidth / 2) . "\n" ;
- $scriptSvg2 .= " stubslide: -" . sprintf ("%.2f", $MaxBarWidth / 2) . "\n" ;
- }
- $scriptPng2 .= " stubs: text\n" ;
- $scriptSvg2 .= " stubs: text\n" ;
- my ($text, $link, $hint) ;
- undef (@Bars2) ;
- foreach $bar (@Bars)
- {
- if ($AxisBars eq "y")
- { push @Bars2, $bar ; }
- else
- { unshift @Bars2, $bar ; }
- }
- foreach $bar (@Bars2)
- {
- $hint = "" ;
- $text = @BarLegend {lc ($bar)} ;
- if ($text =~ /^\s*$/)
- { $text = "\\" ; }
- $link = @BarLink {lc ($bar)} ;
- if (! defined ($link))
- {
- if ($text =~ /\[.*\]/)
- { ($text, $link, $hint) = &ProcessWikiLink ($text, $link, $hint) ; }
- }
- $text =~ s/\[+([^\]]*)\]+/$1/ ;
- $scriptPng2 .= "$text\n" ;
- if (defined ($link))
- {
- push @linksSVG, $link ;
- my $lcnt = $#linksSVG ;
- $scriptSvg2 .= "[" . $lcnt . "[" . $text . "]" . $lcnt . "]\n" ;
- }
- else
- { $scriptSvg2 .= "$text\n" ; }
- }
- $scriptPng2 .= "\n" ;
- $scriptSvg2 .= "\n" ;
- $scriptPng2 .= "#proc " . $AxisBars . "axis\n" ;
- if ($AxisBars eq "x")
- { $scriptPng2 .= " stubdetails: adjust=0,0.09 color=$LinkColor\n" ; }
- else
- { $scriptPng2 .= " stubdetails: adjust=0.09,0 color=$LinkColor\n" ; }
- $scriptPng2 .= " tics: none\n" ;
- $scriptPng2 .= " stubrange: 1\n" ;
- if ($AxisBars eq "y")
- { $scriptPng2 .= " stubslide: -" . sprintf ("%.2f", $MaxBarWidth / 2) . "\n" ; }
- $scriptPng2 .= " stubs: text\n" ;
- $barcnt = $#Bars + 1 ;
- foreach $bar (@Bars2)
- {
- $hint = "" ;
- $text = @BarLegend {lc ($bar)} ;
- if ($text =~ /^\s*$/)
- { $text = "\\" ; }
- $link = @BarLink {lc ($bar)} ;
- if (! defined ($link))
- {
- if ($text =~ /\[.*\]/)
- { ($text, $link, $hint) = &ProcessWikiLink ($text, $link, $hint) ; }
- }
- if ((! defined ($link)) || ($link eq ""))
- { $text = "\\" ; }
- else
- {
- $scriptPng3 .= "#proc rect\n" ;
- $scriptPng3 .= " rectangle: 0 $barcnt(s)+0.05 " . @PlotArea {"left"} . " $barcnt(s)-0.05\n" ;
- $scriptPng3 .= " color: " . @BackgroundColors {"canvas"} . "\n" ;
- $scriptPng3 .= " clickmapurl: " . $link . "\n" ;
- if ((defined ($hint)) && ($hint ne ""))
- { $scriptPng3 .= " clickmaplabel: " . $hint . "\n" ; }
- $text =~ s/\[+([^\]]*)\]+/$1/ ;
- }
- $scriptPng2 .= "$text\n" ;
- $barcnt-- ;
- }
- $scriptPng2 .= "\n" ;
- }
- &PlotLines ("front") ;
- $script .= "\n([inc1])\n\n" ; # will be replaced by annotations
- $script .= "\n([inc2])\n\n" ;
- if ($#PlotTextsPng >= 0)
- {
- foreach $command (@PlotTextsPng)
- {
- if ($command =~ /^\s*location/)
- { $command =~ s/(.*)\[(.*)\](.*)/$1 . ($#Bars - $2 + 2) . $3/xe ; }
- $scriptPng1 .= $command ;
- }
- $scriptPng1 .= "\n" ;
- }
- if ($#PlotTextsSvg >= 0)
- {
- foreach $command (@PlotTextsSvg)
- {
- if ($command =~ /^\s*location/)
- { $command =~ s/(.*)\[(.*)\](.*)/$1 . ($#Bars - $2 + 2) . $3/xe ; }
- $scriptSvg1 .= $command ;
- }
- $scriptSvg1 .= "\n" ;
- }
- # $script .= "#proc symbol\n" ;
- # $script .= " location: 01/01/1943(s) Korea \n" ;
- # $script .= " symbol: style=fill shape=downtriangle fillcolor=white radius=0.04\n" ;
- # $script .= "\n" ;
- #proc axis
- # repeat without grid to get axis on top of bar
- # needed because axis may overlap bar slightly
- if (defined (@Scales {"Minor"}))
- { &PlotScale ("Minor", $false) ; }
- if (defined (@Scales {"Major"}))
- { &PlotScale ("Major", $false) ; }
- #proc drawcommands
- if ($#TextData >= 0)
- {
- $script .= "#proc drawcommands\n" ;
- $script .= " commands:\n" ;
- foreach $entry (@TextData)
- { $script .= $entry ; }
- $script .= "\n" ;
- }
- #proc legend
- if (defined (@Legend {"orientation"}))
- {
- if (($#LegendData < 0) && ($Preset eq ""))
- { &Error2 ("Command 'Legend' found, but no entries for the legend were specified.\n" .
- " Please remove or disable command (disable = put \# before the command)\n" .
- " or specify entries for the legend with command 'Colors', attribute 'legend'\n") ;
- return ; }
- $perColumn = 999 ;
- if (@Legend {"orientation"} =~ /ver/i)
- {
- if (@Legend {"columns"} > 1)
- {
- $perColumn = 0 ;
- while ((@Legend {"columns"} * $perColumn) < $#LegendData + 1)
- { $perColumn ++ ; }
- }
- }
- for ($l = 1 ; $l <= @Legend {"columns"} ; $l++)
- {
- $script .= "#proc legend\n" ;
- $script .= " noclear: yes\n" ;
- if (@Legend {"orientation"} =~ /ver/i)
- { $script .= " format: multiline\n" ; }
- else
- { $script .= " format: singleline\n" ; }
- $script .= " seglen: 0.2\n" ;
- $script .= " swatchsize: 0.12\n" ;
- $script .= " textdetails: size=S\n" ;
- $script .= " location: " . (@Legend{"left"}+0.2) . " " . @Legend{"top"} . "\n" ;
- $script .= " specifyorder:\n" ;
- for ($l2 = 1 ; $l2 <= $perColumn ; $l2++)
- {
- $category = shift (@LegendData) ;
- if (defined ($category))
- { $script .= "$category\n" ; }
- }
- $script .= "\n" ;
- @Legend {"left"} += @Legend {"columnwidth"} ;
- }
- }
- $script .= "#endproc\n" ;
- print "\nGenerating output:\n" ;
- if ( $plcommand ne "" )
- { $pl = $plcommand; }
- else
- {
- $pl = "pl.exe" ;
- if ($env eq "Linux")
- { $pl = "pl" ; }
- }
- print "Using ploticus command \"".$pl."\" (".$plcommand.")\n";
- $script_save = $script ;
- $script =~ s/\(\[inc1\]\)/$scriptSvg1/ ;
- $script =~ s/\(\[inc2\]\)/$scriptSvg2/ ;
- $script =~ s/\(\[inc3\]\)// ;
- $script =~ s/textsize XS/textsize 7/gi ;
- $script =~ s/textsize S/textsize 8.9/gi ;
- $script =~ s/textsize M/textsize 10.5/gi ;
- $script =~ s/textsize L/textsize 13/gi ;
- $script =~ s/textsize XL/textsize 17/gi ;
- $script =~ s/size=XS/size=7/gi ;
- $script =~ s/size=S/size=8.9/gi ;
- $script =~ s/size=M/size=10.5/gi ;
- $script =~ s/size=L/size=13/gi ;
- $script =~ s/size=XL/size=17/gi ;
- $script =~ s/(\n location:.*)/&ShiftOnePixelForSVG($1)/ge ;
- open "FILE_OUT", ">", $file_script ;
- print FILE_OUT &DecodeInput($script) ;
- close "FILE_OUT" ;
- $map = ($MapSVG) ? "-map" : "";
- print "Running Ploticus to generate svg file\n" ;
- # my $cmd = "$pl $map -" . "svg" . " -o $file_vector $file_script -tightcrop -font \"Times\"" ;
- # my $cmd = "$pl $map -" . "svg" . " -o $file_vector $file_script -tightcrop" ;
- my $cmd = EscapeShellArg($pl) . " $map -" . "svg" . " -o " .
- EscapeShellArg($file_vector) . " " . EscapeShellArg($file_script) . " -tightcrop" ;
- print "$cmd\n";
- system ($cmd) ;
- $script = $script_save ;
- $script =~ s/dopagebox: no/dopagebox: yes/ ;
- $script =~ s/\(\[inc1\]\)/$scriptPng1/ ;
- $script =~ s/\(\[inc2\]\)/$scriptPng2/ ;
- $script =~ s/\(\[inc3\]\)/$scriptPng3/ ;
- $script =~ s/textsize XS/textsize 6/gi ;
- $script =~ s/textsize S/textsize 8/gi ;
- $script =~ s/textsize M/textsize 10/gi ;
- $script =~ s/textsize L/textsize 14/gi ;
- $script =~ s/textsize XL/textsize 18/gi ;
- $script =~ s/size=XS/size=6/gi ;
- $script =~ s/size=S/size=8/gi ;
- $script =~ s/size=M/size=10/gi ;
- $script =~ s/size=L/size=14/gi ;
- $script =~ s/size=XL/size=18/gi ;
- open "FILE_OUT", ">", $file_script ;
- print FILE_OUT &DecodeInput($script) ;
- close "FILE_OUT" ;
- $map = ($MapPNG && $linkmap) ? "-csmap" : "";
- if ($linkmap && $showmap)
- { $map .= " -csmapdemo" ; }
- # $crop = "-crop 0,0," + @ImageSize {"width"} . "," . @ImageSize {"height"} ;
- print "Running Ploticus to generate bitmap\n" ;
- # $cmd = "$pl $map -" . $fmt . " -o $file_bitmap $file_script -tightcrop" ; # -v $file_bitmap" ;
- # $cmd = "$pl $map -" . $fmt . " -o $file_bitmap $file_script -tightcrop -diagfile $file_pl_info -errfile $file_pl_err" ;
- $cmd = EscapeShellArg($pl) . " $map -" . $fmt . " -o " .
- EscapeShellArg($file_bitmap) . " " . EscapeShellArg($file_script) . " -tightcrop -font FreeSans.ttf" .
- " -mapfile " . EscapeShellArg($file_htmlmap) ;
- print "$cmd\n";
- system ($cmd) ;
- if ((-e $file_bitmap) && (-s $file_bitmap > 500 * 1024))
- {
- &Error2 ("Output image size exceeds 500 K. Image deleted.\n" .
- "Run with option -b (bypass checks) when this is correct.\n") ;
- unlink $file_bitmap ;
- } ;
- # not for Wikipedia, only for offline use:
- if ((-e $file_bitmap) && ($fmt eq "gif"))
- {
- print "Running nconvert to convert gif image to png format\n\n" ;
- print "---------------------------------------------------------------------------\n" ;
- $cmd = "nconvert.exe -out png " . EscapeShellArg($file_bitmap) ;
- system ($cmd) ;
- print "---------------------------------------------------------------------------\n" ;
- if (! (-e $file_png))
- { print "PNG file not created (is nconvert.exe missing?)\n\n" ; }
- }
- if (-e $file_htmlmap) # correct click coordinates of right aligned texts (Ploticus bug)
- {
- open "FILE_IN", "<", $file_htmlmap ;
- @map = <FILE_IN> ;
- close "FILE_IN" ;
- foreach $line (@map)
- {
- chomp $line ;
- if ($line =~ /\&\&/)
- {
- $coords = $line ;
- $shift = $line ;
- $coords =~ s/^.*coords\=\"([^\"]*)\".*$/$1/ ;
- $shift =~ s/^.*\&\&([^\"]*)\".*$/$1/ ;
- $line =~ s/\&\&[^\"]*// ;
- (@updcoords) = split (",", $coords) ;
- $maplength = @updcoords [2] - @updcoords [0] ;
- @updcoords [0] = @updcoords [0] - 2 * ($maplength-25) ;
- @updcoords [2] = @updcoords [0] + $maplength ;
- $coordsnew = join (",", @updcoords) ;
- $line =~ s/$coords/$coordsnew/ ;
- push @map2, $line . "\n" ;
- }
- else
- { push @map2, $line . "\n" ; }
- }
- open "FILE_OUT", ">", $file_htmlmap ;
- print FILE_OUT @map2 ;
- close "FILE_OUT" ;
- }
- if (-e $file_vector)
- {
- open "FILE_IN", "<", $file_vector ;
- @svg = <FILE_IN> ;
- close "FILE_IN" ;
- foreach $line (@svg)
- {
- $line =~ s/\{\{(\d+)\}\}x+/@textsSVG[$1]/gxe ;
- $line =~ s/\[(\d+)\[ (.*?) \]\d+\]/'<a style="fill:blue;" xlink:href="' . @linksSVG[$1] . '">' . $2 . '<\/a>'/gxe ;
- }
- open "FILE_OUT", ">", $file_vector ;
- print FILE_OUT @svg ;
- close "FILE_OUT" ;
- }
- # not for Wikipedia, for offline use:
- if ($makehtml)
- {
- $map = "" ;
- if ($linkmap)
- {
- open "FILE_IN", "<", $file_htmlmap ;
- while ($line = <FILE_IN>)
- { $map .= $line ; }
- close "FILE_IN" ;
- }
- print "Generating html test file\n" ;
- $width = sprintf ("%.0f", @Image {"width"} * 100) ;
- $height = sprintf ("%.0f", @Image {"height"} * 100) ;
- $html = <<__HTML__ ;
- <html>
- <head>
- <title>%FILENAME% - EasyTimeline test file</title>\n
- </head>
- <body>
- <h1><font color="green">EasyTimeline</font> - Test Page</h1>
- <b>Fixed size version (PNG): file $file_png</b><p>
- <map name="map1">
- $map</map>
- <!--
- If you want a border simplest way is set <img .. border='1'>
- Here tables are used to draw similar borders around both images (border='1' seems not to work for embed tag)
- -->
- <table border='1' cellpadding='0' cellspacing='0'><tr><td>
- <img src=$file_png usemap='#map1' border='0'>
- </td></tr></table>
- <hr>
- <b>Scalable version (SVG): file $file_vector</b><p>
- <table border='1' cellpadding='0' cellspacing='0'><tr><td>
- <noembed>Your browser does not support embedded objects</noembed>
- <embed src='$file_vector' name='SVGEmbed' border='1'
- width='$width' height='$height' type='image/svg-xml' pluginspage='http://www.adobe.com/svg/viewer/install/'>
- </td></tr></table>
- <p>As you can see the scalable version renders fonts smoother better than the bitmap version.
- <br>Any SVG picture can also be rescaled or zoomed into, without annoying artefacts.
- <p>Windows users:<br>
- <small> Right mouse click on picture for zoom options or</small>
- <p><small> Ctrl+click for zoom in</small>
- <br><small> Ctrl+Shift+click for zoom out</small>
- <br><small> Alt+drag with mouse to move focus</small>
- </body>
- </html>
- __HTML__
- $html =~ s/\%FILENAME\%/$file_name/ ;
- open "FILE_OUT", ">", $file_html ;
- print FILE_OUT $html ;
- close "FILE_OUT" ;
- }
- # my $cmd = "\"c:\\\\Program Files\\\\XnView\\\\xnview.exe\"" ;
- # system ("\"c:\\\\Program Files\\\\XnView\\\\xnview.exe\"", "d:\\\\Wikipedia\\Perl\\\\Wo2\\\\Test.png") ;
- }
- sub WriteTexts
- {
- my ($line, $xpos, $ypos) ;
- foreach $line (@PlotText)
- {
- my ($at, $bar, $text, $textcolor, $fontsize, $align, $shift, $link, $hint) = split (",", $line) ;
- $text =~ s/\#\%\$/\,/g ;
- $link =~ s/\#\%\$/\,/g ;
- $hint =~ s/\#\%\$/\,/g ;
- $shift =~ s/\#\%\$/\,/g ;
- $textcolor =~ s/\#\%\$/\,/g ;
- my $barcnt = 0 ;
- for ($b = 0 ; $b <= $#Bars ; $b++)
- {
- if (lc(@Bars [$b]) eq lc($bar))
- { $barcnt = ($b + 1) ; last ; }
- }
- if (@Axis {"time"} eq "x")
- { $xpos = "$at(s)" ; $ypos = "[$barcnt](s)" ; }
- else
- { $ypos = "$at(s)" ; $xpos = "[$barcnt](s)" ; }
- if ($shift ne "")
- {
- my ($shiftx, $shifty) = split (",", $shift) ;
- if ($shiftx > 0)
- { $xpos .= "+$shiftx" ; }
- if ($shiftx < 0)
- { $xpos .= "$shiftx" ; }
- if ($shifty > 0)
- { $ypos .= "+$shifty" ; }
- if ($shifty < 0)
- { $ypos .= "$shifty" ; }
- }
- &WriteText ("~", $bar, $shiftx, $xpos, $ypos, $text, $textcolor, $fontsize, $align, $link, $hint) ;
- }
- }
- sub PlotBars
- {
- #proc getdata / #proc bars
- while ($#PlotBarsNow >= 0)
- {
- undef @PlotBarsLater ;
- $maxwidth = 0 ;
- foreach $entry (@PlotBarsNow)
- {
- ($width) = split (",", $entry) ;
- if ($width > $maxwidth)
- { $maxwidth = $width ; }
- }
- $script .= "#proc getdata\n" ;
- $script .= " delim: comma\n" ;
- $script .= " data:\n" ;
- foreach $entry (@PlotBarsNow)
- {
- my ($width, $bar, $from, $till, $color, $link, $hint) = split (",", $entry) ;
- if ($width < $maxwidth)
- {
- push @PlotBarsLater, $entry ;
- next ;
- }
- for ($b = 0 ; $b <= $#Bars ; $b++)
- {
- if (lc(@Bars [$b]) eq lc($bar))
- { $bar = ($#Bars - ($b - 1)) ; last ; }
- }
- if (@Axis {"order"} !~ /reverse/i)
- { $entry = "$bar,$from,$till,$color,$link,$hint,\n" ; }
- else
- { $entry = "$bar," . (-$till) . "," . (-$from) . ",$color,$link,$hint,\n" ; }
- $script .= "$entry" ;
- }
- $script .= "\n" ;
- #proc bars
- $script .= "#proc bars\n" ;
- $script .= " axis: " . @Axis {"time"} . "\n" ;
- $script .= " barwidth: $maxwidth\n" ;
- $script .= " outline: no\n" ;
- # $script .= " thinbarline: width=5\n" ;
- if (@Axis {"time"} eq "x")
- { $script .= " horizontalbars: yes\n" ; }
- $script .= " locfield: 1\n" ;
- $script .= " segmentfields: 2 3\n" ;
- $script .= " colorfield: 4\n" ;
- # $script .= " outline: width=1\n" ;
- # $script .= " barwidthfield: 5\n" ;
- # if (@fields [4] ne "")
- # { $script .= " clickmapurl: " . &LinkToUrl ($text) . "\n" ; }
- # if (@fields [5] ne "")
- # { $script .= " clickmaplabel: $text\n" ; }
- $script .= " clickmapurl: \@\@5\n" ;
- $script .= " clickmaplabel: \@\@6\n" ;
- $script .= "\n" ;
- @PlotBarsNow = @PlotBarsLater ;
- }
- }
- sub PlotScale
- {
- my $scale = shift ;
- my $grid = shift ;
- my ($color, $from, $till, $start) ;
- %x = %Period ;
- # if (($DateFormat =~ /\//) && ($grid))
- # { return ; }
- # if (($DateFormat =~ /\//)
- # {
- # }
- # if (! $grid) # redefine area, scale linear for time axis, showl whole years always, Ploticus bug
- # {
- # $from = @Period {"from"} ;
- # $till = @Period {"till"} ;
- $from = &DateToFloat (@Period {"from"}) ;
- $till = &DateToFloat (@Period {"till"}) ;
- # $from =~ s/.*\///g ; # delete dd mm if present
- # $till =~ s/.*\///g ;
- #proc areadef
- $script .= "#proc areadef\n" ;
- $script .= " #clone: A\n" ;
- $script .= " " . @Axis {"time"} . "scaletype: linear\n" ; # date yyyy
- if (@Axis {"order"} !~ /reverse/i)
- { $script .= " " . @Axis {"time"} . "range: $from $till\n" ; }
- else
- { $script .= " " . @Axis {"time"} . "range: " . (-$till) . " " . (-$from) . "\n" ; }
- $script .= "\n" ;
- # }
- $script .= "#proc " . @Axis {"time"} . "axis\n" ;
- if (($scale eq "Major") && (! $grid))
- {
- # $script .= " stubs: incremental " . @Scales {"Major inc"} . " " . @Scales {"Major unit"} . "\n" ;
- # if ($DateFormat =~ /\//)
- # { $script .= " stubformat: " . @Axis {"format"} . "\n" ; }
- # temp always show whole years (Ploticus autorange bug)
- if (@Scales {"Major stubs"} eq "") # ($DateFormat !~ /\//)
- { $script .= " stubs: incremental " . @Scales {"Major inc"} . "\n" ; }
- else
- { $script .= " stubs: list " . @Scales {"Major stubs"} . "\n" ; }
- }
- else
- { $script .= " stubs: none\n" ; }
- if ($DateFormat !~ /\//)
- # { $script .= " ticincrement: " . @Scales {"$scale inc"} . " " . @Scales {"$scale unit"} . "\n" ; }
- { $script .= " ticincrement: " . @Scales {"$scale inc"} . "\n" ; }
- else
- {
- my $unit = 1 ;
- if (@Scales {"$scale unit"} =~ /month/i)
- { $unit = 1/12 ; }
- if (@Scales {"$scale unit"} =~ /day/i)
- { $unit = 1/365 ; }
- $script .= " ticincrement: " . @Scales {"$scale inc"} . " $unit\n" ;
- }
- if (defined (@Scales {"$scale start"}))
- {
- $start = @Scales {"$scale start"} ;
- # $start =~ s/.*\///g ; # delete dd mm if present
- $start = &DateToFloat ($start) ;
- if (@Axis {"order"} =~ /reverse/i)
- {
- $loop = 0 ;
- $start = -$start ;
- while ($start - @Scales {"$scale inc"} >= - @Period {"till"})
- {
- $start -= @Scales {"$scale inc"} ;
- if (++$loop > 1000) { last ; } # precaution
- }
- }
- $script .= " stubrange: $start\n" ;
- }
- if ($scale eq "Major")
- {
- $script .= " ticlen: 0.05\n" ;
- if (@Axis {"time"} eq "y")
- { $script .= " stubdetails: adjust=0.05,0\n" ; }
- if (@Axis {"order"} =~ /reverse/i)
- { $script .= " signreverse: yes\n" ; }
- }
- else
- { $script .= " ticlen: 0.02\n" ; }
- # $script .= " location: 4\n" ; test
- $color .= @Scales {"$scale grid"} ;
- if (defined (@Colors {$color}))
- { $color = @Colors {$color} ; }
- if ($grid)
- { $script .= " grid: color=$color\n" ; }
- $script .= "\n" ;
- if ($grid) # restore areadef
- {
- #proc areadef
- $script .= "#proc areadef\n" ;
- $script .= " #clone: A\n" ;
- $script .= "\n" ;
- }
- }
- sub PlotLines
- {
- my $layer = shift ;
- if ($#DrawLines < 0)
- { return ; }
- undef (@DrawLinesNow) ;
- foreach $line (@DrawLines)
- {
- if ($line =~ /\|$layer\n/)
- { push @DrawLinesNow, $line ; }
- }
- if ($#DrawLinesNow < 0)
- { return ; }
- foreach $entry (@DrawLinesNow)
- {
- chomp ($entry) ;
- $script .= "#proc line\n" ;
- # $script .= " notation: scaled\n" ;
- if ($entry =~ /^[12]/)
- { ($mode, $at, $from, $till, $color, $width) = split ('\|', $entry) ; }
- else
- { ($mode, $points, $color, $width) = split ('\|', $entry) ; }
- $script .= " linedetails: width=$width color=$color style=0\n" ;
- if ($mode == 1) # draw perpendicular to time axis
- {
- if (@Axis {"order"} =~ /reverse/i)
- { $at = -$at ; }
- if (@Axis {"time"} eq "x")
- {
- if ($from eq "")
- { $from = @PlotArea {"bottom"} }
- if ($till eq "")
- { $till = @PlotArea {"bottom"} + @PlotArea {"height"} }
- $from += ($width/200) ; # compensate for overstrechting of thick lines
- $till -= ($width/200) ;
- if ($from > @Image {"height"})
- { $from = @Image {"height"} ; }
- if ($till > @Image {"height"})
- { $till = @Image {"height"} ; }
- $script .= " points: $at(s) $from $at(s) $till\n" ;
- }
- else
- {
- if ($from eq "")
- { $from = @PlotArea {"left"} }
- if ($till eq "")
- { $till = @PlotArea {"left"} + @PlotArea {"width"} }
- $from += ($width/200) ;
- $till -= ($width/200) ;
- if ($from > @Image {"width"})
- { $from = @Image {"width"} ; }
- if ($till > @Image {"width"})
- { $till = @Image {"width"} ; }
- $script .= " points: $from $at(s) $till $at(s)\n" ;
- }
- }
- if ($mode == 2) # draw parralel to time axis
- {
- if (@Axis {"order"} =~ /reverse/i)
- {
- $from = -$from ;
- $till = -$till ;
- }
- $from .= "(s)+" .($width/200) ;
- $till .= "(s)-" .($width/200) ;
- if (@Axis {"time"} eq "x")
- {
- if ($at eq "")
- { $at = @PlotArea {"bottom"} ; }
- if ($at > @Image {"height"})
- { $at = @Image {"height"} ; }
- $script .= " points: $from $at $till $at\n" ;
- }
- else
- {
- if ($at eq "")
- { $at = @PlotArea {"left"} ; }
- if ($at > @Image {"width"})
- { $at = @Image {"width"} ; }
- $script .= " points: $at $from $at $till\n" ;
- }
- }
- if ($mode == 3) # draw free line
- {
- @Points = split (",", $points) ;
- foreach $point (@Points)
- { $point = &Normalize ($point) ; }
- if ((@Points [0] > @Image {"width"}) ||
- (@Points [1] > @Image {"height"}) ||
- (@Points [2] > @Image {"width"}) ||
- (@Points [3] > @Image {"height"}))
- { &Error2 ("Linedata attribute 'points' invalid.\n" .
- sprintf ("(%d,%d)(%d,%d)", @Points[0]*100, @Points[1]*100, @Points[2]*100, @Points[3]*100) . " does not fit in image\n") ;
- return ; }
- $script .= " points: @Points[0] @Points[1] @Points[2] @Points[3]\n" ;
- }
- }
- $script .= "\n" ;
- }
- sub ColorPredefined
- {
- my $color = shift ;
- if ($color =~ /^(?:black|white|tan1|tan2|red|magenta|claret|coral|pink|orange|
- redorange|lightorange|yellow|yellow2|dullyellow|yelloworange|
- brightgreen|green|kelleygreen|teal|drabgreen|yellowgreen|
- limegreen|brightblue|darkblue|blue|oceanblue|skyblue|
- purple|lavender|lightpurple|powderblue|powderblue2)$/xi)
- {
- if (! defined (@Colors {lc ($color)}))
- { &StoreColor ($color, $color, "", $command) ; }
- return ($true) ;
- }
- else
- { return ($false) ; }
- }
- sub ValidAbs
- {
- $value = shift ;
- if ($value =~ /^ \d+ \.? \d* (?:px|in|cm)? $/xi)
- { return ($true) ; }
- else
- { return ($false) ; }
- }
- sub ValidAbsRel
- {
- $value = shift ;
- if ($value =~ /^ \d+ \.? \d* (?:px|in|cm|$hPerc)? $/xi)
- { return ($true) ; }
- else
- { return ($false) ; }
- }
- sub ValidDateFormat
- {
- my $date = shift ;
- my ($day, $month, $year) ;
- # if ($date=~ /^\-?\d+$/) # for now full years are always allowed
- # { return ($true) ; }
- if ($DateFormat eq "yyyy")
- {
- if (! ($date=~ /^\-?\d+$/))
- { return ($false) ; }
- return ($true) ;
- }
- if ($DateFormat eq "x.y")
- {
- if (! ($date=~ /^\-?\d+(?:\.\d+)?$/))
- { return ($false) ; }
- return ($true) ;
- }
- if (! ($date=~ /^\d\d\/\d\d\/\d\d\d\d$/))
- { return ($false) ; }
- if ($DateFormat eq "dd/mm/yyyy")
- {
- $day = substr ($date,0,2) ;
- $month = substr ($date,3,2) ;
- $year = substr ($date,6,4) ;
- }
- else
- {
- $day = substr ($date,3,2) ;
- $month = substr ($date,0,2) ;
- $year = substr ($date,6,4) ;
- }
- if ($month =~ /^(?:01|03|05|07|08|10|12)$/)
- { if ($day > 31) { return ($false) ; }}
- elsif ($month =~ /^(?:04|06|09|11)$/)
- { if ($day > 30) { return ($false) ; }}
- elsif ($month =~ /^02$/)
- {
- if (($year % 4 == 0) && ($year % 100 != 0))
- { if ($day > 29) { return ($false) ; }}
- else
- { if ($day > 28) { return ($false) ; }}
- }
- else { return ($false) ; }
- return ($true) ;
- }
- sub ValidDateRange
- {
- my $date = shift ;
- my ($day, $month, $year,
- $dayf, $monthf, $yearf,
- $dayt, $montht, $yeart) ;
- my $from = @Period {"from"} ;
- my $till = @Period {"till"} ;
- if (($DateFormat eq "yyyy") || ($DateFormat eq "x.y"))
- {
- if (($date < $from) || ($date > $till))
- { return ($false) ; }
- return ($true) ;
- }
- if ($DateFormat eq "dd/mm/yyyy")
- {
- $day = substr ($date,0,2) ;
- $month = substr ($date,3,2) ;
- $year = substr ($date,6,4) ;
- $dayf = substr ($from,0,2) ;
- $monthf = substr ($from,3,2) ;
- $yearf = substr ($from,6,4) ;
- $dayt = substr ($till,0,2) ;
- $montht = substr ($till,3,2) ;
- $yeart = substr ($till,6,4) ;
- }
- if ($DateFormat eq "mm/dd/yyyy")
- {
- $day = substr ($date,3,2) ;
- $month = substr ($date,0,2) ;
- $year = substr ($date,6,4) ;
- $dayf = substr ($from,3,2) ;
- $monthf = substr ($from,0,2) ;
- $yearf = substr ($from,6,4) ;
- $dayt = substr ($till,3,2) ;
- $montht = substr ($till,0,2) ;
- $yeart = substr ($till,6,4) ;
- }
- if (($year < $yearf) ||
- (($year == $yearf) &&
- (($month < $monthf) ||
- (($month == $monthf) && ($day < $dayf))
- )))
- { return ($false) }
- if (($year > $yeart) ||
- (($year == $yeart) &&
- (($month > $montht) ||
- (($month == $montht) && ($day > $dayt))
- )))
- { return ($false) }
- return ($true) ;
- }
- sub DateMedium
- {
- my $from = shift ;
- my $till = shift ;
- if (($DateFormat eq "yyyy") || ($DateFormat eq "x.y"))
- { return (sprintf ("%.3f", ($from + $till) / 2)) ; }
- $from2 = &DaysFrom1800 ($from) ;
- $till2 = &DaysFrom1800 ($till) ;
- my $date = &DateFrom1800 (int (($from2 + $till2) / 2)) ;
- return ($date) ;
- }
- sub DaysFrom1800
- {
- @mmm = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) ;
- my $date = shift ;
- if ($DateFormat eq "dd/mm/yyyy")
- {
- $day = substr ($date,0,2) ;
- $month = substr ($date,3,2) ;
- $year = substr ($date,6,4) ;
- }
- else
- {
- $day = substr ($date,3,2) ;
- $month = substr ($date,0,2) ;
- $year = substr ($date,6,4) ;
- }
- if ($year < 1800)
- { &Error2 ("Function 'DaysFrom1800' expects year >= 1800, not '$year'.") ; return ; }
- $days = ($year - 1800) * 365 ;
- $days += int (($year -1 - 1800) / 4) ;
- $days -= int (($year -1 - 1800) / 100) ;
- if ($month > 1)
- {
- for ($m = $month - 2 ; $m >= 0 ; $m--)
- {
- $days += @mmm [$m] ;
- if ($m == 1)
- {
- if ((($year % 4) == 0) && (($year % 100) != 0))
- { $days ++ ; }
- }
- }
- }
- $days += $day ;
- return ($days) ;
- }
- sub DateToFloat
- {
- my $date = shift ;
- if ($DateFormat !~ /\//)
- { return ($date) ; }
- my $year = $date ;
- $year =~ s/.*\///g ; # delete dd mm/mm dd
- my $fraction = (&DaysFrom1800 ($date) - &DaysFrom1800 ("01/01/" . $year)) / 365.25 ;
- return ($year + $fraction) ;
- }
- sub DateFrom1800
- {
- my $days = shift ;
- @mmm = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) ;
- $year = 1800 ;
- while ($days > 365 + (($year % 4) == 0))
- {
- if ((($year % 4) == 0) && (($year % 100) != 0))
- { $days -= 366 ; }
- else
- { $days -= 365 ; }
- $year ++ ;
- }
- $month = 0 ;
- while ($days > @mmm [$month])
- {
- $days -= @mmm [$month] ;
- if ($month == 1)
- {
- if ((($year % 4) == 0) && (($year % 100) != 0))
- { $days -- ; } ;
- }
- $month++ ;
- }
- $day = $days ;
- $month ++ ;
- if ($DateFormat eq "dd/mm/yyyy")
- { $date = sprintf ("%02d/%02d/%04d", $day, $month, $year) ; }
- else
- { $date = sprintf ("%02d/%02d/%04d", $month, $day, $year) ; }
- return ($date) ;
- }
- sub ExtractText
- {
- my $data = shift ;
- my $data2 = $data ;
- my $text = "" ;
- # special case: allow embedded spaces when 'text' is last attribute
- # $data2 =~ s/\:\:/\@\#\!/g ;
- if ($data2 =~ /text\:[^\:]+$/)
- {
- $text = $data2 ;
- $text =~ s/^.*?text\:// ;
- # $text =~ s/^\s(.*?)\s*$/$1/ ; ?? ->
- $text =~ s/^(.*?)\s*$/$1/ ;
- $text =~ s/\\n/\n/g ;
- $text =~ s/\"\"/\@\#\$/g ;
- $text =~ s/\"//g ;
- $text =~ s/\@\#\$/"/g ;
- $data2 =~ s/text\:.*$// ;
- }
- # extract text between double quotes
- $data2 =~ s/\"\"/\@\#\$/g ;
- if ($data2 =~ /text\:\s*\"/)
- {
- $text = $data2 ;
- $text =~ s/^.*?text\:\s*\"// ;
- if (! ($text =~ /\"/))
- { &Error ("PlotData invalid. Attribute 'text': no closing \" found.") ;
- return ("x", "x") ; }
- $text =~ s/\".*$//;
- $text =~ s/\@\#\$/"/g ;
- $text =~ s/\\n/\n/g ;
- }
- $data2 =~ s/text\:\s*\"[^\"]*\"// ;
- $data2 =~ s/\@\#\$/"/g ;
- return ($data2, $text) ;
- }
- sub ParseText
- {
- my $text = shift ;
- $text =~ s/\_\_/\@\#\$/g ;
- $text =~ s/\_/ /g ;
- $text =~ s/\@\#\$/_/g ;
- $text =~ s/\~\~/\@\#\$/g ;
- $text =~ s/\~/\\n/g ;
- $text =~ s/\@\#\$/~/g ;
- return ($text) ;
- }
- sub BarDefined
- {
- my $bar = shift ;
- foreach $bar2 (@Bars)
- {
- if (lc ($bar2) eq lc ($bar))
- { return ($true) ; }
- }
- # not part of barset ? return
- if ($bar != /\#\d+$/)
- { return ($false) ; }
- # find previous bar in barset
- my $barcnt = $bar ;
- my $barid = $bar ;
- $barcnt =~ s/.*\#(\d+$)/$1/ ;
- $barid =~ s/(.*\#)\d+$/$1/ ;
- $barcnt -- ;
- $a = $#Bars ;
- for (my $b = 0 ; $b <= $#Bars ; $b++)
- {
- if (lc (@Bars [$b]) eq lc ($barid . $barcnt))
- {
- $b++ ;
- for (my $b2 = $#Bars + 1 ; $b2 > $b ; $b2--)
- { @Bars [$b2] = @Bars [$b2-1]; }
- @Bars [$b] = lc ($bar) ;
- @BarLegend {lc ($bar)} = " " ;
- return ($true) ;
- }
- }
- return ($false) ;
- }
- sub ValidAttributes
- {
- my $command = shift ;
- if ($command =~ /^BackgroundColors$/i)
- { return (CheckAttributes ($command, "", "canvas,bars")) ; }
- if ($command =~ /^BarData$/i)
- # { return (CheckAttributes ($command, "", "bar,barset,barcount,link,text")) ; }
- { return (CheckAttributes ($command, "", "bar,barset,link,text")) ; }
- if ($command =~ /^Colors$/i)
- { return (CheckAttributes ($command, "id,value", "legend")) ; }
- if ($command =~ /^ImageSize$/i)
- { return (CheckAttributes ($command, "", "width,height,barincrement")) ; }
- if ($command =~ /^Legend$/i)
- { return (CheckAttributes ($command, "", "columns,columnwidth,orientation,position,left,top")) ; }
- if ($command =~ /^LineData$/i)
- { return (CheckAttributes ($command, "", "at,from,till,atpos,frompos,tillpos,points,color,layer,width")) ; }
- if ($command =~ /^Period$/i)
- { return (CheckAttributes ($command, "from,till", "")) ; }
- if ($command =~ /^PlotArea$/i)
- { return (CheckAttributes ($command, "", "left,bottom,width,height,right,top")) ; }
- if ($command =~ /^PlotData$/i)
- { return (CheckAttributes ($command, "", "align,anchor,at,bar,barset,color,fontsize,from,link,mark,shift,text,textcolor,till,width")) ; }
- if ($command =~ /^Scale/i)
- { return (CheckAttributes ($command, "increment,start", "unit,grid,gridcolor,text")) ; }
- if ($command =~ /^TextData$/i)
- { return (CheckAttributes ($command, "", "fontsize,lineheight,link,pos,tabs,text,textcolor")) ; }
- if ($command =~ /^TimeAxis$/i)
- { return (CheckAttributes ($command, "", "orientation,format,order")) ; }
- return ($true) ;
- }
- sub CheckAttributes
- {
- my $name = shift ;
- my @Required = split (",", shift) ;
- my @Allowed = split (",", shift) ;
- my $attribute ;
- my %Attributes2 = %Attributes ;
- $hint = "\nSyntax: '$name =" ;
- foreach $attribute (@Required)
- { $hint .= " $attribute:.." ; }
- foreach $attribute (@Allowed)
- { $hint .= " [$attribute:..]" ; }
- $hint .= "'" ;
- foreach $attribute (@Required)
- {
- if ((! defined (@Attributes {$attribute})) || (@Attributes {$attribute} eq ""))
- { &Error ("$name definition incomplete. $hint") ;
- undef (@Attributes) ; return ($false) ; }
- delete (@Attributes2 {$attribute}) ;
- }
- foreach $attribute (@Allowed)
- { delete (@Attributes2 {$attribute}) ; }
- @AttrKeys = keys %Attributes2 ;
- if ($#AttrKeys >= 0)
- {
- if (@AttrKeys [0] eq "single")
- { &Error ("$name definition invalid. Specify all attributes as name:value pairs.") ; }
- else
- { &Error ("$name definition invalid. Invalid attribute '" . @AttrKeys [0] . "' found. $hint") ; }
- undef (@Attributes) ; return ($false) ; }
- return ($true) ;
- }
- sub CheckPreset
- {
- my $command = shift ;
- my ($preset, $action, $attrname, $attrvalue) ;
- my $newcommand = $true ;
- my $addvalue = $true ;
- if ($command =~ /^$prevcommand$/i)
- { $newcommand = $false ; }
- if ((! $newcommand) && ($command =~ /^(?:DrawLines|PlotData|TextData)$/i))
- { $addvalue = $false ; }
- $prevcommand = $command ;
- foreach $preset (@PresetList)
- {
- if ($preset =~ /^$command\|/i)
- {
- ($command, $action, $attrname, $attrpreset) = split ('\|', $preset) ;
- if ($attrname eq "")
- { $attrname = "single" ; }
- $attrvalue = @Attributes {$attrname} ;
- if (($action eq "-") && ($attrvalue ne ""))
- {
- if ($attrname eq "single")
- { &Error ("Chosen preset makes this command redundant.\n" .
- " Please remove this command.") ; }
- else
- { &Error ("Chosen preset conflicts with '$attrname:...'.\n" .
- " Please remove this attribute.") ; }
- @Attributes {$attrname} = "" ;
- }
- if (($action eq "+") && ($attrvalue eq ""))
- {
- if ($addvalue)
- { @Attributes {$attrname} = $attrpreset ; }
- }
- if (($action eq "=") && ($attrvalue eq ""))
- { @Attributes {$attrname} = $attrpreset ; }
- if (($action eq "=") && ($attrvalue ne "") &&
- ($attrvalue !~ /$attrpreset/i))
- {
- if ($attrname eq "single")
- { &Error ("Conflicting settings.\nPreset defines '$attrpreset'.") ; }
- else
- { &Error ("Conflicting settings.\nPreset defines '$attrname:$attrpreset'.") ; }
- @Attributes {$attrname} = $attrpreset ;
- }
- }
- }
- }
- sub ShiftOnePixelForSVG
- {
- my $line = shift ;
- $line =~ s/location:\s*// ;
- my ($posx, $posy) = split (" ", $line) ;
- if ($posy =~ /\+/)
- { ($posy1, $posy2) = split ('\+', $posy) ; }
- elsif ($posy =~ /.+\-/)
- {
- if ($posy =~ /^\-/)
- {
- ($sign, $posy1, $posy2) = split ('\-', $posy) ; $posy2 = - $posy2 ;
- $posy1 = "-" . $posy1 ;
- }
- else
- { ($posy1, $posy2) = split ('\-', $posy) ; $posy2 = - $posy2 }
- }
- else
- { $posy1 = $posy ; $posy2 = 0 ; }
- if ($posy1 !~ /(s)/)
- { $posy += 0.01 ; }
- else
- {
- $posy2 += 0.01 ;
- if ($posy2 == 0)
- { $posy = $posy1 ; }
- elsif ($posy2 < 0)
- { $posy = $posy1 . "$posy2" ; }
- else
- { $posy = $posy1 . "+" . $posy2 ; }
- }
- $line = "\n location: $posx $posy" ;
- return ($line) ;
- }
- sub NormalizeURL
- {
- my $url = shift ;
- $url =~ s/(https?)\:?\/?\/?/$1:\/\// ; # add possibly missing special characters
- $url =~ s/ /%20/g ;
- return ($url) ;
- }
- # wiki style link may include linebreak characters -> split into several wiki links
- sub NormalizeWikiLink
- {
- my $text = shift ;
- my $brdouble = $false ;
- if ($text =~ /\[\[.*\]\]/)
- { $brdouble = $true ; }
- $text =~ s/\[\[?// ;
- $text =~ s/\]?\]// ;
- my ($hide,$show) = split ('\|', $text) ;
- if ($show eq "")
- { $show = $hide ; }
- $hide =~ s/\s*\n\s*/ /g ;
- my @Show = split ("\n", $show) ;
- $text = "" ;
- foreach $part (@Show)
- {
- if ($brdouble)
- { $part = "[[" . $hide . "|" . $part . "]]" ; }
- else
- { $part = "[" . $hide . "|" . $part . "]" ; }
- }
- $text = join ("\n", @Show) ;
- return ($text) ;
- }
- sub ProcessWikiLink
- {
- my $text = shift ;
- my $link = shift ;
- my $hint = shift ;
- my $wikilink = $false ;
- chomp ($text) ;
- chomp ($link) ;
- chomp ($hint) ;
- my ($wiki, $title) ;
- if ($link ne "") # ignore wiki brackets in text when explicit link is specified
- {
- $text =~ s/\[\[ [^\|]+ \| (.*) \]\]/$1/gx ;
- $text =~ s/\[\[ [^\:]+ \: (.*) \]\]/$1/gx ;
- # $text =~ s/\[\[ (.*) \]\]/$1/gx ;
- }
- else
- {
- if ($text =~ /\[.+\]/) # keep first link in text segment, remove others
- {
- $link = $text ;
- $link =~ s/\n//g ;
- $link =~ s/^[^\[\]]*\[/[/x ;
- if ($link =~ /^\[\[/)
- { $wikilink = $true ; }
- $link =~ s/^ [^\[]* \[+ ([^\[\]]*) \].*$/$1/x ;
- $link =~ s/\|.*$// ;
- if ($wikilink)
- { $link = "[[" . $link . "]]" ; }
- $text =~ s/(\[+) [^\|\]]+ \| ([^\]]*) (\]+)/$1$2$3/gx ;
- $text =~ s/(https?)\:/$1colon/gx ;
- # $text =~ s/(\[+) [^\:\]]+ \: ([^\]]*) (\]+)/$1$2$3/gx ; #???
- # remove interwiki link prefix
- $text =~ s/(\[+) (?:.{2,3}|(?:zh\-.*)|simple|minnan|tokipona) \: ([^\]]*) (\]+)/$1$2$3/gxi ; #???
- $text =~ s/\[+ ([^\]]+) \]+/{{{$1}}}/x ;
- $text =~ s/\[+ ([^\]]+) \]+/$1/gx ;
- $text =~ s/\{\{\{ ([^\}]*) \}\}\}/[[$1]]/x ;
- }
- # if ($text =~ /\[\[.+\]\]/)
- # {
- # $wikilink = $true ;
- # $link = $text ;
- # $link =~ s/\n//g ;
- # $link =~ s/^.*?\[\[/[[/x ;
- # $link =~ s/\| .*? \]\].*$/]]/x ;
- # $link =~ s/\]\].*$/]]/x ;
- # $text =~ s/\[\[ [^\|\]]+ \| (.*?) \]\]/[[$1]]/x ;
- # $text =~ s/\[\[ [^\:\]]+ \: (.*?) \]\]/[[$1]]/x ;
- # # remove remaining links
- # $text =~ s/\[\[ ([^\]]+) \]\]/^%#$1#%^/x ;
- # $text =~ s/\[+ ([^\]]+) \]+/$1/gx ;
- # $text =~ s/\^$hPerc\# (.*?) \#$hPerc\^/[[$1]]/x ;
- # }
- # elsif ($text =~ /\[.+\]/)
- # {
- # $link = $text ;
- # $link =~ s/\n//g ;
- # $link =~ s/^.*?\[/[/x ;
- # $link =~ s/\| .*? \].*$/]/x ;
- # $link =~ s/\].*$/]/x ;
- # $link =~ s/\[ ([^\]]+) \]/$1/x ;
- # $text =~ s/\[ [^\|\]]+ \| (.*?) \]/[[$1]]/x ;
- # # remove remaining links
- # $text =~ s/\[\[ ([^\]]+) \]\]/^%#$1#%^/x ;
- # $text =~ s/\[+ ([^\]]+) \]+/$1/gx ;
- # $text =~ s/\^$hPerc\# (.*?) \#$hPerc\^/[[$1]]/x ;
- ## $text =~ s/\[\[ (.*) \]\]/$1/gx ;
- # }
- }
- if ($wikilink)
- {
- # if ($link =~ /^\[\[.+\:.+\]\]$/) # has a colon in its name
- if ($link =~ /^\[\[ (?:.{2,3}|(?:zh\-.*)|simple|minnan|tokipona) \: .+\]\]$/xi) # has a interwiki link prefix
- {
- # This will fail for all interwiki links other than Wikipedia.
- $wiki = lc ($link) ;
- $title = $link ;
- $wiki =~ s/\[\[([^\:]+)\:.*$/$1/x ;
- $title =~ s/^[^\:]+\:(.*)\]\]$/$1/x ;
- $title =~ s/ /_/g ;
- $link = "http://$wiki.wikipedia.org/wiki/$title" ;
- $link = &EncodeURL ($title) ;
- if (($hint eq "") && ($title ne ""))
- { $hint = "$wiki: $title" ; }
- }
- else
- {
- # $wiki = "en" ;
- $title = $link ;
- $title =~ s/^\[\[(.*)\]\]$/$1/x ;
- $title =~ s/ /_/g ;
- $link = $articlepath ;
- $urlpart = &EncodeURL ($title) ;
- $link =~ s/\$1/$urlpart/ ;
- if (($hint eq "") && ($title ne ""))
- { $hint = "$title" ; }
- }
- $hint =~ s/_/ /g ;
- }
- else
- {
- if ($link ne "")
- { $hint = &ExternalLinkToHint ($link) ; }
- }
- if (($link ne "") && ($text !~ /\[\[/) && ($text !~ /\]\]/))
- { $text = "[[" . $text . "]]" ; }
- $hint = &EncodeHtml ($hint) ;
- return ($text, $link, $hint) ;
- }
- sub ExternalLinkToHint
- {
- my $hint = shift ;
- $hint =~ s/^https?\:?\/?\/?// ;
- $hint =~ s/\/.*$// ;
- return (&EncodeHtml ($hint . "/..")) ;
- }
- sub EncodeInput
- {
- my $text = shift ;
- # revert encoding of '<' & '>' by MediaWiki
- $text =~ s/\<\;/\</g ;
- $text =~ s/\>\;/\>/g ;
- $text =~ s/([\`\{\}\%\&\@\$\(\)\;\=])/"%" . sprintf ("%X", ord($1)) . "%";/ge ;
- return ($text) ;
- }
- sub DecodeInput
- {
- my $text = shift ;
- $text =~ s/\%([0-9A-F]{2})\%/chr(hex($1))/ge ;
- return ($text) ;
- }
- sub EncodeHtml
- {
- my $text = shift ;
- $text =~ s/([\<\>\&\'\"])/"\&\#" . ord($1) . "\;"/ge ;
- $text =~ s/\n/<br>/g ;
- return ($text) ;
- }
- sub EncodeURL
- {
- my $url = shift ;
- # For some reason everything gets run through this weird internal
- # encoding that's similar to URL-encoding. Armor against this as well,
- # or else adjacent encoded bytes will be corrupted.
- $url =~ s/([^0-9a-zA-Z\%\:\/\._])/"%25%".sprintf ("%02X",ord($1))/ge ;
- return ($url) ;
- }
- sub Error
- {
- my $msg = &DecodeInput(shift) ;
- $msg =~ s/\n\s*/\n /g ; # indent consecutive lines
- $CntErrors++ ;
- if (! $listinput)
- { push @Errors, "Line $LineNo: " . &DecodeInput($Line) . "\n" ; }
- push @Errors, "- $msg\n\n" ;
- if ($CntErrors > 10)
- { &Abort ("More than 10 errors found") ; }
- }
- sub Error2
- {
- my $msg = &DecodeInput(shift) ;
- $msg =~ s/\n\s*/\n /g ; # indent consecutive lines
- $CntErrors++ ;
- push @Errors, "- $msg\n" ;
- }
- sub Warning
- {
- my $msg = &DecodeInput(shift) ;
- $msg =~ s/\n\s*/\n /g ; # indent consecutive lines
- if (! $listinput)
- { push @Warnings, "Line $LineNo: " . &DecodeInput ($Line) . "\n" ; }
- push @Warnings, "- $msg\n\n" ;
- }
- sub Warning2
- {
- my $msg = &DecodeInput(shift) ;
- $msg =~ s/\n\s*/\n /g ; # indent consecutive lines
- push @Warnings, "- $msg\n" ;
- }
- sub Info
- {
- my $msg = &DecodeInput(shift) ;
- $msg =~ s/\n\s*/\n /g ; # indent consecutive lines
- if (! $listinput)
- { push @Info, "Line $LineNo: " . &DecodeInput ($Line) . "\n" ; }
- push @Info, "- $msg\n\n" ;
- }
- sub Info2
- {
- my $msg = &DecodeInput(shift) ;
- $msg =~ s/\n\s*/\n /g ; # indent consecutive lines
- push @Info, "- $msg\n" ;
- }
- sub Abort
- {
- my $msg = &DecodeInput(shift) ;
- print "\n\n***** " . $msg . " *****\n\n" ;
- print @Errors ;
- print "Execution aborted.\n" ;
- open "FILE_OUT", ">", $file_errors ;
- print FILE_OUT "<p>EasyTimeline $version</p><p><b>Timeline generation failed: " . &EncodeHtml ($msg) ."</b></p>\n" ;
- foreach $line (@Errors)
- { print FILE_OUT &EncodeHtml ($line) . "\n" ; }
- close "FILE_OUT" ;
- if ($makehtml) # generate html test file, which would normally contain png + svg (+ image map)
- {
- open "FILE_IN", "<", $file_errors ;
- open "FILE_OUT", ">", $file_html ;
- print FILE_OUT "<html><head>\n<title>Graphical Timelines - HTML test file</title>\n</head>\n" .
- "<body><h1><font color='green'>EasyTimeline</font> - Test Page</h1>\n\n" .
- "<code>\n" ;
- print FILE_OUT <FILE_IN> ;
- print FILE_OUT "</code>\n\n</body>\n</html>" ;
- close "FILE_IN" ;
- close "FILE_OUT" ;
- }
- exit ;
- }
- sub EscapeShellArg
- {
- my $arg = shift;
- if ($env eq "Linux") {
- $arg =~ s/'/\\'/;
- $arg = "'$arg'";
- } else {
- $arg =~ s/"/\\"/;
- $arg = "\"$arg\"";
- }
- return $arg;
- }
- # vim: set sts=2 ts=2 sw=2 et :
- sub UnicodeToAscii {
- my $unicode = shift ;
- my $char = substr ($unicode,0,1) ;
- my $ord = ord ($char) ;
- if ($ord < 128) # plain ascii character
- { return ($unicode) ; } # (will not occur in this script)
- else
- {
- # for completeness sake complete routine, only 2 byte unicodes sent here
- if ($ord >= 252)
- { $value = $ord - 252 ; }
- elsif ($ord >= 248)
- { $value = $ord - 248 ; }
- elsif ($ord >= 240)
- { $value = $ord - 240 ; }
- elsif ($ord >= 224)
- { $value = $ord - 224 ; }
- else
- { $value = $ord - 192 ; }
- for ($c = 1 ; $c < length ($unicode) ; $c++)
- { $value = $value * 64 + ord (substr ($unicode, $c,1)) - 128 ; }
- # $html = "\&\#" . $value . ";" ; any unicode can be specified as html char
- if (($value >= 128) && ($value <= 255))
- { return (chr ($value)) ; }
- else
- { return "?" ; }
- }
- }
|