code_perl/Maasha/KISS/Draw.pm

   1 package Maasha::KISS::Draw;
   2
   3 # Copyright (C) 2009 Martin A. Hansen.
   4
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # http://www.gnu.org/copyleft/gpl.html
  20
  21
  22 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  23
  24
  25 # Routines for creating KISS graphics using Cairo and Pango.
  26
  27
  28 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29
  30
  31 use warnings;
  32 use strict;
  33 use Data::Dumper;
  34 use Cairo;
  35 use Pango;
  36
  37 use vars qw( @ISA @EXPORT );
  38
  39 @ISA = qw( Exporter );
  40
  41
  42 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  43
  44
  45 sub draw_feature
  46 {
  47     # Given a list of features add these to
  48     # a Cairo::Context object.
  49
  50     my ( $cr,         # Cairo::Context object
  51          $features,   # List of features
  52        ) = @_;
  53
  54     # Returns nothing.
  55
  56     my ( $feature );
  57
  58     foreach $feature ( @{ $features } )
  59     {
  60         $cr->set_source_rgb( color_name2rgb( $feature->{ 'color' } ) );
  61
  62         if ( $feature->{ 'type' } eq 'line' )
  63         {
  64             $cr->set_line_width( $feature->{ 'line_width' } );
  65             $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
  66             $cr->line_to( $feature->{ 'x2' }, $feature->{ 'y2' } );
  67         }
  68         elsif ( $feature->{ 'type' } eq 'rect' )
  69         {
  70             $cr->rectangle(
  71                 $feature->{ 'x1' },
  72                 $feature->{ 'y1' },
  73                 $feature->{ 'x2' } - $feature->{ 'x1' },
  74                 $feature->{ 'y2' } - $feature->{ 'y1' },
  75             );
  76
  77             $cr->fill;
  78         }
  79         elsif ( $feature->{ 'type' } eq 'text' )
  80         {
  81             $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
  82             $cr->set_font_size( $feature->{ 'font_size' } );
  83             $cr->show_text( $feature->{ 'txt' } );
  84         }
  85
  86         $cr->stroke;
  87     }
  88 }
  89
  90
  91 sub color_name2rgb
  92 {
  93     my ( $color_name
  94        ) = @_;
  95
  96     my ( %color_hash, $rgb );
  97
  98     %color_hash = (
  99         'black' => [   0,   0,   0 ],
 100         'red'   => [ 255,   0,   0 ],
 101         'green' => [   0, 255,   0 ],
 102         'blue'  => [   0,   0, 255 ],
 103     );
 104
 105     if ( exists $color_hash{ $color_name } ) {
 106         $rgb = $color_hash{ $color_name };
 107     } else {
 108         $rgb = [ 0, 0, 0 ];
 109     }
 110
 111     return wantarray ? @{ $rgb } : $rgb;
 112 }
 113
 114
 115 sub file_png
 116 {
 117     # Martin A. Hansen, October 2009.
 118
 119     # Prints a Cairo::Surface object to a PNG file.
 120
 121     my ( $surface,   # Cairo::Surface object
 122          $file,      # path to PNG file
 123        ) = @_;
 124
 125     # Returns nothing
 126
 127     $surface->write_to_png( $file );
 128 }
 129
 130
 131 sub hdump
 132 {
 133     my ( $foo ) = @_;
 134
 135     my ( @html );
 136
 137     @html = "Content-Type: text/html; charset=ISO-8859-1\n\n";
 138
 139     push @html, "<pre>\n";
 140     push @html, Dumper( $foo );
 141     push @html, "</pre>\n";
 142
 143     return wantarray ? @html : \@html;
 144 }
 145
 146
 147 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 148
 149 1;
 150
 151