############################################## # # 55_InfoPanel.pm written by betateilchen # # forked from 02_RSS.pm by Dr. Boris Neubert # ############################################## # $Id: $ package main; use strict; use warnings; use MIME::Base64; use Image::Info qw(image_info dim); #use Data::Dumper; use feature qw/switch/; use vars qw(%data); use HttpUtils; my @cmd_halign= qw(thalign ihalign); my @cmd_valign= qw(tvalign ivalign); my @valid_valign = qw(auto baseline middle center hanging); my @valid_halign = qw(start middle end); no if $] >= 5.017011, warnings => 'experimental::smartmatch'; # we can # use vars qw(%FW_types); # device types, # use vars qw($FW_RET); # Returned data (html) # use vars qw($FW_wname); # Web instance # use vars qw($FW_subdir); # Sub-path in URL for extensions, e.g. 95_FLOORPLAN # use vars qw(%FW_pos); # scroll position # use vars qw($FW_cname); # Current connection name #sub InfoPanel_Initialize($); sub btIP_Define($$); sub btIP_Set; sub btIP_Notify; sub btIP_readLayout($); sub btIP_itemArea; sub btIP_itemButton; sub btIP_itemCircle; sub btIP_itemDate; sub btIP_itemEllipse; sub btIP_itemGroup; sub btIP_itemImg; sub _btIP_imgData; sub _btIP_imgRescale; sub btIP_itemLine; sub btIP_itemPlot; sub btIP_itemRect; sub btIP_itemSeconds; sub btIP_itemText; sub btIP_itemTextBox; sub btIP_itemTime; sub btIP_color; sub btIP_xy; sub btIP_ReturnSVG($); sub btIP_evalLayout($$@); sub btIP_addExtension($$$); sub btIP_CGI; sub btIP_splitRequest($); sub btIP_returnHTML($); sub btIP_HTMLHead($$); sub btIP_getScript; sub btIP_HTMLTail; sub btIP_Overview; sub btIP_getURL; ###################################### sub InfoPanel_Initialize($) { my ($hash) = @_; $hash->{DefFn} = "btIP_Define"; $hash->{UndefFn} = "btIP_Undef"; #$hash->{AttrFn} = "btIP_Attr"; $hash->{AttrList} = "autoreload:1,0 bg bgcolor refresh size title tmin"; $hash->{SetFn} = "btIP_Set"; $hash->{NotifyFn} = "btIP_Notify"; btIP_addExtension("btIP_CGI","btip","InfoPanel"); return undef; } sub btIP_Define($$) { my ($hash, $def) = @_; my @a = split("[ \t]+", $def); return "Usage: define InfoPanel filename" if(int(@a) != 3); my $name= $a[0]; my $filename= $a[2]; $hash->{NOTIFYDEV} = 'global'; $hash->{fhem}{div} = ''; $hash->{LAYOUTFILE} = $filename; btIP_readLayout($hash); $hash->{STATE} = 'defined'; return undef; } sub btIP_Undef($$) { my ($hash, $arg) = @_; # check if last device my $url = '/btip'; $data{FWEXT}{$url} = undef if int(devspec2array('TYPE=InfoPanel')) == 1; return undef; } sub btIP_Set { my ($hash, @a) = @_; my $name = $a[0]; # usage check my $usage= "Unknown argument, choose one of reread:noArg"; if((@a == 2) && ($a[1] eq "reread")) { btIP_readLayout($hash); return undef; } else { return $usage; } } sub btIP_Notify { my ($hash,$dev) = @_; return unless AttrVal($hash->{NAME},'autoreload',1); return if($dev->{NAME} ne "global"); return if(!grep(m/^FILEWRITE $hash->{LAYOUTFILE}$/, @{$dev->{CHANGED}})); Log3(undef, 4, "InfoPanel: $hash->{NAME} reread layout after edit."); undef = btIP_readLayout($hash); return undef; } sub btIP_readLayout($) { my ($hash)= @_; my $filename= $hash->{LAYOUTFILE}; my $name= $hash->{NAME}; my ($err, @layoutfile) = FileRead($filename); if($err) { Log 1, "InfoPanel $name: $err"; $hash->{fhem}{layout}= ("text 0.1 0.1 'Error: $err'"); } else { $hash->{fhem}{layout} = join("\n", @layoutfile); while($hash->{fhem}{layout} =~ m/\@include/ ) { my (@layout2,@include); foreach my $ll (@layoutfile) { if($ll !~ m/^\@include/) { push(@layout2,$ll); } else { my ($cmd, $def)= split("[ \t]+", $ll, 2); ($err,@include) = FileRead($def) if($def); splice(@layout2,-1,0,@include) unless $err; } } @layoutfile = @layout2; @layout2 = undef; $hash->{fhem}{layout} = join("\n",@layoutfile); } $hash->{fhem}{layout} =~ s/\n\n/\n/g; } return; } ################## # # Layout evaluation # ##### Items sub btIP_itemArea { my ($id,$x1,$y1,$x2,$y2,$link,%params)= @_; $id = ($id eq '-') ? createUniqueId() : $id; my $width = $x2 - $x1; my $height = $y2 - $y1; my $target = 'secret'; $target = '_top' if $link =~ s/^-//; $target = '_blank' if $link =~ s/^\+//; my $output = "\n"; $output .= "\n"; $output .= "\n"; return $output; } sub btIP_itemButton { my ($id,$x1,$y1,$x2,$y2,$rx,$ry,$link,$text,%params)= @_; $id = ($id eq '-') ? createUniqueId() : $id; my $width = $x2 - $x1; my $height = $y2 - $y1; my ($r,$g,$b,$a) = btIP_color($params{boxcolor}); $text = AnalyzePerlCommand(undef,$text); $link = AnalyzePerlCommand(undef,$link); my $target = 'secret'; $target = '_top' if $link =~ s/^-//; $target = '_blank' if $link =~ s/^\+//; my $output = "\n"; $output .= "\n"; my $oldhalign = $params{thalign}; my $oldvalign = $params{tvalign}; $params{thalign} = "middle"; $params{tvalign} = "middle"; $output .= btIP_itemText($id."_text",($x1+$x2)/2,($y1+$y2)/2,$text,%params); $params{thalign} = $oldhalign; $params{tvalign} = $oldvalign; $output .= "\n"; return $output; } sub btIP_itemCircle { my ($id,$x,$y,$r,$filled,%params)= @_; $id = ($id eq '-') ? createUniqueId() : $id; my $output = "\n" if $type eq 'close'; $id = ($id eq '-') ? createUniqueId() : $id; return "" if $type eq 'open'; } sub btIP_itemImg { my ($id,$x,$y,$scale,$srctype,$arg,%params)= @_; $id = ($id eq '-') ? createUniqueId() : $id; return unless(defined($arg)); return if($arg eq ""); my ($data,$info,$width,$height,$mimetype,$output); if($srctype eq 'file') { my (@d,$err); $err = ""; Log3(undef,4,"InfoPanel img name: $arg"); ($err,@d) = FileRead($arg); if($err && configDBUsed()) { # not found in database, try to read from filesystem Log3(undef,4,"Infopanel forced read $arg"); $err = undef; ($err,@d) = FileRead({FileName => $arg, ForceType =>'file'}); Log3(undef,4,"Infopanel: forced read error file: $arg") if $err; Log3(undef,4,"Infopanel: forced read found: $arg") if !$err; } $data = join("",@d) unless $err; } elsif ($srctype eq "url" || $srctype eq "urlq") { if($srctype eq "url") { $data= GetFileFromURL($arg,3,undef,1); } else { $data= GetFileFromURLQuiet($arg,3,undef,1); } } elsif ($srctype eq 'data') { $data = $arg; } else { Log3(undef,2,"InfoPanel: unknown sourcetype for image tag"); return ""; } ($width,$height,$data) = _btIP_imgData($data,$scale); $output = "\n"; return $output; } sub _btIP_imgData { my ($arg,$scale) = @_; my $info = image_info(\$arg); my $width = $info->{width}; my $height = $info->{height}; ($width,$height)= _btIP_imgRescale($width,$height,$scale) unless $scale eq '1'; my $mimetype = $info->{file_media_type}; my $data = "data:$mimetype;base64,".encode_base64($arg); return ($width,$height,$data); } sub _btIP_imgRescale { my ($width,$height,$scale) = @_; if ($scale =~ s/([whWH])([\d]*)/$2/) { $scale = (uc($1) eq "W") ? $scale/$width : $scale/$height; } $width = int($scale*$width); $height = int($scale*$height); return ($width,$height); } sub btIP_itemLine { my ($id,$x1,$y1,$x2,$y2,$th,%params)= @_; $id = ($id eq '-') ? createUniqueId() : $id; my ($r,$g,$b,$a) = btIP_color($params{rgb}); return "\n"; } sub btIP_itemPlot { my ($id,$x,$y,$scale,$inline,$arg) = @_; my (@plotName) = split(";",$arg); $id = ($id eq '-') ? createUniqueId() : $id; my (@webs,$width,$height,$output,$mimetype,$svgdata); @webs=devspec2array("TYPE=FHEMWEB"); foreach(@webs) { if(!InternalVal($_,'TEMPORARY',undef)) { $FW_wname=InternalVal($_,'NAME',''); last; } } ($width,$height) = split(",", AttrVal($plotName[0],"plotsize","800,160")); ($width,$height) = _btIP_imgRescale($width,$height,$scale) unless $scale eq '1'; if($inline eq "1") { # # embed base64 data # $FW_RET = undef; $FW_webArgs{dev} = $plotName[0]; $FW_webArgs{logdev} = InternalVal($plotName[0], "LOGDEVICE", ""); $FW_webArgs{gplotfile} = InternalVal($plotName[0], "GPLOTFILE", ""); $FW_webArgs{logfile} = InternalVal($plotName[0], "LOGFILE", "CURRENT"); $FW_pos{zoom} = ($plotName[1]) ? $plotName[1] : 'day'; $FW_pos{off} = ($plotName[2]) ? $plotName[2] : undef; ($mimetype, $svgdata) = SVG_showLog("unused"); $svgdata =~ s/<\/svg>/<\/svg>/; # $svgdata =~ s/\n"; } else { # # embed link to plot # my $url; $url = "$FW_ME/SVG_showLog?dev=". $plotName[0]. "&logdev=". InternalVal($plotName[0], "LOGDEVICE", ""). "&gplotfile=". InternalVal($plotName[0], "GPLOTFILE", ""). "&logfile=". InternalVal($plotName[0], "LOGFILE", "CURRENT"); $url .= "&pos=". ($plotName[1]) ? $plotName[1] : 'day'; $url .= "&zoom=". ($plotName[2]) ? $plotName[2] : undef; $output = "\n"; } return $output; } sub btIP_itemRect { my ($id,$x1,$y1,$x2,$y2,$rx,$ry,$filled,%params)= @_; $id = ($id eq '-') ? createUniqueId() : $id; my $width = $x2 - $x1; my $height = $y2 - $y1; my $output = "\n$text\n\n"; return $output; } sub btIP_itemTextBox { my ($id,$x,$y,$boxwidth,$boxheight,$text,%params)= @_; return unless(defined($text)); $id = ($id eq '-') ? createUniqueId() : $id; my $color = substr($params{rgb},0,6); my ($d,$output); if(defined($params{boxcolor})) { my $orgcolor = $params{rgb}; $params{rgb} = $params{boxcolor}; my $bx1 = $x - $params{padding}; my $by1 = $y - $params{padding}; my $bx2 = $x + $boxwidth + $params{padding}; my $by2 = $y + $boxheight + $params{padding}; $output .= btIP_itemRect("box_$id",$bx1,$by1,$bx2,$by2,1,1,1,%params); $params{rgb} = $orgcolor; } else { $output = ""; } $d = "
\n". "

