Save GooCanvas2 to PNG file - perl

After drawing with GooCanvas2, I'm trying to take a 'screenshot' of the canvas and save it to a .PNG file.
This script provides a very nice example using Gtk2/GooCanvas, but having converted that script to Gtk3/GooCanvas2, I get an error that I don't understand:
Write PNG...
*** unhandled exception in callback:
*** `need' is not a valid cairo_status_t value; valid values are: success, no-memory, invalid-restore, invalid-pop-group, no-current-point, invalid-matrix, invalid-status, null-pointer, invalid-string, invalid-path-data, read-error, write-error, surface-finished, surface-type-mismatch, pattern-type-mismatch, invalid-content, invalid-format, invalid-visual, file-not-found, invalid-dash, invalid-dsc-comment, invalid-index, clip-not-representable, temp-file-error, invalid-stride, font-type-mismatch, user-font-immutable, user-font-error, negative-count, invalid-clusters, invalid-slant, invalid-weight at goopng2.pl line 90.
*** ignoring at /usr/share/perl5/Gtk3.pm line 546.
The error is generated by Gtk3::Gdk::PixbufLoader->write(). I have not modified that function at all:
$surface->write_to_png_stream (sub {
my ($closure, $data) = #_;
$loader->write($data);
});
And this is the converted script:
#!/usr/bin/perl -w
use strict;
use warnings;
use GooCanvas2;
use Gtk3 '-init';
use Glib qw(TRUE FALSE);
my $window = Gtk3::Window->new('toplevel');
$window->signal_connect('delete_event' => sub { Gtk3->main_quit; });
$window->set_default_size(640, 600);
my $vbox = Gtk3::VBox->new;
$vbox->set_border_width(4);
$vbox->show;
$window->add($vbox);
my $swin = Gtk3::ScrolledWindow->new;
$swin->set_shadow_type('in');
$vbox->pack_start($swin, 1, 1, 0);
my $canvas = GooCanvas2::Canvas->new();
$canvas->set_size_request(600, 450);
$canvas->set_bounds(0, 0, 1000, 1000);
$swin->add($canvas);
my $root = $canvas->get_root_item();
my $rect = GooCanvas2::CanvasRect->new(
parent => $root,
'x' => 100,
'y' => 100,
'width' => 400,
'height' => 400,
'line-width' => 10,
'radius-x' => 20,
'radius-y' => 10,
'stroke-color' => 'yellow',
'fill-color' => 'red'
);
my $text = GooCanvas2::CanvasText->new(
'parent' => $root,
'text' => "Hello World",
'x' => 300,
'y' => 300,
'width' => -1,
'anchor' => 'center',
'font' => 'Sans 24',
);
$text->rotate(45, 300, 300);
# Create PNG
my $sb = Gtk3::Button->new_with_label('Write PNG and JPG');
$vbox->pack_start($sb, FALSE, FALSE, 0);
$sb->show;
$sb->signal_connect("clicked", \&write_png_clicked, $canvas);
$window->show_all();
Gtk3->main;
sub write_png_clicked {
my ($but, $canvas) = #_;
print "Write PNG...\n";
my $surface = Cairo::ImageSurface->create ('rgb24', 1000, 1000);
# also argb32 is available
# my $surface = Cairo::ImageSurface->create ('argb32', 1000, 1000);
my $cr = Cairo::Context->create($surface);
# make a background rectangle filled white so saved file looks same as screen
# otherwise a black background may appear, it's like pdf, if it isn't
# drawn , it will be a black background, It won't automagically pick up
# a white background on a canvas
$cr->rectangle( 0, 0, 1000, 1000 );
$cr->set_source_rgb( 1, 1, 1 );
$cr->fill;
$canvas->render($cr, undef, 1);
# this works, but see below for way to use pixbuf and jpg
# my $status = $surface->write_to_png ("$0.png");
# print "$status\n";
my $loader = Gtk3::Gdk::PixbufLoader->new;
$surface->write_to_png_stream (sub {
my ($closure, $data) = #_;
$loader->write($data);
});
$loader->close;
my $pixbuf = $loader->get_pixbuf;
print $pixbuf->get_bits_per_sample(),"\n";
print $pixbuf->get_colorspace(),"\n";
$pixbuf->save ("$0.png", 'png');
print "done png\n";
$pixbuf->save ("$0.jpg", 'jpeg', quality => 100);
print "done jpg\n";
return TRUE;
}

* unhandled exception in callback:
* `need' is not a valid cairo_status_t value; valid values are: success, no-memory, [...] at goopng2.pl line 90.
*** ignoring
at /usr/share/perl5/Gtk3.pm line 546.
By running the debugger on your code I could see that $loader->write($data) raised an exception:
need an array ref to convert to GArray
and write_to_png_stream() was not expecting this type of exception and truncated the message to the first word "need" as you can see from Glib error message at the top: `need' is not a valid cairo_status_t value ...
By some trial and error I found that I could pass the $buffer argument as an array of characters and not as a perl string:
sub write_png_clicked {
my ($but, $canvas) = #_;
print "Write PNG...\n";
my $surface = Cairo::ImageSurface->create ('rgb24', 1000, 1000);
my $cr = Cairo::Context->create($surface);
$cr->rectangle( 0, 0, 1000, 1000 );
$cr->set_source_rgb( 1, 1, 1 );
$cr->fill;
$canvas->render($cr, undef, 1);
my $loader = Gtk3::Gdk::PixbufLoader->new;
$surface->write_to_png_stream (
sub {
my ($loader, $buffer) = #_;
$loader->write([map ord, split //, $buffer]);
return TRUE;
}, $loader
);
$loader->close;
my $pixbuf = $loader->get_pixbuf;
print $pixbuf->get_bits_per_sample(),"\n";
print $pixbuf->get_colorspace(),"\n";
$pixbuf->save ("test.png", 'png');
print "done png\n";
$pixbuf->save ("test.jpg", 'jpeg', quality => 100);
print "done jpg\n";
return TRUE;
}
Edit:
To save only a part of the canvas you can pass a GooCanvasBounds parameter to the render() method:
my $bounds = GooCanvas2::CanvasBounds->new();
$bounds->x1(50);
$bounds->x2(250);
$bounds->y1(50);
$bounds->y2(250);
$canvas->render($cr, $bounds, 1);
Edit 2:
To capture a region at a specific position and a specific width and height:
my $img_width = 200;
my $img_height = 200;
my $img_x0 = 100;
my $img_y0 = 100;
my $surface = Cairo::ImageSurface->create ('rgb24', $img_width, $img_height);
$cr->translate(-$img_x0,-$img_y0);
$canvas->render($cr, undef, 1);

Related

Invalid Content-Type 'multipart/; boundary

I am using Perl and Email::MIME to access an email account via IMAP. When I try to download the attachment, I get this error:
Invalid Content-Type 'multipart/;
boundary="===============6113972194662902815=="' at
/path/to/class/Reader.pm line 99.
Here is my code:
my $env = $self->env();
my $imap = $self->imap();
my $logger = $self->logger();
my ($OUT, $out_file);
# parse attachment
my $message_string = $imap->message_string($imap_id);
Email::MIME->new($message_string)->walk_parts(sub {
my ($part) = #_;
if ($part->content_type =~ /octet\-stream/) {
($OUT, $out_file) = tempfile();
binmode $OUT;
print $OUT $part->body;
close $OUT;
$logger->info("downloaded attached report: [$out_file]");
}
});
Here is the end of the dump of the $part:
MixOLE4sTiwwLE4NCiI9IiIyMDE4LTA0LTE5IDA5OjU5OjI5LjQ5NCIiIixhZTJhNDEzMy1hYWRj
LTQ4ZjgtYWY0My1jYjdhMGEzYzQzMzIsIkFwcGxpYW5jZSBwYXJ0cywgaG91c2Vob2xkIixBcHBs
aWFuY2UgU2FsZXMsTUlETE9USElBTixWQSxWYWN1dW0gU3lzdGVtcyw4MDQ1NDg0MTgxLCAsYTEx
OGUxODIyMTAwNzJkYSxEVVJBVElPTiw0NSwyLjQ3ODQsTixOLE4sMCxODQoiPSIiMjAxOC0wNC0x
OSAwOTo1OToyOS45MSIiIiwxZTNlZGQzZi02NGM0LTQ3M2UtODk2Yy00MTI3ZTVhYzIwYWUsRklO
QU5DRXxGSU5BTkNJQUwgSU5TVElUVVRJT05TfEJBTktTLEJhbmtzLEdSRUVOU0JVUkcsUEEsRmly
c3QgRmVkZXJhbCBTYXZpbmdzICYgTG9hbiBBc3NvY2lhdGlvbiBPZiAgR3JlZW4sODQ0MjU1MTk0
MSwgLDgzNDA0NmQ2MWEyYzRkY2UsRFVSQVRJT04sNDUsNS4wLE4sTixOLDAsTg0KIj0iIjIwMTgt
MDQtMTkgMDk6NTk6MjkuOTE1IiIiLGY1YTBmOTc1LTg1MmUtNDAwNC05YTY1LWEzYzgyNDJlYTQy
NywiaW5zdXJhbmNlLCBsZW5kZXJzLCBtb3J0Z2FnZXMiLExvYW5zICYgTW9ydGdhZ2VzLE1hbmFz
cXVhbixOSixDb21tZXJjaWFsIE1vcnRnYWdlIEFzc29jaWF0ZXMgSW5jLiw3MzI0NTEzMzU0LCAs
ZGQ5YTQ4OGVmYjJiY2NlMSxEVVJBVElPTiw0NSwzLjQ0MzUsTixOLE4sMCxODQo=
--===============6113972194662902815==--
",
ct => {
attributes => {
charset => "us-ascii"
},
composite => "plain",
discrete => "text",
subtype => "plain",
type => "text"
},
encode_check => 1,
header => Email::MIME::Header,
mycrlf => "
",
parts => []
}
}
I have tried several different methods of downloading this file and I keep getting that error. Let me know if there are any questoins

Add several records in moodle

I've been having trouble adding items in my table in moodle, this is what I've trying with no success.
$totalrec = array();
$rec2 = $DB->get_records('table1', null, '', '*', 0, 0);
$rec4 = $DB->get_records('table2', array('x' => 'y') , '', '*', 0, 0);
foreach ($rec2 as $records2) {
$rec3 = $DB->get_records('z', array('m' => 'n') , '', '*', 0, 0);
foreach ($rec3 as $records3) {
if (isset($_REQUEST['a']) && isset($_REQUEST['b'])) {
$ca = $_REQUEST['a'];
$co = $_REQUEST['b'];
$pi = $records2->idp;
$recorsh = new class ();
$recorsh->id = $records2->id;
$recorsh->te = $co;
$recorsh->idt = $ti;
$recorsh->res = $ca;
$recorsh->ida = $idaud;
$totalrec[$n] = array($recorsh);
$n++;
}
}
}
$lastinsertid2 = $DB->insert_records('table4', $totalrec);
and, this one:
$rec2 = $DB->get_records('table1', null, '', '*', 0, 0);
$rec4 = $DB->get_records('table2', array('x' => 'y') , '', '*', 0, 0);
foreach($rec2 as $records2) {
$rec3 = $DB->get_records('z', array('m' => 'n') , '', '*', 0, 0);
foreach($rec3 as $records3) {
if (isset($_REQUEST['a']) && isset($_REQUEST['b'])) {
$ca = $_REQUEST['a'];
$co = $_REQUEST['b'];
$pi = $records2->idp;
$recorsh = new class ();
$recorsh->id = $records2->id;
$recorsh->te = $co;
$recorsh->idt = $ti;
$recorsh->res = $ca;
$recorsh->ida = $idaud;
$lastinsertid = $DB->insert_record('table4', $recorsh, false);
}
}
}
Both of them gives me a "Error writing to database" but doesn't say anything specific, I know that I'm not doing the inserting "in the right way" but I don't know how to do it, what am I doing wrong?
It's probably because the ID is added to each object before inserting.
$recorsh->id = $records2->id;
Like davosmith says, during development always have debugging set to developer level.
In your config.php have this
error_reporting(E_ALL | E_STRICT);
ini_set('display_errors', 0);
$CFG->debug = E_ALL | E_STRICT; // 32767;
$CFG->debugdisplay = true;
Also never ever use $_REQUEST or $_GET or $_POST directly. This can introduce SQL injection.
Use
$a = optional_param('a', null, PARAM_XXX);
$b = optional_param('b', null, PARAM_XXX);
or
$a = required_param('a', PARAM_XXX);
$b = required_param('b', PARAM_XXX);
Change PARAM_XXX to the type of parameter you are expecting. eg PARAM_INT, PARAM_BOOL etc.

Perl Tk Label change background color associate with textvariable

How to automatically change the label background color associate with textvariable?
i.e when textvariable is positive value , background change to green. When it is minus value, it automatically change to red. Pls advise.
use strict;
use Tk;
my $mw = new MainWindow(-title => "TTTT",
);
$mw->geometry( "400x300" );
my $LAST1 ;
my $bgclr = 'green';
my $label1 = $mw->Label ( -textvariable=>\$LAST1, -fg=>'White',
-font=> 'arial 20',
-bg => $bgclr,
);
$label1->place(-x=>10, -y => 65);
$mw->repeat(2000,\&tick);
MainLoop;
sub tick {
my $AA= '9.16';
my $sum = '235.72';
my $avge = (($sum + $AA) / 25);
my $RR = ((($AA - $avge) / $avge) *100);
$LAST1 = $RR;
}
I would recommend using an Treads and Tread::Shared in a large scale programs in order to update the Main GUI while running an external subs.
But for your example this might be enough to start with.
Here is a sample code base on your provide code:
use strict;
use Tk;
our $time_tick = 1;
our $label1;
our $Pos_Color = 'green';
our $Neg_Color = 'red';
my $mw = new MainWindow(-title => "TTTT",
);
$mw->geometry( "400x300" );
my $LAST1 ;
my $bgclr = $Pos_Color;
$label1 = $mw->Label ( -textvariable=>\$time_tick, -fg=>'White',
-font=> 'arial 20',
-bg => $bgclr,
);
$label1->place(-x=>10, -y => 65);
$mw->repeat(2000,\&tick);
MainLoop;
sub tick {
$time_tick = $time_tick * -1;
if ($time_tick > 0)
{
$label1->configure(-bg => $Pos_Color);
}
else
{
$label1->configure(-bg => $Neg_Color);
}
}

Perl Tkx entry validation not working

I am having an issue getting my text validation to work properly. Basically I have 2 entry boxes, one to enter the name of a branch in CVS and the other to enter a directory name. I want my program to validate the text in each box whenever it is changed.
To do this, the documentation online says to use the "key" option to validate the entry whenever a keystroke changes the entry box's contents. The problem is, when I use the "key" option and then run the program, when I type into the entry boxes no text appears.
My code is shown below:
use strict;
use warnings;
use Tkx;
# Initialize BRANCH and DIRECTORY
my ($BRANCH, $DIRECTORY) = ();
# DEFINE DISPLAY OBJECTS ###########################################################################
# Define main window
my $main_window = Tkx::widget->new('.');
# Define content frame
my $content_frame = $main_window->new_ttk__frame(-padding => '5 5 5 5');
# Define labels
my $branch_label = $content_frame->new_ttk__label(-text => 'Branch' );
my $directory_label = $content_frame->new_ttk__label(-text => 'Directory');
# Define entry boxes
my $branch_entry = $content_frame->new_ttk__entry(-width => 20, -textvariable => \$BRANCH , -validate => 'key', -validatecommand => \&check_state);
my $directory_entry = $content_frame->new_ttk__entry(-width => 20, -textvariable => \$DIRECTORY, -validate => 'key', -validatecommand => \&check_state);
# Define buttons
my $generate_list_button = $content_frame->new_ttk__button(-text => 'Generate', -state => 'disabled', -command => \&generate_list);
# POSITION DISPLAY OBJECTS #########################################################################
# Position content frame
$content_frame->g_grid(-column => 0, -row => 0);
# Position labels
$branch_label ->g_grid(-column => 0, -row => 0);
$directory_label->g_grid(-column => 0, -row => 1);
# Position entry boxes
$branch_entry ->g_grid(-column => 1, -row => 0);
$directory_entry->g_grid(-column => 1, -row => 1);
# Position buttons
$generate_list_button->g_grid(-column => 0, -row => 2, -columnspan => 2);
# Add padding
for my $child (Tkx::SplitList($content_frame->g_winfo_children)) {
Tkx::grid_configure($child, -padx => 5, -pady => 5);
}
# Check the state of the program
sub check_state {
# Check conditions are met to enable generate_list
if ($BRANCH && $DIRECTORY) {
if (-d $DIRECTORY) {
$generate_list_button->state('!disabled');
} else {
$generate_list_button->state('disabled');
}
} else {
$generate_list_button->state('disabled');
}
return 0;
}
Tkx::MainLoop();
If I change "key" to something else (like focusout) it appears to work correctly. But I would really like it to validate after every keystroke instead of just when the focus is taken out of the entry box. Why doesn't this work?
Your check_state subroutine always returns 0 which means "validation failed" and prevents
the text from being entered. Since you aren't really validating the text -- just using the validation mechanism to trigger state updates to related widgets -- you should return 1 (unconditionally) instead. See validatecommand in the (Tcl) Tk documentation for more details.
The subroutines returning 0 turned out to be only half the problem. Once I fixed that the entry validation was not acting properly. What was happening was every time it tried to validate the entry it would actually be validating the previous entry.
ex:
If you typed in "/somedirectory" it would try to validate on every keystroke, after the last keystroke of "y" it would get the value of $DIRECTORY and validate against it. The problem was that at this point $DIRECTORY would be equal to "/somedirector"
To solve this issue I had to do a little digging so I wanted to post my findings in case someone else ran into this same issue.
The solution was to use Tkx::Ev() to get the "current" value of the entry as it was being entered.
(Tkx::Ev(%P) gets the newly entered value so the validation will work properly)
# Define the entry box
my $directory_entry = $content_frame->new_ttk__entry(
-width => 20,
-textvariable => \$DIRECTORY,
-validate => 'key',
-validatecommand => [\&check_dir, Tkx::Ev('%P')],
);
# Validate the entry box
sub check_dir {
# Unpack input arguments
my ($P) = #_;
if (-d $P) {
# Do something here
} else {
# Do something else here
}
return 1;
}

Why is the server returned the result for a different submit than selected by perl HTML::Form and LWP::UserAgent?

I want to process a number of files with http://2struc.cryst.bbk.ac.uk/twostruc; to automate this I wrote a perl script using perl's HTML::Form.
This server has a two step submit process: first, upload a file or enter an id; second, select the methods to be used and the output (by chosing one of five submits).
The first step works, but for the second step I seem to be unable to chose any submit button other than the first, even though my script output confirms that I selected the one I want (different from the first).
The two core parts of the code are below, the request function:
sub create_submit_request
{
my $form_arrayref = shift;
my $form_action = shift;
my $value_hashref = shift;
my $submit_name = shift;
my $submit_index = shift;
my $found_form = 0;
my $form;
foreach my $this_form( #$form_arrayref)
{
printf( "# Found form with action=%s\n", $this_form->action);
if( $this_form->action eq $form_action)
{
$found_form = 1;
$form = $this_form;
}
}
die( "# Error: No form with action $form_action") if( $found_form == 0);
my #inputs = $form->inputs;
my $inputs_string;
foreach my $input( #inputs)
{
my $input_name = defined( $input->name) ? $input->name : "<unnamed_input>";
my $input_value = defined( $input->value) ? $input->value : "";
$inputs_string .= $input_name.( length( $input_value) > 0 ? "=".$input_value : "")." (".$input->type."); ";
}
printf( "# Available input names: %s\n", $inputs_string);
printf( "# Filling in form data\n");
while( my( $key, $value) = each( %$value_hashref))
{
$form->value( $key, $value);
}
my #submit_buttons = $form->find_input( $submit_name, "submit", $submit_index); # 1-based counting for the index
die( "# Error: Can only handle a single submit, but found ".scalar( #submit_buttons)) if( scalar( #submit_buttons) != 1);
my %submit_hash = %{ $submit_buttons[ 0]};
# DEBUG
printf( "# Use submit: %s\n", Data::Dumper->Dump( [ \%submit_hash ]));
return $form->click( %submit_hash);
}
and the code using it:
my $request = HTTP::Request->new( GET => $url_server);
my $response = $useragent->request( $request);
# the first page contains the pdb id input and file upload inputs
my #forms = HTML::Form->parse( $response);
my %value_hash = ( "file" => $pdb_file);
# the submit buttons have no name, use undef; chose the first one (w/o javascript)
$request = create_submit_request( \#forms, $form_action1, \%value_hash, undef, 1);
printf( "# Submitting to server\n");
$response = $useragent->request( $request);
# the first page contains the pdb id input and file upload inputs
#forms = HTML::Form->parse( $response);
%value_hash =( "dsspcont" => "on", "stride" => "on");
# this form has 5 submit buttons; select the 5th
$request = create_submit_request( \#forms, $form_action2, \%value_hash, undef, 5);
printf( "# Submitting to server\n");
$response = $useragent->request( $request);
my $response_content = $response->content;
printf( "# Response content: %s\n", $response_content);
Even though the script prints
# Use submit: $VAR1 = {
'name' => 'function_sequenceStructureAlignment',
'onclick' => 'this.form.target=\'_blank\';return true;',
'type' => 'submit',
'value' => 'Sequence Structure Alignments',
'value_name' => ''
};
which is the 5th submit button in the second step, the response is equivalent to pressing the first submit button.
To test the server itself, the file 1UBI.pdb can be downloaded from http://www.rcsb.org/pdb/files/1UBI.pdb and uploaded to the server. The full script is at http://pastebin.com/bSJLvNfc and can be run with
perl 2struc.pl --pdb 1UBI.pdb
Why is the server returning a different output/submit that I seem to select in the script?
(It seems it's not dependend on cookies, because I can clear them after the first step, and still get the correct result for the second step in a web browser.)
You gave a hash as selector for click, which is wrong (see documentation how to specify the selector). But because you have already found the correct submit element you could simply call click directly on it:
--- orig.pl
+++ fixed.pl
## -87,7 +87,7 ##
# DEBUG
printf( "# Use submit: %s\n", Data::Dumper->Dump( [ \%submit_hash ]));
- return $form->click( %submit_hash);
+ return $submit_buttons[0]->click($form);
}
sub predict_pdb