How can I force list context in Template Toolkit with RDBO? - perl

I have a TT plugin that does the trivial unique ids:
sub get_unique_uid_tt {
my ( $classname, $o ) = #_;
my %h;
foreach my $item ( #{$o} ) {
unless ( exists $h{ $item->id } ) {
$h{ $item->id } = 1;
}
}
return keys %h;
}
where the template call is simply:
[% Namespace.get_unique_uid_tt( data.users ) %]
and "data" is an RDB Object, users being one of its relationships. I have verified that the ".users" returns a list in Perl directly, whether the relationship has one or many elements.
However, it appears that TT returns the element for single-element lists, while properly returning lists for multiple element.
I looked this up and found that you can force list context with ".list":
[% Namespace.get_unique_uid_tt( data.users.list ) %]
This does not work as intended for single-element lists, as a Data::Dumper revealed:
$VAR1 = [
{
'value' => 1,
'key' => '__xrdbopriv_in_db'
},
{
'value' => bless(
... snip ...
),
'key' => 'db'
},
{
'value' => '1',
'key' => 'id'
}
];
instead of the expected
$VAR1 = [
bless( {
'__xrdbopriv_in_db' => 1,
'id' => '1',
'db' => ... snip ...
}, 'DataClass' )
];
Is there any other simple way in TT to get a list of objects, even on single-element lists? (One approach is to rewrite the function, but one that does not would be preferable)

Found this on the TT mailing list:
http://lists.template-toolkit.org/pipermail/templates/2009-December/011061.html
seems like TT's ".list" has trouble converting objects to lists in general, not just RDBOs.
The suggestion is make a vmethod:
$Template::Stash::LIST_OPS->{ as_list } = sub {
return ref( $_[0] ) eq 'ARRAY' ? shift : [shift];
};
I added this to my context object (same idea):
$context->define_vmethod(
'list',
'as_list',
sub {
return ref( $_[0] ) eq 'ARRAY' ? shift : [shift];
},
);

It's not quite what you're after, but could you alter the TT plugin to handle both lists and single items?
sub get_unique_uid_tt {
my ( $classname, $o ) = #_;
my %h;
if (ref $o eq 'ARRAY') {
foreach my $item ( #{$o} ) {
unless ( exists $h{ $item->id } ) {
$h{ $item->id } = 1;
}
}
}
else {
return ($o->id);
}
return keys %h;
}

Related

executing a function within an array within a hash in perl

