How to apply a style to cell using OpenOffice::OODoc module in Perl?
I tried:
my $container = odfContainer("report1.ods", create => 'spreadsheet');
my $doc = odfDocument (
container => $container,
part => 'content'
);
# Styles
my $styles = odfDocument (
container => $container,
part => 'styles'
);
$styles->createStyle ('TTT',
family => 'cell',
display-name => 'Table Headers',
properties => {
'fo:font-weight' => 'bold',
'fo:color' => '#ffffff',
}
);
{
for (my $x = 0; $x < $X; $x++) {
$doc->columnStyle ($sheet, $x, "TTT"); # does not work
for (my $y = 0; $y < $Y; $y++) {
my $cell = $doc->getTableCell ($sheet, $y, $x);
$doc->cellValueType ($cell, $headers->[$x][1]);
$doc->updateCell ($cell, $data->[$y][$x]);
$doc->setStyle ($cell, 'TTT'); # does not work
$doc->cellStyle ($cell, 'TTT'); # does not work
}
}
}
See style:
style(object [, style])
Returns the style name of a text or graphics object. If the first
argument is a "master page" (see OODoc::Styles), it even returns the
associated "page layout".
Replaces the object's style if a style name is given as the second
argument.
Related
In the example code below, I am defining a class Person that can have child objects of the same class.
When I invoke the printTree method, I am expecting the following output
Sam Ram Geeta
What I see instead is
SamRamRamRamRamRamRamRamRamRamRamR.....
Any hints on what I am doing wrong and how to achieve my goal?
package Person;
use Moose;
has name => ( is => 'ro' );
my #kids;
sub addChild {
my ( $self, $name ) = #_;
my $k = Person->new( name => $name );
push #kids, $k;
return $k;
}
sub printTree {
my $self = shift;
print $self->name;
$_->printTree foreach ( #kids );
}
no Moose;
package main;
my $s = Person->new( name => "Sam" );
my $r = $s->addChild( "Ram" );
my $g = $s->addChild( "Geeta" );
$s->printTree;
The issue is that #Person::kids does not belong to any one instance, and you effectively end up with
#Person::kids = ($r, $g);
$s->printTree() loops through #Person::kids, calls
$r->printTree() loops through #Person::kids, calls
$r->printTree() loops through #Person::kids, calls
$r->printTree() loops through #Person::kids, calls
...
You need to make it an attribute, e.g.
has kids => (
isa => 'ArrayRef[Person]',
traits => ['Array'],
handles => {
all_kids => 'elements',
push_kids => 'push',
},
default => sub { [] },
);
sub addChild {
my ($self, $name) = #_;
my $k = Person->new(name => $name);
$self->push_kids($k);
return $k;
}
sub printTree {
my ($self) = #_;
print $self->name;
$_->printTree foreach $self->all_kids;
}
You can check perldoc Moose::Meta::Attribute::Native::Trait::Array for other useful handles from the Array trait.
Given this Perl/Tkx code fragment:
#itemList = ({'attrib1' => 'name1', 'attrib2' => 'value1'},
{'attrib1' => 'name2', 'attrib2' => 'value2'});
$row = 0;
foreach $item (#itemList) {
push(#btn_list, new_ttk__button(-text => $item->{'attrib1'}, -command => sub {do_something($item->{'attrib2'});}));
$btn_list[-1]->g_grid(-column => 0, -row => $row);
$row++;
}
(In the real program #itemList is populated from a user editable config file.)
I do see two buttons labeled 'name1' and 'name2'. But when I click on either button it seems that the parameter that is passed to the callback is always $itemList[1]->{'attrib2'}; i.e. 'attrib2' of the last element of the #itemList array. What I would like is to have the first button call do_something($itemList[0]->{'attrib2'} and the second call do_something($itemList[1]->{'attrib2'}.
What am I doing wrong, please and thank you?
You have encountered a subtle feature of for loops in Perl. First the solution: use my in the for loop. Then $item will be able to create a proper closure in the anonymous sub you declare later in the loop.
for my $item (#itemlist) {
push(#btn_list, new_ttk__button(
-text => $item->{'attrib1'},
-command => sub {do_something($item->{'attrib2'});}));
$btn_list[-1]->g_grid(-column => 0, -row => $row);
$row++;
}
Further explanation: Perl implicitly localizes the subject variable of a for loop. If you don't use my in the for loop, the loop will be using a localized version of a package variable. That makes your code equivalent to:
package main;
$main::item = undef;
#itemList = ({'attrib1' => 'name1', 'attrib2' => 'value1'},
{'attrib1' => 'name2', 'attrib2' => 'value2'});
$row = 0;
foreach (#itemList) {
local $main::item = $_;
push(#btn_list, new_ttk__button(
-text => $main::item->{'attrib1'},
-command => sub {do_something($main::item->{'attrib2'});}));
$btn_list[-1]->g_grid(-column => 0, -row => $row);
$row++;
}
# at the end of the loop, value of $main::item restored to undef
Your anonymous subs still refer to the $main::item package variable, whatever value that variable holds at the time that those subroutines are invoked, which is probably undef.
Shorter solution: use strict
Additional proof-of-concept. Try to guess what the following program outputs:
#foo = ( { foo => 'abc', bar => 123 },
{ foo => 'def', bar => 456 } );
my #fn;
foreach $foo (#foo) {
push #fn, sub { "42" . $foo->{bar} . "\n" };
}
foreach my $foo (#foo) {
push #fn, sub { "19" . $foo->{foo} . "\n" };
}
print $_->() for #fn;
Here's the answer:
42
42
19abc
19def
Is is possible to supply an accessor wrapper for a moose attribute without having to write it every time?
Example:
* There is an an attribute of type TkRef
* It should provide a wrapper for setting the value
* The name of the wrapper should be defined when defining the attribute
* I don't want to have to write the wrapper
I imagine it like this:
has _some_val => (
is => 'rw',
isa => 'TkRef',
coerce => 1,
init_arg => 'my_accessor_wrapper_name',
default => 'default value'
);
# Later in the class:
sub some_public_method {
my $self = shift;
# will set _some_val behind the scenes:
$self->my_accessor_wrapper_name('this will be the new value');
...
}
I'm assuming here that this follows on from your previous question so the aim is to wrap a ScalarRef attribute's accessors to ensure that when the setter is called with a new ScalarRef (or something that can be coerced into a ScalarRef), rather that the usual set action happening, you copy the string stored in the new scalar into the old scalar.
There are easier ways to do this than below (say, by writing a wrapper for has), but I think this is the "most antlered":
use 5.010;
use strict;
use warnings;
{
package MooseX::Traits::SetScalarByRef;
use Moose::Role;
use Moose::Util::TypeConstraints qw(find_type_constraint);
# Supply a default for "is"
around _process_is_option => sub
{
my $next = shift;
my $self = shift;
my ($name, $options) = #_;
if (not exists $options->{is})
{
$options->{is} = "rw";
}
$self->$next(#_);
};
# Supply a default for "isa"
my $default_type;
around _process_isa_option => sub
{
my $next = shift;
my $self = shift;
my ($name, $options) = #_;
if (not exists $options->{isa})
{
if (not defined $default_type)
{
$default_type = find_type_constraint('ScalarRef')
->create_child_constraint;
$default_type
->coercion('Moose::Meta::TypeCoercion'->new)
->add_type_coercions('Value', sub { my $r = $_; \$r });
}
$options->{isa} = $default_type;
}
$self->$next(#_);
};
# Automatically coerce
around _process_coerce_option => sub
{
my $next = shift;
my $self = shift;
my ($name, $options) = #_;
if (defined $options->{type_constraint}
and $options->{type_constraint}->has_coercion
and not exists $options->{coerce})
{
$options->{coerce} = 1;
}
$self->$next(#_);
};
# This allows handles => 1
around _canonicalize_handles => sub
{
my $next = shift;
my $self = shift;
my $handles = $self->handles;
if (!ref($handles) and $handles eq '1')
{
return ($self->init_arg, 'set_by_ref');
}
$self->$next(#_);
};
# Actually install the wrapper
around install_delegation => sub
{
my $next = shift;
my $self = shift;
my %handles = $self->_canonicalize_handles;
for my $key (sort keys %handles)
{
$handles{$key} eq 'set_by_ref' or next;
delete $handles{$key};
$self->associated_class->add_method($key, $self->_make_set_by_ref($key));
}
# When we call $next, we're going to temporarily
# replace $self->handles, so that $next cannot see
# the set_by_ref bits which were there.
my $orig = $self->handles;
$self->_set_handles(\%handles);
$self->$next(#_);
$self->_set_handles($orig); # and restore!
};
# This generates the coderef for the method that we're
# going to install
sub _make_set_by_ref
{
my $self = shift;
my ($method_name) = #_;
my $reader = $self->get_read_method;
my $type = $self->type_constraint;
my $coerce = $self->should_coerce;
return sub {
my $obj = shift;
if (#_)
{
my $new_ref = $coerce
? $type->assert_coerce(#_)
: do { $type->assert_valid(#_); $_[0] };
${$obj->$reader} = $$new_ref;
}
$obj->$reader;
};
}
}
{
package Local::Example;
use Moose;
use Moose::Util::TypeConstraints;
subtype 'TkRef', as 'ScalarRef';
coerce 'TkRef', from 'Str', via { my $r = $_; return \$r };
has _some_val => (
traits => [ 'MooseX::Traits::SetScalarByRef' ],
isa => 'TkRef',
init_arg => 'some_val',
default => 'default value',
handles => 1,
);
}
use Scalar::Util qw(refaddr);
my $eg = Local::Example->new;
say refaddr($eg->some_val);
$eg->some_val("new string");
say refaddr($eg->some_val), " - should not have changed";
say ${ $eg->some_val };
I would like to compare the values of two hash references.
The data dumper of my first hash is this:
$VAR1 = {
'42-MG-BA' => [
{
'chromosome' => '19',
'position' => '35770059',
'genotype' => 'TC'
},
{
'chromosome' => '2',
'position' => '68019584',
'genotype' => 'G'
},
{
'chromosome' => '16',
'position' => '9561557',
'genotype' => 'G'
},
And the second hash is similar to this but with more hashes in the array. I would like to compare the genotype of my first and second hash if the position and the choromosome matches.
map {print "$_= $cave_snp_list->{$_}->[0]->{chromosome}\n"}sort keys %$cave_snp_list;
map {print "$_= $geno_seq_list->{$_}->[0]->{chromosome}\n"}sort keys %$geno_seq_list;
I could do that for the first array of the hashes.
Could you help me in how to work for all the arrays?
This is my actual code in full
#!/software/bin/perl
use strict;
use warnings;
use Getopt::Long;
use Benchmark;
use Config::Config qw(Sequenom.ini);
useDatabase::Conn;
use Data::Dumper;
GetOptions("sam=s" => \my $sample);
my $geno_seq_list = getseqgenotypes($sample);
my $cave_snp_list = getcavemansnpfile($sample);
#print Dumper($geno_seq_list);
print scalar %$geno_seq_list, "\n";
foreach my $sam (keys %{$geno_seq_list}) {
my $seq_used = $geno_seq_list->{$sam};
my $cave_used = $cave_snp_list->{$sam};
print scalar(#$geno_seq_list->{$_}) if sort keys %$geno_seq_list, "\n";
print scalar(#$cave_used), "\n";
#foreach my $seq2com (# {$seq_used } ){
# foreach my $cave2com( # {$cave_used} ){
# print $seq2com->{chromosome},":" ,$cave2com->{chromosome},"\n";
# }
#}
map { print "$_= $cave_snp_list->{$_}->[0]->{chromosome}\n" } sort keys %$cave_snp_list;
map { print "$_= $geno_seq_list->{$_}->[0]->{chromosome}\n" } sort keys %$geno_seq_list;
}
sub getseqgenotypes {
my $snpconn;
my $gen_list = {};
$snpconn = Database::Conn->new('live');
$snpconn->addConnection(DBI->connect('dbi:Oracle:pssd.world', 'sn', 'ss', { RaiseError => 1, AutoCommit => 0 }),
'pssd');
#my $conn2 =Database::Conn->new('live');
#$conn2->addConnection(DBI->connect('dbi:Oracle:COSI.world','nst_owner','nst_owner', {RaiseError =>1 , AutoCommit=>0}),'nst');
my $id_ind = $snpconn->execute('snp::Sequenom::getIdIndforExomeSample', $sample);
my $genotype = $snpconn->executeArrRef('snp::Sequenom::getGenotypeCallsPosition', $id_ind);
foreach my $geno (#{$genotype}) {
push #{ $gen_list->{ $geno->[1] } }, {
chromosome => $geno->[2],
position => $geno->[3],
genotype => $geno->[4],
};
}
return ($gen_list);
} #end of sub getseqgenotypes
sub getcavemansnpfile {
my $nstconn;
my $caveman_list = {};
$nstconn = Database::Conn->new('live');
$nstconn->addConnection(
DBI->connect('dbi:Oracle:CANP.world', 'nst_owner', 'NST_OWNER', { RaiseError => 1, AutoCommit => 0 }), 'nst');
my $id_sample = $nstconn->execute('nst::Caveman::getSampleid', $sample);
#print "IDSample: $id_sample\n";
my $file_location = $nstconn->execute('nst::Caveman::getCaveManSNPSFile', $id_sample);
open(SNPFILE, "<$file_location") || die "Error: Cannot open the file $file_location:$!\n";
while (<SNPFILE>) {
chomp;
next if /^>/;
my #data = split;
my ($nor_geno, $tumor_geno) = split /\//, $data[5];
# array of hash
push #{ $caveman_list->{$sample} }, {
chromosome => $data[0],
position => $data[1],
genotype => $nor_geno,
};
} #end of while loop
close(SNPFILE);
return ($caveman_list);
}
The problem that I see is that you're constructing a tree for generic storage of data, when what you want is a graph, specific to the task. While you are constructing the record, you could also be constructing the part that groups data together. Below is just one example.
my %genotype_for;
my $record
= { chromosome => $data[0]
, position => $data[1]
, genotype => $nor_geno
};
push #{ $gen_list->{ $geno->[1] } }, $record;
# $genotype_for{ position }{ chromosome }{ name of array } = genotype code
$genotype_for{ $data[1] }{ $data[0] }{ $sample } = $nor_geno;
...
return ( $caveman_list, \%genotype_for );
In the main line, you receive them like so:
my ( $cave_snp_list, $geno_lookup ) = getcavemansnpfile( $sample );
This approach at least allows you to locate similar position and chromosome values. If you're going to do much with this, I might suggest an OO approach.
Update
Assuming that you wouldn't have to store the label, we could change the lookup to
$genotype_for{ $data[1] }{ $data[0] } = $nor_geno;
And then the comparison could be written:
foreach my $pos ( keys %$small_lookup ) {
next unless _HASH( my $sh = $small_lookup->{ $pos } )
and _HASH( my $lh = $large_lookup->{ $pos } )
;
foreach my $chrom ( keys %$sh ) {
next unless my $sc = $sh->{ $chrom }
and my $lc = $lh->{ $chrom }
;
print "$sc:$sc";
}
}
However, if you had limited use for the larger list, you could construct the specific case
and pass that in as a filter when creating the longer list.
Thus, in whichever loop creates the longer list, you could just go
...
next unless $sample{ $position }{ $chromosome };
my $record
= { chromosome => $chromosome
, position => $position
, genotype => $genotype
};
...
I want to export a function which depends on name of class where is exported into. I thought that it should be easy with Sub::Exporter but unfortunately the into key is not passed to generators. I have ended up with those ugly example code:
use strict;
use warnings;
package MyLog;
use Log::Log4perl qw(:easy get_logger);
use Sub::Exporter -setup => {
exports => [
log => \&gen_log,
audit_log => \&gen_log,
],
groups => [ default => [qw(log audit_log)] ],
collectors => ['category'],
installer => \&installer, # tunnel `into` value into generators
};
if ( not Log::Log4perl->initialized() ) {
#easy init if not initialised
Log::Log4perl->easy_init($ERROR);
}
sub gen_log {
my ( $class, $name, $arg, $global ) = #_;
my $category = $arg->{category};
$category = $global->{category}{$name} unless defined $category;
return sub { # return generator
my $into = shift; # class name passed by `installer`
$category = $name eq 'audit_log' ? "audit_log.$into" : $into
if !defined $category; # set default category
# lazy logger
my $logger;
return sub {
$logger or $logger = get_logger($category);
};
};
}
sub installer {
my ( $args, $todo ) = #_;
# each even value is still generator thus generate final function
my $i;
1 & $i++ and $_ = $_->( $args->{into} ) for #$todo;
Sub::Exporter::default_installer(#_);
}
1;
Is there better way how to do it without sacrifice all this rich Sub::Exporter abilities?
For example I would like to use one of those:
use MyLog category => { log => 'foo', audit_log => 'bar' };
use MyLog -default => { -prefix => 'my_' };
use MyLog
audit_log => { -as => 'audit' },
log => { -as => 'my_log', category => 'my.log' };
Edit: Added Sub::Exporter abilities requirement to question.
Edit2: Added usage examples.
You aren't clear how you want to determine the name. If I understand you correctly, this does what you want.
my %sub_for = (
foo => \&foo,
#...
);
sub install_as {
my ($package, $exported_name, $sub) = #_;
no strict 'refs';
*{"$package\::$exported_name"} = $sub;
return;
}
sub get_name_for {
my ($package, $name) = #_;
#... your code here
}
sub import {
my $class = shift;
my $package = caller;
for my $internal_name (#_) {
install_as($package, get_name_for($package, $internal_name), $get_sub_for{$name});
}
return;
}