http://www.perlmonks.org?node_id=690211
Category: Gui Programming
Author/Contact Info zentara
Description: You can load an image, and make waypoints. Zoom and save to svg or pdf. (I don't know if it's a bug on my system, but it won't save a loaded svg map as svg (the waypoints show up but the svg map is all black), but will save to pdf just fine. Add an image of your choice and uncomment the section for loading it. I just start with a rectangle for this demo. For best results with an image, use a huge image and scale the canvas down after loading it, so the resolution stays good when zooming. I have 1, but it's 3 megs, so I won't base64encode it into the script. :-)
#!/usr/bin/perl -w
use strict;
use warnings;
use Goo::Canvas;
use Gtk2 '-init';
use Glib qw(TRUE FALSE);

my $window = Gtk2::Window->new('toplevel');
$window->signal_connect('delete_event' => sub { Gtk2->main_quit; });
$window->set_default_size(640, 600);


my $vbox = Gtk2::VBox->new;
$vbox->set_border_width(4);
$vbox->show;

my $hbox = Gtk2::HBox->new(FALSE, 4);
$vbox->pack_start($hbox, FALSE, FALSE, 0);
$hbox->show;


$window->add($vbox);

my $swin = Gtk2::ScrolledWindow->new;
$swin->set_shadow_type('in');
$vbox->pack_start($swin, 1, 1, 0); 


my $cwidth = 1000;
my $cheight = 1000;
my $canvas = Goo::Canvas->new();
$canvas->set_size_request(900, 600); # size on screen
$canvas->set_bounds(0, 0, $cwidth, $cheight); # scrollregion
$swin->add($canvas);

my $root = $canvas->get_root_item();

#####################################################
# if you want to test a map
# my $im = Gtk2::Gdk::Pixbuf->new_from_file("usa.png");
# my $w = $im->get_width;
# my $h = $im->get_height;
# my $image = Goo::Canvas::Image->new(
#            $root, $im, 0, 0,
#            'width' => $w,
#            'height' => $h);

######################################################


my $rect = Goo::Canvas::Rect->new(
    $root, 100, 100, 400, 400,
    'line-width' => 10,
    'radius-x' => 20,
    'radius-y' => 10,
    'stroke-color' => 'yellow',
    'fill-color' => 'red'
);

my $text = Goo::Canvas::Text->new(
    $root, "Start Here", 340, 170, -1, 'center',
    'font' => 'Sans 24',
    "fill-color" => "midnightblue",
);
#$text->rotate(45, 300, 300);

$canvas->signal_connect('button-press-event',
                      \&on_can_button_press);

my $way_ref = [ 340, 170,
          340, 230,
          390, 230,
          390, 170 ];

push @$way_ref,200,300; # shows pushing works

#my $points = Goo::Canvas::Points->new([100, 100, 200, 200]);
my $points = Goo::Canvas::Points->new($way_ref);

my $line = Goo::Canvas::Polyline->new(
        $root, FALSE,
         undef, # points need to be set after creation
        'stroke-color' => 'black',
        'line-width' => 3,
        'start-arrow' => TRUE,
        'end-arrow' => TRUE,
        'arrow-tip-length' => 3,
        'arrow-length' => 4,
        'arrow-width' => 3.5
    );

# setting after line creation, sets the 'points' property by name
$line->set(points => $points);


# Zoom
my $z = Gtk2::Label->new("Zoom:");
$hbox->pack_start($z, FALSE, FALSE, 0);
$z->show;

my $adj = Gtk2::Adjustment->new(1, 0.05, 100, 0.05, 0.5, 0.5);
my $sb = Gtk2::SpinButton->new($adj, 0, 2);
$adj->signal_connect("value-changed", \&zoom_changed, $canvas);
$sb->set_size_request(60, -1);
$hbox->pack_start($sb, FALSE, FALSE, 10);
$sb->show;


# Create SVG                                                          
+                
my $sbsvg = Gtk2::Button->new_with_label('Write SVG');                
+                       
$hbox->pack_start($sbsvg, FALSE, FALSE, 0);                           
+                    
$sbsvg->show;                                                         
+                    
$sbsvg->signal_connect("clicked", \&write_svg_clicked, $canvas);      
+                    
    
# Create PDF                                                          
+                
my $bpdf = Gtk2::Button->new_with_label('Write PDF');                 
+                      
$hbox->pack_start($bpdf, FALSE, FALSE, 0);                            
+                   
$bpdf->show;                                                          
+                   
$bpdf->signal_connect("clicked", \&write_pdf_clicked, $canvas);       
+  


$window->show_all();
Gtk2->main;

sub on_can_button_press {
     my ( $widget, $event ) = @_;
#     print $widget ,' ',$event->type,"\n";
      my ($x,$y) = ($event->x,$event->y);
      print "$x  $y\n";


     my $scale = $adj->get_value;
     print "scale->$scale\n"; 
     
     my $scaled_x = $scale * $x;
     my $scaled_y = $scale * $y;
     print 'scaled  ',$scaled_x,'  ',$scaled_y,"\n";
      
     push @$way_ref,$x/$scale,$y/$scale;
      
      # won't work
      #$points->set(points => $way_ref); # Points can't be changed
      # need to create a new set
      my $points = Goo::Canvas::Points->new($way_ref);
      #works    
      $line->set(points => $points);

    return TRUE;
}


sub write_svg_clicked {
    my ($but, $canvas) = @_;
    print "Write SVG...\n";
    
    my $scale = $adj->get_value;
    print "scale->$scale\n"; 
    
    my $surface = Cairo::SvgSurface->create("$0-$scale.svg", 
                    $scale*$cwidth, $scale*$cheight);

    my $cr = Cairo::Context->create($surface);

    $cr->set_source_rgb( 1, 1, 1 );
    $cr->fill;
    $cr->set_source_rgb( 0, 0, 0 );


    # needed to save scaled version
    $cr->scale($scale, $scale);
     
    #print $canvas->get_bounds,"\n";
     
     $canvas->render($cr, undef, 1);
#    $canvas->render ($cr, $bounds, $scale) 

    $cr->show_page;

    print $canvas->get_scale,"\n";
    print "done\n";

    return TRUE;
}

sub write_pdf_clicked {
    my ($but, $canvas) = @_;
    print "Write PDF...\n";

    my $scale = $adj->get_value;
    print "scale->$scale\n"; 
    
    my $surface = Cairo::PdfSurface->create("$0-$scale.pdf", 
                    $scale*$cwidth, $scale*$cheight);
    
    my $cr = Cairo::Context->create($surface);

    # needed to save scaled version
    $cr->scale($scale, $scale);

    $canvas->render($cr, undef, 1);
    $cr->show_page;
    print "done\n";
    return TRUE;
}


sub zoom_changed {
    my ($adj, $canvas) = @_;
    $canvas->set_scale($adj->get_value);
}