Change font size for a TextView widget in a running Gtk3 Perl app - perl

I'm trying to modify the font size, in a TextView widget, in a running Perl application and I'm having a difficult time of it. Here's one of my attempts(the relevant code is in the function setFontSize).
#! /usr/bin/env perl
use feature qw(state);
use local::lib;
use warnings;
use strict;
use utf8;
use constant MAX_FONT_SIZE => 200;
use constant MIN_FONT_SIZE => 12;
use constant FONT_UNIT => 4;
use Glib qw(TRUE FALSE);
use Gtk3 qw(init);
use Pango;
sub killKey {
my ($object, $event) = #_;
my $c = lc chr ($event->keyval);
Gtk3->main_quit if $c eq 'q';
FALSE;
}
sub setFontSize {
my ($tView, $font_size) = #_;
my $pCont = $tView->get_pango_context();
my $fDescr = $pCont->get_font_description();
$fDescr->set_absolute_size($font_size * Pango::SCALE);
my $buf = $tView->get_buffer();
my $end = $buf->get_end_iter();
my $start = $buf->get_start_iter();
my $str = $buf->get_text($start, $end, TRUE);
my $newBuf = Gtk3::TextBuffer->new();
$newBuf->set_text($str);
#$buf->set_text($buf->get_text($start, $end, TRUE), -1);
$tView->set_buffer($newBuf);
STDOUT->print("called: ", $fDescr->to_string(),"\n");
# {
# no strict "refs";
#
# for my $elem (sort keys %{ref($fDescr)."::"}) {
# STDOUT->print("${elem}\n");
# }
# }
}
sub catchScroll {
my ($object, $event, $tView) = #_;
state $font_size = 40;
my $dir = $event->direction;
my ($ctrl, $mod) = #{$event->state};
if ($ctrl eq q<control-mask> && $mod eq q<mod2-mask>) {
if ($dir eq q<up>) {
$font_size += FONT_UNIT if $font_size < MAX_FONT_SIZE;
setFontSize($tView, $font_size);
return FALSE;
}elsif ($dir eq q<down>) {
$font_size -= FONT_UNIT if $font_size > MIN_FONT_SIZE;
setFontSize($tView, $font_size);
return FALSE;
}
}
FALSE;
}
my $window = Gtk3::Window->new(q<toplevel>);
my $scrWin = Gtk3::ScrolledWindow->new();
my $tView = Gtk3::TextView->new();
my $provider = Gtk3::CssProvider->new();
$provider->load_from_path("the.css");
my $style = $tView->get_style_context();
$style->add_provider($provider, 600);
my $str = qx(perldoc -T -t -f split 2>&1);
my $buf = $tView->get_buffer();
$buf->set_text($str);
my $sIter = $buf->get_start_iter();
$buf->place_cursor($sIter);
#$tView->set_editable(FALSE);
$window->add_events(q<GDK_KEY_PRESS_MASK>);
$window->add_events(q<GDK_SCROLL_MASK>);
$window->signal_connect(delete_event => sub{Gtk3->main_quit; FALSE});
$window->signal_connect(key_press_event => \&killKey);
$window->signal_connect(scroll_event => \&catchScroll, $tView);
$window->set_border_width(0);
$window->fullscreen();
$window->set_decorated(FALSE);
$scrWin->add($tView);
$window->add($scrWin);
$window->show_all;
Gtk3->main;
I can hack the font values from the provider and it works perfectly... Kind of makes you wonder why the Gtk3 folks don't have that functionality available for these types of problems.
the.css
text {
background-color: rgb(0,0,0);
color: rgb(0, 255, 0);
}
textview {
font-size: 40px;
}
The final version: I added CSS::Tiny to handle the css in provider and added functionality to freeze the vertical scroll bar while I modify the font size with Ctrl+mouse wheel.
#! /usr/bin/env perl
use feature qw(state);
use warnings;
use strict;
use utf8;
use constant MAX_FONT_SIZE => 200;
use constant MIN_FONT_SIZE => 20;
use constant FONT_UNIT => 4;
use constant FONT_START_SIZE => 40;
use CSS::Tiny;
use Glib qw(TRUE FALSE);
use Gtk3 qw(init);
sub killKey {
my ($object, $event) = #_;
my $c = lc chr ($event->keyval);
Gtk3->main_quit if $c eq 'q';
}
sub changeFontSize {
my ($style, $provider, $font_size) = #_;
my $cssStr = $provider->to_string();
my $css = CSS::Tiny->new();
$css = CSS::Tiny->read_string($cssStr);
$css->{textview}->{q<font-size>} = "${font_size}px";
$style->remove_provider($provider);
$provider = Gtk3::CssProvider->new();
$provider->load_from_data($css->write_string());
$style->add_provider($provider, 600);
}
sub catchScroll {
my ($object, $event, $data) = #_;
my ($style, $provider, $vadj) = #{$data};
my ($ctrl, $mod) = #{$event->state};
my $dir = $event->direction;
my $retval = Gtk3::get_current_event();
state $font_size = FONT_START_SIZE;
if ($ctrl eq q<control-mask> && $mod eq q<mod2-mask>) {
if ($dir eq q<up>) {
$font_size += FONT_UNIT if $font_size < MAX_FONT_SIZE;
changeFontSize($style, $provider, $font_size);
}elsif ($dir eq q<down>) {
$font_size -= FONT_UNIT if $font_size > MIN_FONT_SIZE;
changeFontSize($style, $provider, $font_size);
}else {
}
$vadj->set_value(0.0);
}
FALSE;
}
my $window = Gtk3::Window->new(q<toplevel>);
my $scrWin = Gtk3::ScrolledWindow->new();
my $tView = Gtk3::TextView->new();
my $provider = Gtk3::CssProvider->new();
$provider->load_from_path(q<the.css>);
my $style = $tView->get_style_context();
$style->add_provider($provider, 600);
my $str = qx(perldoc -T -t -f split 2>&1);
my $buf = $tView->get_buffer();
$buf->set_text($str);
my $sIter = $buf->get_start_iter();
$buf->place_cursor($sIter);
$tView->set_editable(FALSE);
$window->add_events(q<GDK_KEY_PRESS_MASK>);
$window->add_events(q<GDK_SCROLL_MASK>);
$window->signal_connect(delete_event => sub{Gtk3->main_quit; FALSE});
$window->signal_connect(key_press_event => \&killKey);
$window->signal_connect(
scroll_event =>
\&catchScroll,
[$style, $provider, $scrWin->get_vadjustment()]
);
$window->set_border_width(0);
$window->set_position(q<center>);
$window->fullscreen();
$window->set_decorated(FALSE);
$scrWin->add($tView);
$window->add($scrWin);
$window->show_all();
Gtk3->main;
the.css
text {
background-color: rgb(0, 0, 0);
color: rgb(0, 255, 0);
}
textview {
font-size: 40px;
}

