Understanding name spaces in POE-Tk - perl

I posted "How to undersand the POE-Tk use of destroy?" in an attempt to reduce the bug in my production code to a test case. But it seems that the solution to the test case is not working in the full program.
The program is 800+ lines long so I am hesitant to post it in full. I realize that the snippets I provide here may be too short to be of any use, but I hope to get some direction in either where to look for a solution or what additional information I can provide.
Here is the Session::Create section of my POE-Tk app.
POE::Session->create(
inline_states => {
_start => \&ui_start,
get_zone => \&get_zone,
ping => \&ping,
mk_disable => \&mk_disable,
mk_active => \&mk_active,
pop_up_add => \&pop_up_add,
add_button_press => sub {
my ($kernel, $session, $heap) = #_[KERNEL, SESSION, HEAP];
print "\nadd button pressed\n\n";
&validate;
},
ih_button_1_press => sub {
my ($kernel, $session, $heap) = #_[KERNEL, SESSION, HEAP];
print "\nih_button_1 pressed\n\n";
if( Tk::Exists($heap->{ih_mw}) ) {
print "\n\nih_mw exists in ih_button_1_press\n\n";
} else {
print "\n\nih_mw does not exist in ih_button_1_press\n\n";
}
1;
$heap->{ih_mw}->destroy if Tk::Exists($heap->{ih_mw});
&auth;
},
pop_up_del => \&pop_up_del,
auth => \&auth,
# validate => \&validate,
auth_routine => \&auth_routine,
raise_widget => \&raise_widget,
del_action => \&del_action,
over => sub { exit; }
}
);
add_button_press is called here;
sub pop_up_add {
...
my $add_but_2 = $add_frm_2->Button(
-text => "Add Record",
-command => $session->postback("add_button_press"),
-font => "{Arial} 12 {bold}") -> pack(
-anchor => 'c',
-pady => 6,
);
...
}
validate creates the Toplevel widget $heap->{ih_mw};
sub validate {
...
if( ! $valid ) {
print "\n! valid entered\n\n";
$heap->{label_text} .= "Add record anyway?";
my $lt_ref = \$heap->{label_text};
...
my $heap->{ih_mw} = $heap->{add_mw}->Toplevel( -title => "ih_mw");
...
if( Tk::Exists($heap->{ih_mw}) ) {
print "\n\nih_mw exists in validate\n\n";
} else {
print "\n\nih_mw does not exist in validate\n\n";
}
...
my $ih_but1 = $heap->{ih_mw}->Button( -text => "Add",
-font => 'vfont',
-command => $session->postback("ih_button_1_press"),
)->pack( -pady => 5 );
...
}
Pressing $ih_but1 results in this;
C:\scripts\alias\resource>alias_poe_V-3_0_par.pl
add button pressed
sub validate called
! valid entered
ih_mw exists in validate
ih_button_1 pressed
ih_mw does not exist in ih_button_1_press
So the $heap->{ih_mw} widget seems to be unkown to the ih_button_1_press anonymous subroutine even with the inclusion of "($kernel, $session, $heap) = #_[KERNEL, SESSION, HEAP];"

Where does $heap in &validate come from? You don't pass it as a parameter. Could $heap in &validate and $heap in &in_button_1_press not be the same thing? Have you tried printing the stringy form of $heap to see if the addresses are the same in the two functions?

Related

Perl- Get Hash Value from Multi level hash

I have a 3 dimension hash that I need to extract the data in it. I need to extract the name and vendor under vuln_soft-> prod. So far, I manage to extract the "cve_id" by using the following code:
foreach my $resultHash_entry (keys %hash){
my $cve_id = $hash{$resultHash_entry}{'cve_id'};
}
Can someone please provide a solution on how to extract the name and vendor. Thanks in advance.
%hash = {
'CVE-2015-6929' => {
'cve_id' => 'CVE-2015-6929',
'vuln_soft' => {
'prod' => {
'vendor' => 'win',
'name' => 'win 8.1',
'vers' => {
'vers' => '',
'num' => ''
}
},
'prod' => {
'vendor' => 'win',
'name' => 'win xp',
'vers' => {
'vers' => '',
'num' => ''
}
}
},
'CVE-2015-0616' => {
'cve_id' => 'CVE-2015-0616',
'vuln_soft' => {
'prod' => {
'name' => 'unity_connection',
'vendor' => 'cisco'
}
}
}
}
First, to initialize a hash, you use my %hash = (...); (note the parens, not curly braces). Using {} declares a hash reference, which you have done. You should always use strict; and use warnings;.
To answer the question:
for my $resultHash_entry (keys %hash){
print "$hash{$resultHash_entry}->{vuln_soft}{prod}{name}\n";
print "$hash{$resultHash_entry}->{vuln_soft}{prod}{vendor}\n";
}
...which could be slightly simplified to:
for my $resultHash_entry (keys %hash){
print "$hash{$resultHash_entry}{vuln_soft}{prod}{name}\n";
print "$hash{$resultHash_entry}{vuln_soft}{prod}{vendor}\n";
}
because Perl always knows for certain that any deeper entries than the first one is always a reference, so the deref operator -> isn't needed here.

How to Link / Get Config Item to a Ticket through Webservice (SOAP or REST) in OTRS

I want to know how to get and link the ticket to Configuration item through SOAP or REST Webservice.
I have imported this Restfull Web service in admin console and successfully created and getting ticket information using this url
http://XXX.XXX.XXX.XXX/otrs/nph-genericinterface.pl/Webservice/GenericTicketConnectorREST/Ticket/1.
but the problem is the linked config item information is not coming when i get the ticket information.
i did lots of search on google found that ticket can be linked to Config Item through OTRS GUI and in AgentTicketzoom page it will show, i want this to be done through web service.
can any one help me in this problem or suggest some doc on how to create web service to get linked object information from ticket.
Updated#1
i added web controller to my existing Ticket connector successfully. the url is http://XXX.XXX.XXX.XXX/otrs/nph-genericinterface.pl/Webservice/GenericTicketConnectorRest/LinkObject with POST Call.but i am getting this error
{"faultcode":"Server","faultstring":"Got no ConfigObject!"}
i checked the initial parameters also
$VAR1 = { 'Password' => '1234567', 'RequestMethod' => 'POST','SourceKey' => '1', 'SourceObject' => 'Ticket', 'State' => 'valid', 'TargetKey' => '2', 'TargetObject' => 'ITSMConfigItem', 'Type' => 'ParentChild', 'UserID' => '1', 'UserLogin' => 'XXXXX.XXXX#XXXX.com'};
$VAR1 = { 'ErrorMessage' => 'Got no ConfigObject!', 'Success' => 0};
Yes, the ticket can be linked to a configItem via a GUI and it can be done via a Webservice.
First of all you should write a new Generic Interface Connector operation, which will handle method LinkAdd from LinkObject Class ( APIdoc )
Then create and register new operations via a new XML file, like this:
FILE NAME: GenericInterfaceLinkObjectConnector.xml
<?xml version="1.0" encoding="utf-8"?>
<otrs_config version="1.0" init="Application">
<ConfigItem Name="GenericInterface::Operation::Module###LinkObject::LinkAdd" Required="0" Valid="1">
<Description Translatable="1">GenericInterface module registration for the operation layer.</Description>
<Group>GenericInterface</Group>
<SubGroup>GenericInterface::Operation::ModuleRegistration</SubGroup>
<Setting>
<Hash>
<Item Key="Name">LinkAdd</Item>
<Item Key="Controller">LinkObject</Item>
<Item Key="ConfigDialog">AdminGenericInterfaceOperationDefault</Item>
</Hash>
</Setting>
</ConfigItem>
</otrs_config>
After that you can publish a new provider WebService from OTRS GUI, where a newly created connector is used.
Make sure, that you pass all the needed parameters for the method!!!
$True = $LinkObject->LinkAdd(
SourceObject => 'Ticket',
SourceKey => '321',
TargetObject => 'FAQ',
TargetKey => '5',
Type => 'ParentChild',
State => 'Valid',
UserID => 1,
);
UPDATE:
Please read this Document to understand how Generic Interface is built and then please add a new Connector ( LinkObject )
To register the connector and its operation - place XML file in /Kernel/Config/Files/...
Then go to Sysconfig -> GenericInterface -> GenericInterface::Operation::ModuleRegistration and set a tick next to the GenericInterface::Operation::Module###LinkObject::LinkAdd and save changes
Afterwards add this Connector file to /Custom/Kernel/GenericInterface/Operation/LinkObject/LinkAdd.pm
# --
# Kernel/GenericInterface/Operation/LinkObject/LinkAdd.pm - GenericInterface LinkAdd operation backend
# Copyright (C) 2016 ArtyCo (Artjoms Petrovs), http://artjoms.lv/
# --
# This software comes with ABSOLUTELY NO WARRANTY. For details, see
# the enclosed file COPYING for license information (AGPL). If you
# did not receive this file, see http://www.gnu.org/licenses/agpl.txt.
# --
package Kernel::GenericInterface::Operation::LinkObject::LinkAdd;
use strict;
use warnings;
use Kernel::GenericInterface::Operation::Common;
use Kernel::System::LinkObject;
use Kernel::System::VariableCheck qw(IsStringWithData IsHashRefWithData);
=head1 NAME
Kernel::GenericInterface::Operation::LinkObject::LinkAdd - GenericInterface Link Create Operation backend
=head1 SYNOPSIS
=head1 PUBLIC INTERFACE
=over 4
=cut
=item new()
usually, you want to create an instance of this
by using Kernel::GenericInterface::Operation->new();
=cut
sub new {
my ( $Type, %Param ) = #_;
my $Self = {};
bless( $Self, $Type );
# check needed objects
for my $Needed (
qw(DebuggerObject ConfigObject MainObject LogObject TimeObject DBObject EncodeObject WebserviceID)
)
{
if ( !$Param{$Needed} ) {
return {
Success => 0,
ErrorMessage => "Got no $Needed!"
};
}
$Self->{$Needed} = $Param{$Needed};
}
# create additional objects
$Self->{CommonObject} = Kernel::GenericInterface::Operation::Common->new( %{$Self} );
$Self->{LinkObject}
= Kernel::System->LinkObject->new( %{$Self} );
return $Self;
}
=item Run()
Create a new link.
my $Result = $OperationObject->Run(
Data => {
SourceObject => 'Ticket',
SourceKey => '321',
TargetObject => 'Ticket',
TargetKey => '12345',
Type => 'ParentChild',
State => 'Valid',
UserID => 1,
},
);
$Result = {
Success => 1, # 0 or 1
ErrorMessage => '', # In case of an error
Data => {
Result => 1, # 0 or 1
},
};
=cut
sub Run {
my ( $Self, %Param ) = #_;
# check needed stuff
if ( !IsHashRefWithData( $Param{Data} ) ) {
return $Self->{CommonObject}->ReturnError(
ErrorCode => 'LinkAdd.MissingParameter',
ErrorMessage => "LinkAdd: The request is empty!",
);
}
my $LinkID = $Self->{LinkObject}->LinkAdd(
%Param,
);
if ( !$LinkID ) {
return $Self->{CommonObject}->ReturnError(
ErrorCode => 'LinkAdd.AuthFail',
ErrorMessage => "LinkAdd: Authorization failing!",
);
}
return {
Success => 1,
Data => {
Result => $LinkID,
},
};
}
1;
=back
=head1 TERMS AND CONDITIONS
This software is part of the OTRS project (L<http://otrs.org/>).
This software comes with ABSOLUTELY NO WARRANTY. For details, see
the enclosed file COPYING for license information (AGPL). If you
did not receive this file, see L<http://www.gnu.org/licenses/agpl.txt>.
=cut
And afterwards it should appear and can be used from the Admin -> WebServices -> Available Operations dropdown and of course can be used as a webservice.
A PHP usage example can be seen below:
#### Initialize new client session ####
$client = new SoapClient(
null,
array(
'location' => $url,
'uri' => "Core",
'trace' => 1,
'login' => $username,
'password' => $password,
'style' => SOAP_RPC,
'use' => SOAP_ENCODED
)
);
#### Create and send the SOAP Function Call ####
$success = $client->__soapCall("Dispatch",
array($username, $password,
"LinkObject", "LinkAdd",
"SourceObject", 'Ticket',
"SourceKey", $ticket_id1,
"TargetObject", 'Ticket',
"TargetKey", $ticket_id2,
"Type", 'ParentChild',
"State", 'Valid',
"UserID", '1'
));
In case of errors - enable debugging, review the System Log and check all the initial settings of OTRS
Good Luck!
UPDATE #2
To register a webservice - press the button Add new webservice, name it as you want it and set the following settings ( Select the LinkAdd Operation ) and save it
UPDATE #3
Here is an updated module file for OTRS 5
# --
# Kernel/GenericInterface/Operation/LinkObject/LinkAdd.pm - GenericInterface LinkAdd operation backend
# Copyright (C) 2016 ArtyCo (Artjoms Petrovs), http://artjoms.lv/
# --
# This software comes with ABSOLUTELY NO WARRANTY. For details, see
# the enclosed file COPYING for license information (AGPL). If you
# did not receive this file, see http://www.gnu.org/licenses/agpl.txt.
# --
package Kernel::GenericInterface::Operation::LinkObject::LinkAdd;
use strict;
use warnings;
use Kernel::GenericInterface::Operation::Common;
use Kernel::System::LinkObject;
use Kernel::System::VariableCheck qw(IsStringWithData IsHashRefWithData);
=head1 NAME
Kernel::GenericInterface::Operation::LinkObject::LinkAdd - GenericInterface Link Create Operation backend
=head1 SYNOPSIS
=head1 PUBLIC INTERFACE
=over 4
=cut
=item new()
usually, you want to create an instance of this
by using Kernel::GenericInterface::Operation->new();
=cut
sub new {
my ( $Type, %Param ) = #_;
my $Self = {};
bless( $Self, $Type );
# check needed objects
for my $Needed (
qw( DebuggerObject WebserviceID )
)
{
if ( !$Param{$Needed} ) {
return {
Success => 0,
ErrorMessage => "Got no $Needed!"
};
}
$Self->{$Needed} = $Param{$Needed};
}
# create additional objects
$Self->{CommonObject} = Kernel::GenericInterface::Operation::Common->new( %{$Self} );
$Self->{LinkObject}
= $Kernel::OM->Get('Kernel::System::LinkObject');
return $Self;
}
=item Run()
Create a new link.
my $Result = $OperationObject->Run(
Data => {
SourceObject => 'Ticket',
SourceKey => '321',
TargetObject => 'Ticket',
TargetKey => '12345',
Type => 'ParentChild',
State => 'Valid',
UserID => 1,
},
);
$Result = {
Success => 1, # 0 or 1
ErrorMessage => '', # In case of an error
Data => {
Result => 1, # 0 or 1
},
};
=cut
sub Run {
my ( $Self, %Param ) = #_;
# check needed stuff
if ( !IsHashRefWithData( $Param{Data} ) ) {
return $Self->{CommonObject}->ReturnError(
ErrorCode => 'LinkAdd.MissingParameter',
ErrorMessage => "LinkAdd: The request is empty!",
);
}
my $LinkID = $Self->{LinkObject}->LinkAdd(
%Param,
);
if ( !$LinkID ) {
return $Self->{CommonObject}->ReturnError(
ErrorCode => 'LinkAdd.AuthFail',
ErrorMessage => "LinkAdd: Authorization failing!",
);
}
return {
Success => 1,
Data => {
Result => $LinkID,
},
};
}
1;
=back
=head1 TERMS AND CONDITIONS
This software is part of the OTRS project (L<http://otrs.org/>).
This software comes with ABSOLUTELY NO WARRANTY. For details, see
the enclosed file COPYING for license information (AGPL). If you
did not receive this file, see L<http://www.gnu.org/licenses/agpl.txt>.
=cut
After lot of work, i've found the solution to made it by POST REST call.
My main trouble was about creating LinkObject with right %Param.
So, i've implement direct code to aquire right call LinkAdd.
Mainly, Artjoman provide the way. But i catch some errors on it, so here is another perl module in OTRS_HOME/Custom/Kernel/GenericInterface/Operation/LinkObject/LinkAdd.pm:
# --
# Kernel/GenericInterface/Operation/LinkObject/LinkAdd.pm - GenericInterface LinkAdd operation backend
# Copyright (C) 2016 ArtyCo (Artjoms Petrovs), http://artjoms.lv/
# --
# This software comes with ABSOLUTELY NO WARRANTY. For details, see
# the enclosed file COPYING for license information (AGPL). If you
# did not receive this file, see http://www.gnu.org/licenses/agpl.txt.
# --
package Kernel::GenericInterface::Operation::LinkObject::LinkAdd;
use strict;
use warnings;
use Kernel::System::ObjectManager;
use Kernel::System::VariableCheck qw(IsStringWithData IsHashRefWithData);
=head1 NAME
Kernel::GenericInterface::Operation::LinkObject::LinkAdd - GenericInterface Link Create Operation backend
=head1 SYNOPSIS
=head1 PUBLIC INTERFACE
=over 4
=cut
=item new()
usually, you want to create an instance of this
by using Kernel::GenericInterface::Operation->new();
=cut
sub new {
my ( $Type, %Param ) = #_;
my $Self = {};
bless( $Self, $Type );
# check needed objects
for my $Needed (
qw( DebuggerObject WebserviceID )
)
{
if ( !$Param{$Needed} ) {
return {
Success => 0,
ErrorMessage => "Got no $Needed!"
};
}
$Self->{$Needed} = $Param{$Needed};
}
# create additional objects
local $Kernel::OM = Kernel::System::ObjectManager->new( %{$Self} );
$Self->{LinkObject}
= $Kernel::OM->Get('Kernel::System::LinkObject');
return $Self;
}
=item Run()
Create a new link.
my $Result = $OperationObject->Run(
Data => {
SourceObject => 'Ticket',
SourceKey => '321',
TargetObject => 'Ticket',
TargetKey => '12345',
Type => 'ParentChild',
State => 'Valid',
UserID => 1,
},
);
$Result = {
Success => 1, # 0 or 1
ErrorMessage => '', # In case of an error
Data => {
Result => 1, # 0 or 1
},
};
=cut
sub Run {
my ( $Self, %Param ) = #_;
# check needed stuff
if ( !IsHashRefWithData( $Param{Data} ) ) {
return $Self->ReturnError(
ErrorCode => 'LinkAdd.MissingParameter',
ErrorMessage => "LinkAdd: The request is empty!",
);
}
my $LinkID = $Self->{LinkObject}->LinkAdd(
'SourceKey' => $Param{Data}{SourceKey},
'SourceObject' => $Param{Data}{SourceObject},
'State' => $Param{Data}{State},
'TargetKey' => $Param{Data}{TargetKey},
'TargetObject' => $Param{Data}{TargetObject},
'Type' => $Param{Data}{Type},
'UserID' => $Param{Data}{UserID},
);
if ( !$LinkID ) {
return $Self->ReturnError(
ErrorCode => 'LinkAdd.AuthFail',
ErrorMessage => "LinkAdd: Authorization failing!",
);
}
return {
Success => 1,
Data => {
Result => $LinkID,
},
};
}
sub ReturnError {
my ( $Self, %Param ) = #_;
$Self->{DebuggerObject}->Error(
Summary => $Param{ErrorCode},
Data => $Param{ErrorMessage},
);
# return structure
return {
Success => 1,
ErrorMessage => "$Param{ErrorCode}: $Param{ErrorMessage}",
Data => {
Error => {
ErrorCode => $Param{ErrorCode},
ErrorMessage => $Param{ErrorMessage},
},
},
};
}
1;
=back
=head1 TERMS AND CONDITIONS
This software is part of the OTRS project (L<http://otrs.org/>).
This software comes with ABSOLUTELY NO WARRANTY. For details, see
the enclosed file COPYING for license information (AGPL). If you
did not receive this file, see L<http://www.gnu.org/licenses/agpl.txt>.
=cut
So, making POST call to (http://otrs_host/otrs/nph-genericinterface.pl/Webservice/GenericTicketConnectorREST/LinkAdd?UserLogin=login&Password=password) with json
{"SourceObject":"Ticket","SourceKey":"7","TargetObject":"ITSMConfigItem","TargetKey":"1","Type":"DependsOn","State":"Valid","UserID":"1"}
will create a link between Ticket and ITSMConfigItem (not a computer, hardware and so on.)
I think, this simple and quite rude solution will help to understand how to add a full-api operations to your REST otrs with a better(but working) way.

How can I do a scrolled search on MetaCPAN?

I'm trying to convert this script to use the new Elasticsearch official client instead of the older (now deprecated) ElasticSearch.pm, but I can't get the scrolled search to work. Here's what I've got:
#! /usr/bin/perl
use strict;
use warnings;
use 5.010;
use Elasticsearch ();
use Elasticsearch::Scroll ();
my $es = Elasticsearch->new(
nodes => 'http://api.metacpan.org:80',
cxn => 'NetCurl',
cxn_pool => 'Static::NoPing',
#log_to => 'Stderr',
#trace_to => 'Stderr',
);
say 'Getting all results at once works:';
my $results = $es->search(
index => 'v0',
type => 'release',
body => {
filter => { range => { date => { gte => '2013-11-28T00:00:00.000Z' } } },
fields => [qw(author archive date)],
},
);
foreach my $hit (#{ $results->{hits}{hits} }) {
my $field = $hit->{fields};
say "#$field{qw(date author archive)}";
}
say "\nUsing a scrolled search does not work:";
my $scroller = Elasticsearch::Scroll->new(
es => $es,
index => 'v0',
search_type => 'scan',
size => 100,
type => 'release',
body => {
filter => { range => { date => { gte => '2013-11-28T00:00:00.000Z' } } },
fields => [qw(author archive date)],
},
);
while (my $hit = $scroller->next) {
my $field = $hit->{fields};
say "#$field{qw(date author archive)}";
} # end while $hit
The first search, where I'm just getting all the results in 1 chunk, works fine. But the second search, where I'm trying to scroll through the results, produces:
Using a scrolled search does not work:
[Request] ** [http://api.metacpan.org:80]-[500]
ActionRequestValidationException[Validation Failed: 1: scrollId is missing;],
called from sub Elasticsearch::Transport::try {...}
at .../Try/Tiny.pm line 83. With vars: {'body' =>
'ActionRequestValidationException[Validation Failed: 1: scrollId is missing;]',
'request' => {'path' => '/_search/scroll','serialize' => 'std',
'body' => 'c2Nhbjs1OzE3MjU0NjM2MjowakFELUU3VFFibTJIZW1ibUo0SUdROzE3MjU0NjM2NDowakFELUU3VFFibTJIZW1ibUo0SUdROzE3MjU0NjM2MTowakFELUU3VFFibTJIZW1ibUo0SUdROzE3MjU0NjM2MDowakFELUU3VFFibTJIZW1ibUo0SUdROzE3MjU0NjM2MzowakFELUU3VFFibTJIZW1ibUo0SUdROzE7dG90YWxfaGl0czoxNDQ7',
'method' => 'GET','qs' => {'scroll' => '1m'},'ignore' => [],
'mime_type' => 'application/json'},'status_code' => 500}
What am I doing wrong? I'm using Elasticsearch 0.75 and Elasticsearch-Cxn-NetCurl 0.02, and Perl 5.18.1.
I finally got it working with the newer Search::Elasticsearch official client. Here's the short version:
#! /usr/bin/perl
use strict;
use warnings;
use 5.010;
use Search::Elasticsearch ();
my $es = Search::Elasticsearch->new(
cxn_pool => 'Static::NoPing',
nodes => 'api.metacpan.org:80',
);
my $scroller = $es->scroll_helper(
index => 'v0',
type => 'release',
search_type => 'scan',
scroll => '2m',
size => 100,
body => {
fields => [qw(author archive date)],
query => { range => { date => { gte => '2015-02-01T00:00:00.000Z' } } },
},
);
while (my $hit = $scroller->next) {
my $field = $hit->{fields};
say "#$field{qw(date author archive)}";
} # end while $hit
Note that the records are not sorted when you do a scrolled search. I wound up dumping the records into a temporary database and sorting them locally. The updated script is on GitHub.
I don't have a direct answer, but I might have an approach to trouble shooting:
I followed your link to the Elasticsearch::Client and found a scroll() method:
https://metacpan.org/pod/Elasticsearch::Client::Direct#scroll
This method takes scroll and scroll_id as parameters. scroll is the number of minutes that you can keep calling the scroll method before the search expires. scroll_id is a marker to the place where the last call to scroll() ended.
$results = $e->scroll(
scroll => '1m',
scroll_id => $id
);
Elasticsearch::Scroll is an object oriented wrapper around scroll() which hides scroll and scroll_id.
I would run perl -d on your script, and step in to $scroller->next and follow that as far down the rabbit hole as you can. Something in there is trying a search which should be populating scroll_id or scrollId and is failing.
My description here is admittedly pretty rough... I ran across an accurate description of what the scroll id is and does during my googling, but I can't seem to find it again.

Get Perl to print full "key path" to values (Data::Dumper won't)

$foo{alongkeyname}{anotherlongkeyname}{yetanotherlongkeyname}{afairlyshortkeynamewellitgotlongwhileiwastypingitsoiguessnot}{bob}{something} = 1;
How do I get Perl to print $foo and show me the full "path name" to
get to 1? In other words, I want output that looks similar to the
input above.
Data::Dumper won't do this, and the long key names wrap the output,
making even the indented form less useful.
Ages ago, I wrote my own "unfold" subroutine at https://github.com/barrycarter/bcapps/blob/master/bclib.pl#L109 which outputs:
<hash HASH(0x92a33a4)>
<key>
alongkeyname
</key>
<val>
<hash HASH(0x95103b4)>
<key>
anotherlongkeyname
</key>
<val>
<hash HASH(0x9510464)>
<key>
yetanotherlongkeyname
</key>
<val>
<hash HASH(0x9510434)>
<key>
afairlyshortkeynamewellitgotlongwhileiwastypingitsoiguessnot
</key>
<val>
<hash HASH(0x95bae7c)>
<key>
bob
</key>
<val>
<hash HASH(0x95cf8bc)>
something: 1
</hash HASH(0x95cf8bc)>
</val>
</hash HASH(0x95bae7c)>
</val>
</hash HASH(0x9510434)>
</val>
</hash HASH(0x9510464)>
</val>
</hash HASH(0x95103b4)>
</val>
</hash HASH(0x92a33a4)>
but that's not really useful either.
Real-life project inspiring this question: pulling SYNOP/BUOY data from the
XML::Simple hashified output of metaf2xml
EDIT: Thank you Ben! I tried this and it worked great on my example. Then I tried it on another hash, and got:
$VAR1 = {'remark' => [{'obsStationType' => {'stationType' => {'v' => 'AO2'},'s' => 'AO2'}},{'needMaint' => {'s' => '$'}}],'QNH' => {'inHg' => {'v' => '29.99'},'s' => 'A2999'},'visPrev' => {'distance' => {'u' => 'SM','v' => '7','rp' => '1'},'s' => '7SM'},'sfcWind' => {'wind' => {'speed' => {'u' => 'KT','v' => '3'},'dir' => {'rn' => '5','v' => '60','rp' => '4'}},'measurePeriod' => {'u' => 'MIN','v' => '2'},'s' => '06003KT'},'obsStationId' => {'id' => {'v' => 'KBTR'},'s' => 'KBTR'},'obsTime' => {'s' => '080940Z','timeAt' => {'hour' => {'v' => '09'},'minute' => {'v' => '40'},'day' => {'v' => '08'}}},'s' => 'KBTR 080940Z 06003KT 7SM SCT003 BKN200 24/23 A2999 RMK AO2 $','cloud' => [{'cloudCover' => {'v' => 'SCT'},'s' => 'SCT003','cloudBase' => {'u' => 'FT','v' => '300'}},{'cloudCover' => {'v' => 'BKN'},'s' => 'BKN200','cloudBase' => {'u' => 'FT','v' => '20000'}}],'temperature' => {'relHumid4' => {'v' => '94.15'},'dewpoint' => {'temp' => {'u' => 'C','v' => '23'}},'relHumid3' => {'v' => '94.03'},'relHumid1' => {'v' => '94.16'},'relHumid2' => {'v' => '94.17'},'air' => {'temp' => {'u' => 'C','v' => '24'}},'s' => '24/23'}};
So the question I think I want to answer is: what value of this hash will give me the "94.15" you see above? It's sort of hard to tell from the above.
(If anyone's curious, the answer is $hash{temperature}{relHumid4}{v})
MORE EDIT: Thanks, Ilmari. I tried dump_var($VAR1) w/ my VAR1 above and got...
HASH(0x9ae6764) = undef;
I also tried dump_var({$VAR1}) with the same result. I might've missed something. Could you cut and paste my VAR1 above and see if it works? I did export 'Dumper' as you indicate in your 'use' statement.
Here's a quick do-it-yourself solution:
use Data::Dumper 'Dumper';
sub dump_var {
my ($prefix, $var) = #_;
my #rv;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Terse = 1;
if (ref $var eq 'ARRAY' and #$var) {
for my $i (0 .. $#$var) {
push #rv, dump_var($prefix . "->[$i]", $var->[$i]);
}
} elsif (ref $var eq 'HASH' and %$var) {
foreach my $key (sort keys %$var) {
push #rv, dump_var($prefix . '->{'.Dumper($key).'}', $var->{$key});
}
} elsif (ref $var eq 'SCALAR') {
push #rv, dump_var('${' . $prefix . '}', $$var);
} else {
push #rv, "$prefix = " . Dumper($var) . ";\n";
}
return #rv;
}
and some test code:
my $foo = {
alpha => [ 'beta', \ 'gamma' ],
one => { two => { three => 3, four => 3.141 },
five => { six => undef, seven => \*STDIN },
},
foobar => sub { print "Hello, world!\n"; },
};
print dump_var('$foo' => $foo);
which produces the output:
$foo->{'alpha'}->[0] = 'beta';
${$foo->{'alpha'}->[1]} = 'gamma';
$foo->{'foobar'} = sub { "DUMMY" };
$foo->{'one'}->{'five'}->{'seven'} = \*::STDIN;
$foo->{'one'}->{'five'}->{'six'} = undef;
$foo->{'one'}->{'two'}->{'four'} = '3.141';
$foo->{'one'}->{'two'}->{'three'} = 3;
Edit: While testing a PHP version of this code, I realized that it didn't correctly handle empty arrays and hashes. I've fixed the code so that such values are passed directly to Dumper.
Data::Dumper can print output similar to what you're looking for by setting Indent to 0.
[ben#imac ~]$ perl
use Data::Dumper;
$Data::Dumper::Indent = 0;
$foo{alongkeyname}{anotherlongkeyname}{yetanotherlongkeyname}{afairlyshortkeynamewellitgotlongwhileiwastypingitsoiguessnot}{bob}{something} = 1;
print Dumper(\%foo);
Output:
$VAR1 = {'alongkeyname' => {'anotherlongkeyname' => {'yetanotherlongkeyname' => {'afairlyshortkeynamewellitgotlongwhileiwastypingitsoiguessnot' => {'bob' => {'something' => 1}}}}}};
For a possible solution to the problem behind your question, please see the feature announced today in the Project News for metaf2xml.

perl - setting up conditions to find correct key in a hash

Problem:
Seeing exists argument is not a HASH or ARRAY element
Need help setting up several conditions to grab the right key.
Code: (I'm not sure also if my conditions are set up correctly. Need advice troubleshooting)
my $xml = qx(#cmdargs);
my $data = XMLin($xml);
my $size=0;
# checking for error string, if file not found then just exit
# otherwise check the hash keys for filename and get its file size
if (exists $data->{class} =~ /FileNotFound/) {
print "The directory: $Path does not exist\n";
exit;
} elsif (exists $data->{file}->{path}
and $data->{file}->{path} =~/test-out-XXXXX/) {
$size=$data->{file}->{size};
print "FILE SIZE:$size\n";
} else {
# print "Nothing to print.\n";
}
# print "$data";
print Dumper( $data );
My Data:
Data structure for xml file with FileNotFound:
$VAR1 = {
'file' => {},
'path' => '/source/feeds/customer/testA',
'class' => 'java.io.FileNotFoundException',
'message' => '/source/feeds/customer/testA: No such file or directory.'
};
Data structure for xml file found:
$VAR1 = {
'recursive' => 'no',
'version' => '0.20.202.1.1101050227',
'time' => '2011-09-30T02:49:39+0000',
'filter' => '.*',
'file' => {
'owner' => 'test_act',
'replication' => '3',
'blocksize' => '134217728',
'permission' => '-rw-------',
'path' => '/source/feeds/customer/test/test-out-00000',
'modified' => '2011-09-30T02:48:41+0000',
'size' => '135860644',
'group' => '',
'accesstime' => '2011-09-30T02:48:41+0000'
},
The interpreter is probably thinking you meant:
exists($data->{class}=~/FileNotFound/)
Try:
exists $data->{class} and $data->{class}=~/FileNotFound/
instead.