#!/usr/bin/env 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 spaces
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 = ; 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 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" . " -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 = ; 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 = ; close "FILE_IN" ; foreach $line (@svg) { $line =~ s/\{\{(\d+)\}\}x+/@textsSVG[$1]/gxe ; $line =~ s/\[(\d+)\[ (.*?) \]\d+\]/'' . $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 = ) { $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__ ; %FILENAME% - EasyTimeline test file\n

EasyTimeline - Test Page

Fixed size version (PNG): file $file_png

$map


Scalable version (SVG): file $file_vector

Your browser does not support embedded objects

As you can see the scalable version renders fonts smoother better than the bitmap version.
Any SVG picture can also be rescaled or zoomed into, without annoying artefacts.

Windows users:
  Right mouse click on picture for zoom options or

  Ctrl+click for zoom in
  Ctrl+Shift+click for zoom out
  Alt+drag with mouse to move focus __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/([\`\{\}\%\&\@\$\(\)\;\=])/"%" . 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/
/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 "

EasyTimeline $version

Timeline generation failed: " . &EncodeHtml ($msg) ."

\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 "\nGraphical Timelines - HTML test file\n\n" . "

EasyTimeline - Test Page

\n\n" . "\n" ; print FILE_OUT ; print FILE_OUT "\n\n\n" ; 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 "?" ; } } }