I have a Perl data structurte like so
%myhash = (
k1 => v1,
kArray => [
{
name => "anonymous hash",
...
},
\&funcThatReturnsHash,
{
name => "another anonymous hash",
...
}
]
);
Elsewhere I iterate through the list in kArray which contains a bunch of hashes. I would like to either process the actual hash OR the hash returned by the function.
foreach my $elem( #{myhash{kArray}} ) {
if (ref($elem) == "CODE") {
%thisHash = &$elem;
}
else {
%thisHash = %$elem;
}
...
}
However ref ($elem) is always scalar or undefined. I tried func, &func, \&func, \%{&func}, in %myhash to no effect.
how do I extract the hash within the function in the main body?
Apart from the code sample you give being invalid Perl, the main problems seem to be that you are using == to compare strings instead of eq, and you are assigning a hash reference to a hash variable %thishash. I assure you that ref $elem never returns SCALAR with the data you show
It would help you enormously if you followed the common advice to use strict and use warnings at the top of your code
This will work for you
for my $elem ( #{ $myhash{kArray} } ) {
my $this_hash;
if ( ref $elem eq 'CODE' ) {
$this_hash = $elem->();
}
else {
$this_hash = $elem;
}
# Do stuff with $this_hash
}
or you could just use a map like this
use strict;
use warnings;
use 5.010;
use Data::Dump;
my %myhash = (
k1 => v1,
kArray => [
{
name => "anonymous hash",
},
\&funcThatReturnsHash,
{
name => "another anonymous hash",
}
]
);
for my $hash ( map { ref eq 'CODE' ? $_->() : $_ } #{ $myhash{kArray} } ) {
say $hash->{name};
}
sub funcThatReturnsHash {
{ name => 'a third anonymous hash' };
}
output
anonymous hash
a third anonymous hash
another anonymous hash
If you turn on strict and warnings, you'll see that:
foreach my $elem(#{mynahs{kArray}}) {
Isn't valid. You need at the very least a $ before mynahs.
But given something like this - your approach works - here's an example using map to 'run' the code references:
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
sub gimme_hash {
return { 'fish' => 'paste' };
}
my $stuff =
[ { 'anon1' => 'value' },
\&gimme_hash,
{ 'anon2' => 'anothervalue' }, ];
my $newstuff = [ map { ref $_ eq "CODE" ? $_->() : $_ } #$stuff ];
print Dumper $newstuff;
Turns that hash into:
$VAR1 = [
{
'anon1' => 'value'
},
{
'fish' => 'paste'
},
{
'anon2' => 'anothervalue'
}
];
But your approach does work:
foreach my $element ( #$stuff ) {
my %myhash;
if ( ref $element eq "CODE" ) {
%myhash = %{$element -> ()};
}
else {
%myhash = %$element;
}
print Dumper \%myhash;
}
Gives:
$VAR1 = {
'anon1' => 'value'
};
$VAR1 = {
'fish' => 'paste'
};
$VAR1 = {
'anon2' => 'anothervalue'
};

Anomalous push behaviour under Catalyst MVC

I would expect the following code
my #array;
for my $rapport ( qw( value1 value2 value3 ) ) {
push #array, { key => $rapport };
}
to produce:
$VAR1 = [
{
'key' => 'value1'
},
{
'key' => 'value2'
},
{
'key' => 'value3'
}
];
However, running this code segment under Catalyst MVC I get:
$VAR1 = [
{
'key' => [ 'value', 'value2', 'value3' ]
},
];
Can someone please explain to me why?
EDIT: could anyone with the same issue please add an example? I cannot reproduce after some code changes, but as it has been upvoted 5 times I assume some other users have also experienced this issue?
This code example...
#!/usr/bin/perl
use Data::Dumper;
my #input = ( "var1", "var2", "var3" );
my #array;
for my $rapport ( #input ) {
push #array, { key => $rapport };
}
print Dumper( \#array );
exit;
produces ...
$VAR1 = [
{
'key' => 'var1'
},
{
'key' => 'var2'
},
{
'key' => 'var3'
}
];
But the following...
#!/usr/bin/perl
use Data::Dumper;
my #input = [ "var1", "var2", "var3" ]; # sometimes people forget to dereference their variables
my #array;
for my $rapport ( #input ) {
push #array, { key => $rapport };
}
print Dumper( \#array );
exit;
shows...
$VAR1 = [
{
'key' => [
'var1',
'var2',
'var3'
]
}
];
As you can see both examples loop through an array but the second one is an array, that was initialized with a reference value. Since in Catalyst you normally ship various values through your application via stash or similar constructs, you could check weather your array really contains scalar values : )

Perl WWW:Mechanize Accessing data in a hash reference

I have a question I'm hoping you could help with?
This is the last part I need help with in understanding hash references
Code:
my $content_lengths; # this is at the top
foreach my $url ( # ... more stuff
# compare
if ( $mech->response->header('Content-Length') != $content_length ) {
print "$child_url: different content length: $content_length vs "
. $mech->response->header('Content-Length') . "!\n";
# store the urls that are found to have different content
# lengths to the base url only if the same url has not already been stored
$content_lengths->{$url}->{'different'}->{$child_url} = $mech->response->header('Content-Length');
} elsif ( $mech->response->header('Content-Length') == $content_length ) {
print "Content lengths are the same\n";
# store the urls that are found to have the same content length as the base
# url only if the same url has not already been stored
$content_lengths->{$url}->{'equal'}->{$child_url} = $mech->response->header('Content-Length');
}
What it looked like using Data::Dumper
$VAR1 = {
'http://www.superuser.com/' => {
'difference' => {
'http://www.superuser.com/questions' => '10735',
'http://www.superuser.com/faq' => '13095'
},
'equal' => {
'http://www.superuser.com/ ' => '20892'
}
},
'http://www.stackoverflow.com/' => {
'difference' => {
'http://www.stackoverflow.com/faq' => '13015',
'http://www.stackoverflow.com/questions' => '10506'
},
'equal' => {
'http://www.stackoverflow.com/ ' => '33362'
}
}
};
What I need help with:
I need help understanding the various ways of accessing the different parts in the hash reference and using them to do things, such as print them.
So for example how do I print all the $url from the hash reference (i.e from Data::Dumper that will be http://www.superuser.com/ and http://www.stackoverflow.com/)
and how do I print all the $child_url or a particular one/subset from $child_url and so on?
Your help with this is much appreciated,
thanks a lot
You can navigate your hashref thusly:
$hashref->{key1}{key2}{keyN};
For example, if you want the superuser equal branch:
my $urlArrayref = $hashref->{'http://www.superuser.com/'}{'equal'};
More to the point, to print the urls (first level key) of the hashref, you would do:
foreach my $key ( keys( %{$hashref} ) ) {
print( "key is '$key'\n" );
}
Then if you wanted the second level keys:
foreach my $firstLevelKey ( keys( %{$hashref} ) ) {
print( "first level key is '$firstLevelKey'\n" );
foreach my $secondLevelKey ( keys( %{$hashref->{$firstLevelKey}} ) ) {
print( "\tfirst level key is '$secondLevelKey'\n" );
}
}
And so forth...
----- EDIT -----
This is working sample code from your example above:
#!/usr/bin/perl
use strict;
use warnings;
my $content_lengths = {
'http://www.superuser.com/' => {
'difference' => {
'http://www.superuser.com/questions' => '10735',
'http://www.superuser.com/faq' => '13095'
},
'equal' => {
'http://www.superuser.com/ ' => '20892'
}
},
'http://www.stackoverflow.com/' => {
'difference' => {
'http://www.stackoverflow.com/faq' => '13015',
'http://www.stackoverflow.com/questions' => '10506'
},
'equal' => {
'http://www.stackoverflow.com/ ' => '33362'
}
}
};
foreach my $key1 ( keys( %{$content_lengths} ) ) {
print( "$key1\n" );
foreach my $key2 ( keys( %{$content_lengths->{$key1}} ) ) {
print( "\t$key2\n" );
foreach my $key3 ( keys( %{$content_lengths->{$key1}{$key2}} ) ) {
print( "\t\t$key3\n" );
}
}
}
Which results in this output:
http://www.superuser.com/
difference
http://www.superuser.com/questions
http://www.superuser.com/faq
equal
http://www.superuser.com/
http://www.stackoverflow.com/
difference
http://www.stackoverflow.com/faq
http://www.stackoverflow.com/questions
equal
http://www.stackoverflow.com/

How can I extract all global variables from a script and get each data type in Perl?

I like to capture all global variables from an external Perl script with Perl. Currently I am hanging around the type detection.
How to determine the correct data type ('', 'SCALAR', 'HASH', 'ARRAY', 'CODE')?
Parser script:
my %allVariables = ();
{
do "scriptToBeParsed.pl";
foreach my $sym ( keys %main:: ) {
# Get all normal variables and scalar/hash/array references:
if ( ref( *{"$sym"} ) =~ m/^(?:|SCALAR|HASH|ARRAY)$/ ) {
$allVariables{"$sym"} = *{"$sym"};
}
}
}
Script to be parsed:
$someVariable1 = 'Yes, I like to be captured';
$otherVariable2 = \'And I also want to be captured';
%anotherVariable3 = ( 'Capture' => 'me' );
#lameVariable4 = ( 'Capture', 'me' );
$fooVariable5 = { 'Capture' => 'me' };
$barVariable6 = [ 'Capture', 'me' ];
$subVariable7 = sub { return "Don't capture me!" };
sub dontCaptureMe { return "Don't capture me!" }
In my example ref( *{"$sym"} ) returns always 'GLOB' (of course).
Another approach would be to use the has-like access of the typeglob, which is explained in Chapter 8 of brian d foy's Mastering Perl on page 131f.
package test;
no strict;
no warnings;
$someVariable1 = 'Yes, I like to be captured';
$otherVariable2 = \'And I also want to be captured';
%anotherVariable3 = ( 'Capture' => 'me' );
#lameVariable4 = ( 'Capture', 'me' );
$fooVariable5 = { 'Capture' => 'me' };
$barVariable6 = [ 'Capture', 'me' ];
$subVariable7 = sub { return "Don't capture me!" };
sub dontCaptureMe { return "Don't capture me!" }
say $dontCaptureMe;
my %allVariables = ();
{
do "scriptToBecomeParsed.pl";
foreach my $sym ( keys %test:: ) {
for (qw( SCALAR HASH ARRAY CODE IO)) {
if (*{"$sym"}{$_}) {
$allVariables{$_}->{"$sym"} = *{"$sym"}{$_};
}
}
}
}
print Data::Dumper::Dumper \%allVariables;
This will produce the following output:
$VAR1 = {
'CODE' => {
'dontCaptureMe' => sub { "DUMMY" }
},
'ARRAY' => {
'lameVariable4' => [
'Capture',
'me'
]
},
'HASH' => {
'anotherVariable3' => {
'Capture' => 'me'
}
},
'SCALAR' => {
'someVariable1' => \'Yes, I like to be captured',
'__ANON__' => \undef,
'subVariable7' => \sub { "DUMMY" },
'dontCaptureMe' => \undef,
'otherVariable2' => \\'And I also want to be captured',
'BEGIN' => \undef,
'barVariable6' => \[
'Capture',
'me'
],
'anotherVariable3' => \undef,
'lameVariable4' => \undef,
'fooVariable5' => \{
'Capture' => 'me'
}
}
};
like you said
ref( *{"$sym"} ) returns always 'GLOB' (of course).
Because perl stores everything in the symbol table in a glob, it is impossible to tell which data type something is. This is because in perl it is perfectly valid to have an array, scalar, hash or whatever else with the same name... because of this, perl stores everything in globs to avoid collisions. What you could do is loop through all of the symbols in the symbol table and test each glob against all the possible things that it could be (the set isn't too large) and see which ones are set.
Alternatively, a more practical approach might be to just load the perl script as text and parse for $, %, #, sub, open (filehandle) to see what type everything is.

Perl Working On Two Hash References

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
};
...