\n$text\n

\n". "
\n"; $defs{$params{name}}{fhem}{div} .= $d; return $output; } sub btIP_itemTime { my ($id,$x,$y,%params)= @_; $id = ($id eq '-') ? createUniqueId() : $id; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); return btIP_itemText($id,$x,$y,sprintf("%02d:%02d", $hour, $min),%params); } ##### Helper sub btIP_color { my ($rgb)= @_; my $alpha = 1; my @d= split("", $rgb); if(length($rgb) == 8) { $alpha = hex("$d[6]$d[7]"); $alpha = $alpha/255; } return (hex("$d[0]$d[1]"),hex("$d[2]$d[3]"),hex("$d[4]$d[5]"),$alpha); } sub btIP_xy { my ($x,$y,%params)= @_; $x = $params{xx} if($x eq 'x'); $y = $params{yy} if($y eq 'y'); if((-1 < $x) && ($x < 1)) { $x *= $params{width}; } if((-1 < $y) && ($y < 1)) { $y *= $params{height}; } return($x,$y); } ################## # # create SVG content # sub btIP_returnSVG($) { my ($name)= @_; # # increase counter # if(defined($defs{$name}{fhem}) && defined($defs{$name}{fhem}{counter})) { $defs{$name}{fhem}{counter}++; } else { $defs{$name}{fhem}{counter}= 1; } my ($width,$height)= split(/x/, AttrVal($name,"size","800x600")); my $bgcolor = AttrVal($name,'bgcolor','000000'); my $svg = ""; eval { $svg = "\n= $tmin) { $defs{$name}{fhem}{t}= $t1; $bgnr++; } # detect pictures # if(opendir(BGDIR, $bgdir)){ # my @bgfiles= grep {$_ !~ /^\./} readdir(BGDIR); # # #foreach my $f (@bgfiles) { # # Debug sprintf("File \"%s\"\n", $f); # #} # closedir(BGDIR); # # get item number # if($#bgfiles>=0) { # if($bgnr > $#bgfiles) { $bgnr= 0; } # $defs{$name}{fhem}{bgnr}= $bgnr; # my $bgfile= $bgdir . "/" . $bgfiles[$bgnr]; # my $filetype =(split(/\./,$bgfile))[-1]; # my $bg; # $bg= newFromGif GD::Image($bgfile) if $filetype =~ m/^gif$/i; # $bg= newFromJpeg GD::Image($bgfile) if $filetype =~ m/^jpe?g$/i; # $bg= newFromPng GD::Image($bgfile) if $filetype =~ m/^png$/i; # if(defined($bg)) { # my ($bgwidth,$bgheight)= $bg->getBounds(); # if($bgwidth != $width or $bgheight != $height) { # # we need to resize # my ($w,$h); # my ($u,$v)= ($bgwidth/$width, $bgheight/$height); # if($u>$v) { # $w= $width; # $h= $bgheight/$u; # } else { # $h= $height; # $w= $bgwidth/$v; # } # $svg->copyResized($bg,($width-$w)/2,($height-$h)/2,0,0,$w,$h,$bgwidth,$bgheight); # } else { # # size is as required # # kill the predefined image and take the original # undef $svg; # $svg= $bg; # } # } else { # undef $svg; # $reason= "Something was wrong with background image \"$bgfile\"."; # } # } # } # end opendir() } # end defined() $svg .= "\" >\n\n"; $svg .= btIP_evalLayout($svg, $name, $defs{$name}{fhem}{layout}); $defs{$name}{STATE} = localtime(); }; #warn $@ if $@; if($@) { my $msg= $@; chomp $msg; Log3 $name, 2, $msg; } $svg .= "Sorry, your browser does not support inline SVG.\n\n"; return $svg; } sub btIP_evalLayout($$@) { my ($svg,$name,$layout)= @_; my ($width,$height)= split(/x/, AttrVal($name,"size","800x600")); my @layout= split("\n", $layout); my %params; $params{name}= $name; $params{width}= $width; $params{height}= $height; $params{font}= "Arial"; $params{pt}= 12; $params{rgb}= "ffffff"; $params{condition} = 1; # we need two pairs of align parameters # due to different default values for text and img $params{ihalign} = 'left'; $params{ivalign} = 'top'; $params{thalign} = 'start'; $params{tvalign} = 'auto'; $params{tbalign} = 'left'; $params{linespace} = 0; $params{boxcolor} = undef; $params{padding} = 0; $params{xx}= 0; $params{yy}= 0; $defs{$name}{fhem}{div} = undef; my ($id,$x,$y,$x1,$y1,$x2,$y2,$r1,$r2); my ($scale,$inline,$boxwidth,$boxheight,$boxcolor); my ($text,$link,$imgtype,$srctype,$arg,$format); my $cont= ""; foreach my $line (@layout) { # kill trailing newline chomp $line; # kill comments and blank lines $line=~ s/\#.*$//; $line=~ s/\@.*$//; $line=~ s/\s+$//; $line= $cont . $line; if($line=~ s/\\$//) { $cont= $line; undef $line; } next unless($line); $cont= ""; #Debug "$name: evaluating >$line<"; # split line into command and definition my ($cmd, $def)= split("[ \t]+", $line, 2); # Debug "CMD= \"$cmd\", DEF= \"$def\""; # separate condition handling if($cmd eq 'condition') { $params{condition} = AnalyzePerlCommand(undef, $def); next; } next unless($params{condition}); # Debug "before command $line: x= " . $params{xx} . ", y= " . $params{yy}; eval { given($cmd) { when("area") { ($id,$x1,$y1,$x2,$y2,$arg)= split("[ \t]+", $def, 6); ($x1,$y1)= btIP_xy($x1,$y1,%params); ($x2,$y2)= btIP_xy($x2,$y2,%params); my $arg = AnalyzePerlCommand(undef,$arg); $params{xx} = $x; $params{yy} = $y; $svg .= btIP_itemArea($id,$x1,$y1,$x2,$y2,$arg,%params); } when("boxcolor"){ $def = "\"$def\"" if(length($def) == 6 && $def =~ /[[:xdigit:]]{6}/); $params{boxcolor} = AnalyzePerlCommand(undef, $def); } when("button") { ($id,$x1,$y1,$x2,$y2,$r1,$r2,$link,$text)= split("[ \t]+", $def, 9); ($x1,$y1)= btIP_xy($x1,$y1,%params); ($x2,$y2)= btIP_xy($x2,$y2,%params); my $arg = AnalyzePerlCommand(undef,$arg); $params{xx} = $x; $params{yy} = $y; $svg .= btIP_itemButton($id,$x1,$y1,$x2,$y2,$r1,$r2,$link,$text,%params); } when("buttonpanel"){ $defs{$params{name}}{fhem}{div} = "
". "