Currently I am not able to make the Pango font description to work either. Seems like it is difficult to find a good documentation of how this is supposed to work :)
Anyway, as a workaround, a CSS provider can be used:
sub setFontSize {
my ($tView, $font_size) = #_;
state $provider;
my $context = $tView->get_style_context();
if ( $provider ) {
$context->remove_provider( $provider );
}
$provider = Gtk3::CssProvider->new();
my $css = sprintf "textview {font-size: %spx;}", $font_size;
$provider->load_from_data($css);
$context->add_provider($provider, Gtk3::STYLE_PROVIDER_PRIORITY_APPLICATION);
}

Related

PERL tk module handling

I am using tk module to build a checklist for user to choose. I am totally beginner to this module. Currently the checklist created is all in the same series column, since it will be a long list, any idea how could I separate few of the options to another column? Also, any idea how to align those text to the left while checkbox to the right? To display it cleanly and neatly.
#!/usr/bin/perl
use Tk;
$main = MainWindow->new();
$label = $main->Label(-text => "Presence Check");
$label->pack();
$frame = $main->Frame(-relief=>"groove", -borderwidth=>2);
#$frame = $main->Frame(-relief=>"groove", -borderwidth=>2)->pack(-side => 'top', -expand => 1, -fill =>'both');
#$frame = $main->Frame->pack(-side => 'left', -fill => 'x');
$check1 = $frame->Checkbutton(-text=>"Document A (docx, pdf)",
-variable=>\$a,
-onvalue=>"APRESENT",
-offvalue=>"AABSENT");
#$check1->pack(-side=>"top");
$check2 = $frame->Checkbutton(-text=>"Document B (xlsx)",
-variable=>\$b,
-onvalue=>"BPRESENT",
-offvalue=>"BABSENT");
$check2->pack(-side=>"top");
$check3 = $frame->Checkbutton(-text=>"C specification",
-variable=>\$c,
-onvalue=>"CPRESENT",
-offvalue=>"CABSENT");
$check3->pack(-side=>"top");
$check4 = $frame->Checkbutton(-text=>"A-Specification",
-variable=>\$aspec,
-onvalue=>"ASPECPRESENT",
-offvalue=>"ASPECSABSENT");
$check4->pack(-side=>"top");
$check5 = $frame->Checkbutton(-text=>"Important Report",
-variable=>\$report,
-onvalue=>"REPORTPRESENT",
-offvalue=>"REPORTSABSENT");
$check5->pack(-side=>"top");
$check6 = $frame->Checkbutton(-text=>"Handbook",
-variable=>\$handbook,
-onvalue=>"HANDBOOKPRESENT",
-offvalue=>"HANDBOOKABSENT");
$check6->pack(-side=>"top");
$check7 = $frame->Checkbutton(-text=>"Data Spreadsheet",
-variable=>\$dataxls,
-onvalue=>"DATAPRESENT",
-offvalue=>"DATAABSENT");
$check7->pack(-side=>"top");
$check8 = $frame->Checkbutton(-text=>"D file",
-variable=>\$dfile,
-onvalue=>"DFILEPRESENT",
-offvalue=>"DFILEABSENT");
$check8->pack(-side=>"top");
$check10 = $frame->Checkbutton(-text=>"xx doc",
-variable=>\$xxdoc,
-onvalue=>"XXDOCPRESENT",
-offvalue=>"XXDOCABSENT");
$check10->pack(-side=>"top");
$check18 = $frame->Checkbutton(-text=>"yy Doc",
-variable=>\$yydoc,
-onvalue=>"YYDOCPRESENT",
-offvalue=>"YYDOCABSENT");
$check18->pack(-side=>"top");
$frame->pack();
$button = $main->Button(-text => "Exit",
-command => \&exit_button);
$button->pack();
MainLoop();
sub exit_button {
print "$a $b $c $aspec $report $handbook $dataxls $dfile $xxdoc $yydoc \n";
#print "$rv\n";
exit,
}
... any idea how could I separate few of the options to another
column? Also, any idea how to align those text to the left while
checkbox to the right?
Here is an example of how you can use the grid geometry manager to align the labels and checkboxes:
use feature qw(say);
use strict;
use warnings;
use Tk;
my $mw = MainWindow->new();
my #label_texts = (
"Document A (docx, pdf)",
"Document B (xlsx)",
"C specification"
);
my #labels;
my #checkvars;
my #check_buttons;
for my $text ( #label_texts ) {
my $label = $mw->Label(-text => $text);
push #labels, \$label;
my $check_var;
my $check = $mw->Checkbutton(
-text=>"",
-variable=>\$check_var,
);
push #checkvars, \$check_var;
push #check_buttons, \$check;
Tk::grid($label, $check, -sticky => 'w');
}
my $button = $mw->Button(
-text => "Exit",
-command => \&exit_button
);
Tk::grid($button, "-");
MainLoop();
sub exit_button {
for my $i (0..$#checkvars) {
my $var = $checkvars[$i];
my $state = $$var;
$state = 'undef' if !defined $state;
say "Variable $i: ", $state;
}
exit;
}
Please see attached screenshot to this code snippet if it is what you desired
!/usr/bin/perl
#
# vim: ai:ts=4:sw=4
#
use strict;
use warnings;
use feature 'say';
use Tk;
use Data::Dumper;
my $main = MainWindow->new( -title => 'Checkboxes' );
my $label = $main->Label(-text => 'Presence Check');
$label->pack();
my $frame = $main->Frame(-relief=>'groove', -borderwidth=>2);
my $values;
my #chk_boxes = (
[\$values->{doc_a},'Document A (docx, pdf)'],
[\$values->{doc_b},'Document B (xlsx)'],
[\$values->{spec_c},'C specification'],
[\$values->{spec_a},'A-Specification'],
[\$values->{report},'Important Report'],
[\$values->{hand_b},'Handbook'],
[\$values->{data_s},'Data Spreadsheet'],
[\$values->{data_d},'D file'],
[\$values->{doc_xx},'xx doc'],
[\$values->{doc_yy},'yy Doc']
);
check_box(\#chk_boxes);
$frame->pack();
my $button = $main->Button(
-text => 'Exit',
-command => \&exit_button
);
$button->pack();
MainLoop();
sub exit_button {
while( my($k,$v) = each %{$values} ) {
say "$k => $v" if $v;
}
exit;
}
sub check_box {
my $data = shift;
my $index = 0;
for my $chk_box ( #{$data} ) {
my $column = $index % 2;
my $row = int($index/2);
$frame->Checkbutton(
-text => $chk_box->[1],
-variable => $chk_box->[0]
)->grid( -column => $column, -row => $row, -sticky => 'w');
$index++;
}
}
Perhaps following form of data input may be preferable
#!/usr/bin/perl
#
# vim: ai:ts=4:sw=4
#
use strict;
use warnings;
use feature 'say';
use Tk;
use Data::Dumper;
my $main = MainWindow->new( -title => 'Checkboxes' );
my $label = $main->Label(-text => 'Presence Check');
$label->pack();
my $frame = $main->Frame(-relief=>'groove', -borderwidth=>2);
my $values;
my #chk_boxes;
while( <DATA> ) {
chomp;
my($var,$desc) = split '\t';
push #chk_boxes, [\$values->{$var}, $desc];
}
check_box(\#chk_boxes);
$frame->pack();
my $button = $main->Button(
-text => 'Exit',
-command => \&exit_button
);
$button->pack();
MainLoop();
sub exit_button {
while( my($k,$v) = each %{$values} ) {
say "$k => $v" if $v;
}
exit;
}
sub check_box {
my $data = shift;
my $index = 0;
for my $chk_box ( #{$data} ) {
my $column = $index % 2;
my $row = int($index/2);
$frame->Checkbutton(
-text => $chk_box->[1],
-variable => $chk_box->[0]
)->grid( -column => $column, -row => $row, -sticky => 'w');
$index++;
}
}
__DATA__
doc_a Document A (docx, pdf)
doc_b Document B (xlsx)
spec_c C specification
spec_a A-Specification
report Important Report
hand_b Handbook
data_s Data Spreadsheet
data_d D file
doc_xx xx Doc
doc_yy yy Doc
Add-on:
sub check_box {
my $data = shift;
my $index = 0;
for my $chk_box ( #{$data} ) {
my $column = $index % 2;
my $row = int($index/2);
my $chk_x = $frame->Checkbutton(
-text => $chk_box->[1],
-variable => $chk_box->[0]
)->grid( -column => $column, -row => $row, -sticky => 'w');
$chk_x->select if $index == 4;
$index++;
}
}

Tail call Recursion "Optimising"

I have a weird problem I can't figure out. I created a simple sequence in Perl with anonymous functions.
sub{($data, sub{($data, sub{($data, sub{($data, empty)})})})};
And it works but I tired to implement tail optimizing and got some weird behaviour. Example. The iter function below works.
sub iter {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
$func->($data);
#_ = ($func, $next);#This #_ update works fine
goto &iter;
}
}
while this implementation of iter fails.
sub iter {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
$func->($data);
$_[1] = $next; #This #_ update fails
goto &iter;
}
}
Both updates of #_ yield the same values for #_ but the code behaves differently when it continues.. To see what I'm talking about try running the complete code below.
#! /usr/bin/env perl
package Seq;
use 5.006;
use strict;
use warnings;
sub empty {
sub{undef};
}
sub add {
my ($data, $seq) = #_;
sub{($data, $seq)};
}
sub iter {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
$func->($data);
#_ = ($func, $next);#This works fine
#$_[1] = $next; #This fails
goto &iter;
}
}
sub smap {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
sub{($func->($data), Seq::smap($func, $next))};
}else {
empty();
}
}
sub fold {
my ($func, $acc, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
#_ = ($func, $func->($acc, $data), $next);
goto &Seq::fold;
}else {
$acc;
}
}
1;
package main;
use warnings;
use strict;
use utf8;
use List::Util qw(reduce);
my $seq =
reduce
{Seq::add($b, $a)}
Seq::empty,
(4143, 1234, 4321, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10);
Seq::iter(sub{my ($data) = #_; STDOUT->print("$data\n")}, $seq);
my $seq2 = Seq::smap(sub{my ($data) = #_; $data * 2}, $seq);
STDOUT->print("\n\n");
Seq::iter(sub{my ($data) = #_; STDOUT->print("$data\n")}, $seq2);
STDOUT->print("\n\n");
my $ans = Seq::fold(sub{my ($acc, $data) = #_; $acc + $data}, 0, $seq);
my $ans2 = Seq::fold(sub{my ($acc, $data) = #_; $acc + $data}, 0, $seq2);
STDOUT->print("$ans\n");
STDOUT->print("$ans2\n");
exit (0);
The code should work for both examples of iter but it doesn't.. Any pointers why?
Writing to $_[1] writes to the second scalar passed to the sub.
$ perl -E'$x = "abc"; say $x; sub { $_[0] = "def"; say $_[0]; }->($x); say $x;'
abc
def
def
So you are clobbering the caller's variables. Assigning to #_ replaces the scalars it contains rather than writing to them.
$ perl -E'$x = "abc"; say $x; sub { #_ = "def"; say $_[0]; }->($x); say $x;'
abc
def
abc
You can replace a specific element using splice.
$ perl -E'$x = "abc"; say $x; sub { splice(#_, 0, 1, "def"); say $_[0]; }->($x); say $x;'
abc
def
abc
It's far more convenient for iterators to return an empty list when they are exhausted. For starters, it allows them to return undef.
Furthermore, I'd remove the expensive recursive calls with quicker loops. These loops can be made particularly simple because of the change mentioned above.
The module becomes:
package Seq;
use strict;
use warnings;
sub empty { sub { } }
sub add {
my ($data, $seq) = #_;
return sub { $data, $seq };
}
sub iter {
my ($func, $seq) = #_;
while ( (my $data, $seq) = $seq->() ) {
$func->($data);
}
}
sub smap {
my ($func, $seq) = #_;
if ( (my $data, $seq) = $seq->() ) {
return sub { $func->($data), smap($func, $seq) };
} else {
return sub { };
}
}
sub fold {
my ($func, $acc, $seq) = #_;
while ( (my $data, $seq) = $seq->() ) {
$acc = $func->($acc, $data);
}
return $acc;
}
1;
Also, for speed reasons, replace
sub { my ($data) = #_; $data * 2 }
sub { my ($acc, $data) = #_; $acc + $data }
with
sub { $_[0] * 2 }
sub { $_[0] + $_[1] }

Gtk3 TextView modifying font size and keeping the current visible text on screen

I'm working with a Textview widget and I can modify the font-size of the Textview widget with the Ctrl key + mouse scroll wheel but my displayed text scrolls when I do it.... How do I keep the current text from scrolling up or down while I modify the font size of the Textview widget?
A few notable things about the code. The font-size is changed via styles and provider because I can't figure out how to get Pango to work with a TextView widget. I hardwired the code to retrieve some data from my $str = qx(perldoc -T -t -f split 2>&1)... You'll probably have to change this to your own data source.
#! /usr/bin/env perl
use feature qw(state);
use warnings;
use strict;
use utf8;
use CSS::Tiny;
use constant FONT_UNIT => 4;
use constant MAX_FONT_SIZE => 200;
use constant MIN_FONT_SIZE => 12;
use Glib qw(TRUE FALSE);
use Gtk3 qw(init);
sub killKey {
my ($object, $event) = #_;
my $c = lc chr ($event->keyval);
Gtk3->main_quit if $c eq 'q';
FALSE;
}
sub changeFontSize {
my ($font_size, $amount) = #_;
$font_size += $amount;
$font_size .= "px";
$font_size;
}
sub changeStyle {
my ($css, $provider, $style) = #_;
$style->remove_provider($provider);
$provider->load_from_data($css->write_string);
$style->add_provider(
$provider,
Gtk3::STYLE_PROVIDER_PRIORITY_APPLICATION
);
}
sub catchScroll {
my ($object, $event, $data) = #_;
my ($css, $provider, $style) = #{$data};
my $dir = $event->direction;
my ($ctrl, $mod) = #{$event->state};
my $font_size = $css->{textview}->{q<font-size>};
{
no warnings qw<numeric>;
$font_size += 0;
}
if ($ctrl eq q<control-mask> && $mod eq q<mod2-mask>) {
if ($dir eq q<up>) {
$css->{textview}->{q<font-size>} =
changeFontSize($font_size, FONT_UNIT)
if $font_size < MAX_FONT_SIZE;
}else{
$css->{textview}->{q<font-size>} =
changeFontSize($font_size, -FONT_UNIT)
if $font_size > MIN_FONT_SIZE;
}
changeStyle($css, $provider, $style);
}
FALSE;
}
my $window = Gtk3::Window->new(q<toplevel>);
my $scrWin = Gtk3::ScrolledWindow->new();
my $tView = Gtk3::TextView->new();
my $provider = Gtk3::CssProvider->new();
$provider->load_from_path("the.css");
my $style = $tView->get_style_context();
$style->add_provider($provider, Gtk3::STYLE_PROVIDER_PRIORITY_APPLICATION);
my $css = CSS::Tiny->read_string($provider->to_string);
#hardwired data for the TextView
my $str = qx(perldoc -T -t -f split 2>&1);
my $buf = $tView->get_buffer();
$buf->set_text($str);
my $sIter = $buf->get_start_iter();
$buf->place_cursor($sIter);
$tView->set_editable(FALSE);
$window->add_events(q<GDK_KEY_PRESS_MASK>);
$window->add_events(q<GDK_SCROLL_MASK>);
$window->signal_connect(delete_event => sub{Gtk3->main_quit; FALSE});
$window->signal_connect(key_press_event => \&killKey);
$window->signal_connect(
scroll_event =>
\&catchScroll,
[$css, $provider, $style]
);
$window->set_decorated(FALSE);
$window->set_position(q<center>);
$window->fullscreen;
$scrWin->add($tView);
$window->add($scrWin);
$window->show_all;
Gtk3::main;
the.css
text {
background-color: rgb(0,0,0);
color: rgb(0,255,0);
}
textview {
font-size: 40px;
}

How can I wait for the completion of http_request in AnyEvent::HTTP?

The program takes jobs from the database and executes AnyEvent::HTTP::http_request, how to correctly exit the program, after waiting for the completion of all requests?
#!/usr/bin/perl
use strict;
use AnyEvent;
use AnyEvent::DBI;
use AnyEvent::HTTP;
my #queue;
my $added = 0;
my $finished = 0;
my $uid = int(rand(900000)) + 100000;
my ($run, $jobs, $log, $quit);
my $db = AnyEvent::DBI->new('DBI:mysql:dbname=;host=');
my $cv = AnyEvent->condvar;
$run = AnyEvent->timer(
after => 5,
interval => 0.1,
cb => sub {
if ($#queue != -1 && $added - $finished < 300) {
my $job = shift #queue;
my $r; $r = http_request(
GET => $job->{url},
sub {
undef $r;
my ($body, $header) = #_;
...
$finished++;
}
);
$added++;
}
}
);
$jobs = AnyEvent->timer(
after => 0.1,
interval => 5,
cb => sub {
if ($#queue < 1000) {
$db->exec(q{UPDATE `jobs` SET `lock` = ? WHERE `lock` = 0 ORDER BY `time` ASC LIMIT 1000}, $uid, sub {
$db->exec(q{SELECT * FROM `jobs` WHERE `lock` = ?}, $uid, sub {
my ($db, $rows, $rv) = #_;
push #queue, #$rows;
$db->exec(q{UPDATE `jobs` SET `lock` = 1 WHERE `lock` = ?}, $uid, sub { });
});
});
}
}
);
$log = AnyEvent->timer(
after => 5,
interval => 3,
cb => sub {
printf "Queue: %-6d Added: %-6d During: %-6d Total: %-6d\n", $#queue, $added, $added-$finished, $finished;
}
);
$quit = AnyEvent->timer(
after => 1,
interval => 10,
cb => sub {
if (-f 'stop') {
print "Exit\n";
$cv->send;
}
}
);
my $result = $cv->recv;
And maybe you know the best way to queue jobs and execute them, then show your templates in AnyEvent + AnyEvent::HTTP, I use AnyEvent timers, which is better and faster ?
New version :
#!/usr/bin/perl
use strict;
use AnyEvent;
use AnyEvent::DBI;
use AnyEvent::HTTP;
my $pid = int(rand(900000)) + 100000;
my $run = 1;
my $capacity = 300;
my $added = 0;
my $finished = 0;
my $cv = AnyEvent->condvar;
my $dbh = AnyEvent::DBI->new('DBI:mysql:dbname=;host=');
my $log = AnyEvent->timer(
after => 1,
interval => 3,
cb => sub {
printf "Added: %-6d Finished: %-6d Active: %-6d\n", $added, $finished, $AnyEvent::HTTP::ACTIVE if $finished;
if ($run == 0 && $AnyEvent::HTTP::ACTIVE == 0) {
$cv->send;
}
}
);
while (! -f 'stop') {
my $done = AnyEvent->condvar;
$dbh->exec(q{UPDATE `jobs` SET `lock` = ? WHERE `lock` = 0 ORDER BY `time` ASC LIMIT ?}, $pid, $capacity, sub {
$dbh->exec(q{SELECT * FROM `jobs` WHERE `lock` = ?}, $pid, sub {
my ($dbh, $rows, $rv) = #_;
$dbh->exec(q{UPDATE `jobs` SET `lock` = 1 WHERE `lock` = ?}, $pid, sub {});
$done->send($rows);
});
});
my $jobs = $done->recv;
my $done = AnyEvent->condvar;
foreach my $job (#$jobs) {
my $content;
my $r; $r = http_request(
GET => $job->{url},
sub {
undef $r;
my ($body, $header) = #_;
...
$dbh->exec(q{UPDATE `jobs` SET `lock` = 0, `time` = CURRENT_TIMESTAMP WHERE `id` = ?}, $job->{id}, sub {});
$done->send if $AnyEvent::HTTP::ACTIVE < $capacity;
$finished++;
}
);
$added++;
}
$done->recv;
}
$run = 0;
$cv->recv;
You basically need a three-state system:
Running (new jobs accepted).
Exiting (no new jobs accepted; waiting for existing jobs to complete).
Exit (no jobs running).
Both of your version fail because they only have two states:
Running (new jobs accepted)
Exit (jobs could still be running!!!)
Here's a solution:
#!/usr/bin/perl
use strict;
use warnings;
use AE qw( );
use AnyEvent qw( );
use AnyEvent::DBI qw( );
use AnyEvent::HTTP qw( );
use Scalar::Util qw( weaken );
use Sys::Hostname qw( hostname );
my $capacity = 300;
my $exit_request = AE::cv();
my $done = AE::cv();
my $exiting = 0;
my $grabbing = 0;
my $added = 0;
my $finished = 0;
my $uid = join('.', hostname(), $$, int(rand(65536)));
my $db = AnyEvent::DBI->new('DBI:mysql:dbname=;host=');
sub worker {
my ($job, $cb) = #_;
http_request(
GET => $job->{url},
sub {
my ($body, $header) = #_;
...
$cb->();
},
);
}
sub manager {
my $active = $added - $finshed;
if ($exiting) {
$done->send() if !$active;
return;
}
my $avail_slots = $capacity - $active;
return if !$avail_slots;
return if $grabbing;
$grabbing = 1;
$db->exec(qq{UPDATE `jobs` SET `lock` = ? WHERE `status` = 'queued' AND `lock` = 0 ORDER BY `time` ASC LIMIT $avail_slots}, $uid, sub {
$db->exec(q{SELECT * FROM `jobs` WHERE `status` = 'queued' AND `lock` = ?}, $uid, sub {
my (undef, $jobs, undef) = #_;
$db->exec(q{UPDATE `jobs` SET `status = 'wip' WHERE `lock` = ?}, $uid, sub {
$grabbing = 0;
for my $job (#$jobs) {
++$added;
worker($job, sub {
++$finished;
$db->exec(q{UPDATE `jobs` SET `status = 'done', `lock` = 0, `time` = CURRENT_TIMESTAMP WHERE `id` = ?}, $job->{id}, sub { });
manager();
});
});
});
});
});
};
my $db_poll_timer = AE::timer(5, 0.5, \&manager);
my $exit_check_timer = AE::timer(0, 2, sub {
$exit_request->send() if -f 'stop';
});
my $log_timer = AE::timer(1, 3, sub {
printf("Added: %-6d Finished: %-6d Active: %-6d\n",
$added, $finished, $added-$finished);
});
$exit_request->recv();
print("Exiting...\n");
undef $exit_check_timer;
$exiting = 1;
$done->recv();
print("Finished.\n");
undef $db_poll_timer;
undef $log_timer;
Features:
Removed the #queue in order to avoid stealing work from other tasks.
I separated the worker code from the worker management code.
I removed any dependency of the worker being an http_request.
Support for long-running workers (like your first version, but unlike your second version) through timer-based polling.
Fixed a race-condition in the job-grabbing code (that existed in your first version, but not in your second version) using $grabbing.
I went beyond the scope:
Used the shortcuts from AE.
I used a more reliable lock value. It's now a string which even identifies the machine and process that holds the lock.
I added a field to the job table (status) indicating the state of the job rather than reusing the lock field.
Future work:
Use AnyEvent::Filesys::Notify instead of a timer for the file check?

Can't locate object method "add" via package "Heap"

I'm not sure why perl isn't recognizing the Heap's method add. Getting message given in question title. Here are the most relevant files.
#!/usr/bin/perl -w
use strict;
use Util;
use Heap;
use HuffTree;
my $heap = Heap->new;
my $test = 3;
$heap->add($test); # <--------ERROR HERE-----------
package Heap;
use strict;
use warnings;
use POSIX ();
sub new {
my $class = shift;
my $self = { "aref" => [""],
"next" => 1,
#_};
bless $self, $class;
}
sub print {
my $self = shift;
my $next = $self->{"next"};
my $aref = $self->{"aref"};
print "array => #$aref\n";
print "next => $next\n";
}
sub compare {
my ($self, $i, $j) = #_;
my $x = $self->{"aref"}[$i];
my $y = $self->{"aref"}[$j];
if (!defined $x) {
if (!defined $y) {
return 0;
} else {
return -1;
}
}
return 1 if !defined $y;
return $x->priority <=> $y->priority;
}
sub swap {
my ($self, $i, $j) = #_;
my $aref = $self->{"aref"};
($aref->[$i], $aref->[$j]) = ($aref->[$j], $aref->[$i]);
}
sub add {
my ($self, $value) = #_;
my $i = $self->{"next"};
$self->{"aref"}[$i] = $value;
while ($i > 1) {
my $parent = POSIX::floor($i/2);
last if $self->compare($i, $parent) <= 0;
$self->swap($i, $parent);
$i = $parent;
}
$self->{"next"}++;
}
sub reheapify {
my ($self, $i) = #_;
my $left = 2 * $i;
my $right = 2 * $i + 1;
my $winleft = $self->compare($i, $left) >= 0;
my $winright = $self->compare($i, $right) >= 0;
return if $winleft and $winright;
if ($self->compare ($left, $right) > 0) {
$self->swap($i, $left);
$self->reheapify($left);
} else {
$self->swap($i, $right);
$self->reheapify($right);
}
}
sub remove {
my $self = shift;
my $aref = $self->{"aref"};
my $result = $aref->[1];
$aref->[1] = pop #$aref;
$self->{"next"}--;
$self->reheapify(1);
return $result;
}
sub empty {
my $self = shift;
return $self->{"next"} == 1;
}
1;
package HuffTree;
use warnings;
use strict;
use Pair;
our #ISA = "Pair";
sub priority {
my $self = shift;
# lowest count highest priority
return -$self->{frequency};
}
sub left {
my $self = shift;
return $self->{left};
}
sub right {
my $self = shift;
return $self->{right};
}
1;
package Pair;
use warnings;
use strict;
sub new {
my $class = shift;
my $self = { #_ };
bless $self, $class;
}
sub letter {
my $self = shift;
return $self->{letter};
}
sub frequency {
my $self = shift;
return $self->{frequency};
}
sub priority {
my $self = shift;
return $self->{frequency};
}
1;
package Util;
use strict;
use warnings;
sub croak { die "$0: #_: $!\n"; }
sub load_arg_file {
my $path_name = shift #ARGV;
my $fh;
open($fh, $path_name) || croak "File not found.\n";
return $fh;
}
1;
You have a Heap.pm installed from CPAN. That's what gets loaded, not your own Heap.pm. The new sub in the Heap.pm from CPAN looks like this:
sub new {
use Heap::Fibonacci;
return &Heap::Fibonacci::new;
}
Which is actually a bug in said module, because Heap::Fibonacci uses the
standard bless \$h, $class; thing in its new sub,
so the reference is blessed into the Heap package, which
does indeed not have a sub called add (Heap::Fibonacci does).
To solve your immediate problem, you can:
make sure that your module is picked up before the "other" Heap (by modifying #INC with use lib, for example;
or not reinvent the wheel and actually use Heap::Fibonacci).
At any rate, it might be a good idea to report this problem
to the Heap module author - because even if you did not have
your own Heap.pm, your code would still fail with the same message.