Generate Excel output using Win32::OLE in Perl - perl

I am a beginner in Perl and have tried playing around with Perl much to understand its ways and working! I have a basic knowledge of arays, hashes and related topics. I have to develop a script for a topic and i am quite unsure how to go about it. I desperately need help and am very grateful to anyone who can explain the 'how to do' part!
I have a code with 3 parts in it which does the same thing thrice for 3 different lets say components. Basic idea is, it takes all the components marked 'A' from an excel file, iterates through the excel file, adds up its corresponding RAM and ROM values and prints out the output without duplicate entries. The 2nd and 3rd part are the same but for components 'B' and 'C'. So far i am able to print out the output of all 3 parts in a text file. But now i want all three outputs in an excel workbook as 3 separate worksheets!
I am not particularly sure how to go about it. Any ideas are really welcome!!!
PS: Please forgive me if i have not typed the code right in the forum! This is my first post!!
Here is how my code looks so far:
# This Test script was created to try out the possible methods to extract all the Names from the
# excel report without duplicate entries and find their corresponding RAM/ROM size sum
# -excel D:\Abc\Test.xlsx -out D:\Abc\Output
sub usage($)
{
return shift(#_) . <<"END_USAGE";
Usage: $0 -excel Specify the file path.
-out outputdirectory Specify output directiory
END_USAGE
}
use Getopt::Long;
use Win32::OLE;
use List::Util qw(sum);
use Data::Dumper qw(Dumper);
my $output_path = ();
my $excel_path = ();
my $no_rows = ();
my $lastCol = ();
GetOptions("excel=s" => \$excel_path,
"out=s" => \$output_path,
"h|help" => \$help,
);
#help message
die usage("") if ($help);
system(cls);
print "\n*******************************************************************\n";
print "Component Overview \n";
print "*******************************************************************\n";
print "Please wait, Processing may take couple of minutes... \n";
##File handler for the script file.
$log_path = $output_path."\\log.txt";
$output_file_path = $output_path."\\TestExcel.xlsx";
open LogFile,">",$log_path or die "Cannot create the log file:$log_path !!!";
print LogFile "Start time :".localtime()."\n";
# Start Excel and make it visible
my $xlApp = Win32::OLE->GetActiveObject('Excel.Application') || Win32::OLE->new('Excel.Application', 'Quit');
$xlApp->{Visible} = 0;
#Opening the work book
my $workBook = $xlApp->Workbooks->Open($excel_path);
#print "X: " . $workBook . " - " . $excel_path . "\n";
my $excelSheet = $workBook->Worksheets("Report");
$excelSheet->Activate();
print "Reading the file...\n";
&ReadExcel();
print LogFile "Completed time :".localtime()."\n";
print "\nCompleted.Please close this window...\n" ;
print "*******************************************************************\n";
# Sub routine to parse the cosipa file
sub ReadExcel()
{
my $row_index;
#Findings the number of valid rows
$no_rows = $excelSheet->UsedRange->Rows->{'Count'};
$lastCol = $excelSheet->UsedRange->Columns->{'Count'};
$row_index = findRowindex();
my #comp_array = ();
# Name => ResourceType => size
my $resultData = {};
for(my $index=($row_index+1);$index<=$no_rows;$index++)
{
my $X = $excelSheet->Cells($index,6)->Value();
my $Y = $excelSheet->Cells($index,7)->Value();
my $name = $excelSheet->Cells($index,9)->Value();
my $resourceType = $excelSheet->Cells($index,3)->Value();
my $size = $excelSheet->Cells($index,2)->Value();
#Name Overview
my $currNameTypeMap;
if ( ! exists $resultNameData->{ $name } ) # ->: arrow operator is used to dereference reference to arrays or hashes.
{
$resultNameData->{ $name } = {};
}
$currNameTypeMap = $resultNameData->{ $name };
$currNameTypeMap->{ $resourceType } += $size;
# Y Overview
my $currYTypeMap;
if ( ! exists $resultYData->{ $Y } ) # ->: arrow operator is used to dereference reference to arrays or hashes.
{
$resultYData->{ $cluster } = {};
}
$currYTypeMap = $resultYData->{ $Y };
$currYTypeMap->{ $resourceType } += $size;
# X Overview
my $currXTypeMap;
if ( ! exists $resultXData->{ $X } ) # ->: arrow operator is used to dereference reference to arrays or hashes.
{
$resultXData->{ $X } = {};
}
$currXTypeMap = $resultXData->{ $X };
$currXTypeMap->{ $resourceType } += $size;
}
my #uniqNameArr = sort keys %$resultNameData;
my #uniqYArr = sort keys %$resultYData;
my #uniqXArr = sort keys %$resultXData;
for my $currName ( #uniqNameArr )
{
print $currName . "\n". " RAM: " . $resultNameData->{ $currName }-> { "RAM" } . ", ROM: " . $resultNameData->{ $currName }-> { "ROM" } . "\n";
#print Dumper %$resultData;
}
print "----------------------------------------------------------------------- \n";
for my $currY ( #uniqYArr )
{
print $currY. "\n". " RAM: " . $resultYData->{ $currY }-> { "RAM" } . ", ROM: " . $resultYData->{ $currY }-> { "ROM" } . "\n";
}
print "------------------------------------------------------------------------ \n";
for my $currX ( #uniqXArr )
{
print $currX . "\n". " RAM: " . $resultXData->{ $currX }-> { "RAM" } . ", ROM: " . $resultXData->{ $currX }-> { "ROM" } . "\n";
}
}
#Sub routine to find the starting row index
sub findRowindex()
{
my $ret = ();
for(my $index=1;$index<$no_rows;$index++)
{
if(defined($excelSheet->Cells($index,1)))
{
my $cel_value = $excelSheet->Cells($index,1)->Value();
if($cel_value =~ m/^Name$/i)
{
$ret = $index;
last;
}
}
}
return $ret;
}
#Trim function
sub trim {
(my $s = $_[0]) =~ s/^\s+|\s+$//g;
return $s;
}

A workaround: You could use Excel::Writer::XLSX to create Excel files, it is working fine and quite robust. Here is how you could convert a tab separated file to Excel.
Reading excel: Spreadsheet::XLSX
use Text::Iconv;
my $converter = Text::Iconv -> new ("utf-8", "windows-1251");
use Spreadsheet::XLSX;
my $excel = Spreadsheet::XLSX -> new ('test.xlsx', $converter);
foreach my $sheet (#{$excel -> {Worksheet}}) {
printf("Sheet: %s\n", $sheet->{Name});
$sheet -> {MaxRow} ||= $sheet -> {MinRow};
foreach my $row ($sheet -> {MinRow} .. $sheet -> {MaxRow}) {
$sheet -> {MaxCol} ||= $sheet -> {MinCol};
foreach my $col ($sheet -> {MinCol} .. $sheet -> {MaxCol}) {
my $cell = $sheet -> {Cells} [$row] [$col];
if ($cell) {
printf("( %s , %s ) => %s\n", $row, $col, $cell -> {Val});
}
}
}
}
Writing excel: Excel::Writer::XLSX
my $workbook = Excel::Writer::XLSX->new( $xls_filename );
my $worksheet = $workbook->add_worksheet('data');
# Create a format for the headings
my $header_format = $workbook->add_format();
$header_format->set_bold();
$header_format->set_size( 18 );
$header_format->set_color( 'black' );
$header_format->set_align( 'center' );
my $row=0;
while (my $line = <$fh>){
chomp($line);
my #cols = split(/\t/,$line);
for(my $col=0;$col<#cols;$col++){
if ($row == 0 ){
$worksheet->write_string( $row, $col, $cols[$col],$header_format );
} else {
$worksheet->write_string( $row, $col, $cols[$col] );
}
}
$row++;
}
close($fh);
I hope this helps you.
Regards,

Related

Perl script to convert xls to csv

This script coverts xls to csv ok.
The challenge is that it does not convert blank cell in the xls to blanks in csv file.
Any help is appreciated: UPDATED SCRIPT
#!/usr/bin/perl
use strict;
use Spreadsheet::ParseExcel;
use Text::CSV;
my $sourcename = shift #ARGV or die "invocation: $0 <source file>\n";
my $source_excel = new Spreadsheet::ParseExcel;
my $source_book = $source_excel->Parse($sourcename)
or die "Could not open source Excel file $sourcename: $!";
my $storage_book;
foreach my $source_sheet_number (0 .. $source_book->{SheetCount}-1) {
my $source_sheet = $source_book->{Worksheet}[$source_sheet_number];
print "--------- SHEET:", $source_sheet->{Name}, "\n";
next unless defined $source_sheet->{MaxRow};
next unless $source_sheet->{MinRow} <= $source_sheet->{MaxRow};
next unless defined $source_sheet->{MaxCol};
next unless $source_sheet->{MinCol} <= $source_sheet->{MaxCol};
foreach my $row_index ($source_sheet->{MinRow} .. $source_sheet->{MaxRow}) {
foreach my $col_index ($source_sheet->{MinCol} .. $source_sheet->{MaxCol}) {
my $source_cell = $source_sheet->{Cells}[$row_index][$col_index];
if ($source_cell && $source_cell->Value) {
#print "( $row_index , $col_index ) =>", $source_cell->Value, "\t;";
print $source_cell->Value, ";";
}
else
{
print ";"
}
}
}
}
sample excel
EFG KDD ABS JME
FGO POP JET
converted as:
EFG;KDD;ABS;JME;
FGO;POP;JET;
but it should be:
EFG;KDD;ABS;JME;
FGO;;POP;JET;
You have to check if the value of the cell is initialized, not the cell it self.
Change:
if ($source_cell) {
#print "( $row_index , $col_index ) =>", $source_cell->Value, "\t;";
print $source_cell->Value, ";";
}
To:
if ($source_cell && $source_cell->Value) {
#print "( $row_index , $col_index ) =>", $source_cell->Value, "\t;";
print $source_cell->Value, ";";
} else {
print ";";
}
should work.
UPDATE:
foreach my $row_index ($source_sheet->{MinRow} .. $source_sheet->{MaxRow}) {
foreach my $col_index ($source_sheet->{MinCol} .. $source_sheet->{MaxCol}) {
my $source_cell = $source_sheet->{Cells}[$row_index][$col_index];
if ($source_cell && $source_cell->Value) {
print $source_cell->Value.";";
} else {
print ";";
}
}
print "\n";
}
}

Creating a hash using a function

I am trying to create a hash using a function in perl. Actually i was working on creating a binary search tree in perl. Below is the code :
sub newhash {
$data = shift;
$left = undef;
$right = undef;
%node = ("data"=>$data,"left"=>$left,"right"=>$right);
return (\%node);
}
$firstele = newhash(2);
foreach ( keys %$firstele )
{
print "$_:$firstele->{$_}\n";
}
$node = newhash(1);
foreach ( keys %$node )
{
print "$_:$node->{$_} \n";
}
foreach ( keys %$firstele )
{
print "$_:$firstele->{$_}\n";
}
The trouble is that when i am printing the original hash, the data key gets replaced by whatever i am passing to the newhash function . The output:
left:
right:
data:2
left:
right:
data:1
left:
right:
data:1
Any ideas why is the data key getting replaced?
use strict; would tell you about a bunch of undeclared variables; lexicalize them with my and it should solve your problem. As it stands, there's only one %node and you overwrite it with every call to newhash.
use strict;
sub newhash {
my $data = shift;
my $left;
my $right;
my %node = ( # <-- a brand new %node every time
data => $data,
left => $left,
right => $right,
);
return (\%node); # new %node, new reference
}
my $firstele = newhash(2);
print "firstele data: $firstele->{data}\n";
my $node = newhash(1);
print "node data: $node->{data}\n";
print "firstele data: $firstele->{data}\n";
Here is the code for adding elements in BT structure.
use strict;
use List::Util qw(first);
my (#input,$data);
print "Enter the data for being in a BST structure: ";
$data=<>;
chomp($data);
my $root=$data;
push(#input,$data);
while($data =~ m/\b-?\d{1,3}\b/){
my $idx=first { $input[$_] == $root } 0..$#input;
if($data<$root) {
for(my $i=0;$i<=$idx;$i++) {
next if($data>$input[$i]) ;
if($data<$input[$i]) {
splice(#input,$i,0,$data);
}
last;
}
}
if($data>$root) {
for(my $i=$idx;$i<=$#input;$i++) {
if($data>$input[$i]) {
if(($i+1==scalar(#input)) or ($data<$input[$i+1] && $i+1 !=
scalar(#input))) {
splice(#input,$i+1,0,$data);
last;
}
else {
next;
}
}
last;
}
}
print "Enter the number for being in a BT structure: ";
$data=<>;
chomp($data);
}
print "Final BT Array:\n",join(',', #input),"\n";

perl: persist set of strings with commit support

I have a set of strings that is modified inside a loop of 25k iterations. It's empty at the beginning, but 0-200 strings are randomly added or removed from it in each cycle. At the end, the set contains about 80k strings.
I want to make it resumable. The set should be saved to disk after each cycle and be loaded on resume.
What library can I use? The amount of raw data is ~16M, but the changes are usually small. I don't want it to rewrite the whole store on each iteration.
Since the strings are paths, I'm thinking of storing them in a log file like this:
+a
+b
commit
-b
+d
commit
In the beginning the file is loaded into a hash and then compacted. If there's no commit line in the end, the last block is not taken into account.
The Storable package brings persistence to your Perl data structures (SCALAR, ARRAY, HASH or REF objects), i.e. anything that can be conveniently stored to disk and retrieved at a later time.
I've decided to put away the heavy artillery and write something simple:
package LoL::IMadeADb;
sub new {
my $self;
( my $class, $self->{dbname} ) = #_;
# open for read, then write. create if not exist
#msg "open $self->{dbname}";
open(my $fd, "+>>", $self->{dbname}) or die "cannot open < $self->{dbname}: $!";
seek($fd, 0, 0);
$self->{fd} = $fd;
#msg "opened";
$self->{paths} = {};
my $href = $self->{paths};
$self->{nlines} = 0;
my $lastcommit = 0;
my ( $c, $rest );
while(defined($c = getc($fd)) && substr(($rest = <$fd>), -1) eq "\n") {
$self->{nlines}++;
chomp($rest);
if ($c eq "c") {
$lastcommit = tell($fd);
#msg "lastcommit: " . $lastcommit;
} elsif ($c eq "+") {
$href->{$rest} = undef;
} elsif ($c eq "-") {
delete $href->{$rest};
}
#msg "line: '" . $c . $rest . "'";
}
if ($lastcommit < tell($fd)) {
print STDERR "rolling back incomplete file: " . $self->{dbname} . "\n";
seek($fd, $lastcommit, 0);
while(defined($c = getc($fd)) && substr(($rest = <$fd>), -1) eq "\n") {
$self->{nlines}--;
chomp($rest);
if ($c eq "+") {
delete $href->{$rest};
} else {
$href->{$rest} = undef;
}
}
truncate($fd, $lastcommit) or die "cannot truncate $self->{dbname}: $!";
print STDERR "rolling back incomplete file; done\n";
}
#msg "entries = " . (keys( %{ $href })+0) . ", nlines = " . $self->{nlines} . "\n";
bless $self, $class
}
sub add {
my ( $self , $path ) = #_;
if (!exists $self->{paths}{$path}) {
$self->{paths}{$path} = undef;
print { $self->{fd} } "+" . $path . "\n";
$self->{nlines}++;
$self->{changed} = 1;
}
undef
}
sub remove {
my ( $self , $path ) = #_;
if (exists $self->{paths}{$path}) {
delete $self->{paths}{$path};
print { $self->{fd} } "-" . $path . "\n";
$self->{nlines}++;
$self->{changed} = 1;
}
undef
}
sub save {
my ( $self ) = #_;
return undef unless $self->{changed};
my $fd = $self->{fd};
my #keys = keys %{$self->{paths}};
if ( $self->{nlines} - #keys > 5000 ) {
#msg "compacting";
close($fd);
my $bkpdir = dirname($self->{dbname});
($fd, my $bkpname) = tempfile(DIR => $bkpdir , SUFFIX => ".tmp" ) or die "cannot create backup file in: $bkpdir: $!";
$self->{nlines} = 1;
for (#keys) {
print { $fd } "+" . $_ . "\n" or die "cannot write backup file: $!";
$self->{nlines}++;
}
print { $fd } "c\n";
close($fd);
move($bkpname, $self->{dbname})
or die "cannot rename " . $bkpname . " => " . $self->{dbname} . ": $!";
open($self->{fd}, ">>", $self->{dbname}) or die "cannot open < $self->{dbname}: $!";
} else {
print { $fd } "c\n";
$self->{nlines}++;
# flush:
my $previous_default = select($fd);
$| ++;
$| --;
select($previous_default);
}
$self->{changed} = 0;
#print "entries = " . (#keys+0) . ", nlines = " . $self->{nlines} . "\n";
undef
}
1;

Find unused "use'd" Perl modules

I am working on a very large, very old "historically grown" codebase. In the past, there were often people thinking "Oh, I may need this and that module, so I just include it...", and later, people often "cached" Data inside of modules ("use ThisAndThat" needing a few seconds to load some hundred MB from DB to RAM, yeah, its really a stupid Idea, we are working on that too) and so, often, we have a small module use'ing like 20 or 30 modules, from who 90% are totally unused in the source itself, and, because of "caching" in several use'd submodules, modules tend to take up one minute to load or even more, which is, of course, not acceptable.
So, Im trying to get that done better. Right now, my way is looking through all the modules, understanding them as much as possible and I look at all the modules including them and see whether they are needed or not.
Is there any easier way? I mean: There are functions returning all subs a module has like
...
return grep { defined &{"$module\::$_"} } keys %{"$module\::"}
, so, aint there any simple way to see which ones are exported by default and which ones come from where and are used in the other modules?
A simple example is Data::Dumper, which is included in nearly every file, even, when all debug-warns and prints and so on arent in the script anymore. But still the module has to load Data::Dumper.
Is there any simple way to check that?
Thanks!
The following code could be part of your solution - it will show you which symbols are imported for each instance of use:
package traceuse;
use strict;
use warnings;
use Devel::Symdump;
sub import {
my $class = shift;
my $module = shift;
my $caller = caller();
my $before = Devel::Symdump->new($caller);
my $args = \#_;
# more robust way of emulating use?
eval "package $caller; require $module; $module\->import(\#\$args)";
my $after = Devel::Symdump->new($caller);
my #added;
my #after_subs = $after->functions;
my %before_subs = map { ($_,1) } $before->functions;
for my $k (#after_subs) {
push(#added, $k) unless $before_subs{$k};
}
if (#added) {
warn "using module $module added: ".join(' ', #added)."\n";
} else {
warn "no new symbols from using module $module\n";
}
}
1;
Then just replace "use module ..." with "use traceuse module ...", and you'll get a list of the functions that were imported.
Usage example:
package main;
sub foo { print "debug: foo called with: ".Dumper(\#_)."\n"; }
use traceuse Data::Dumper;
This will output:
using module Data::Dumper added: main::Dumper
i.e. you can tell which functions were imported in robust way. And you can easily extend this to report on imported scalar, array and hash variables - check the docs on Devel::Symdump.
Determine which functions are actually used is the other half of the equation. For that you might be able to get away with a simple grep of your source code - i.e. does Dumper appear in the module's source code that's not on a use line. It depends on what you know about your source code.
Notes:
there may be a module which does what traceuse does - I haven't checked
there might be a better way to emulate "use" from another package
I kind of got of got it to work with PPI. It looks like this:
#!/usr/local/bin/perl
use strict;
use warnings;
use Data::Dumper;
use Term::ANSIColor;
use PPI;
use PPI::Dumper;
my %doneAlready = ();
$" = ", ";
our $maxDepth = 2;
my $showStuffOtherThanUsedOrNot = 0;
parse("/modules/Test.pm", undef, undef, 0);
sub parse {
my $file = shift;
my $indent = shift || 0;
my $caller = shift || $file;
my $depth = shift || 0;
if($depth && $depth >= $maxDepth) {
return;
}
return unless -e $file;
if(exists($doneAlready{$file}) == 1) {
return;
}
$doneAlready{$file} = 1;
my $skript = PPI::Document->new($file);
my #included = ();
eval {
foreach my $x (#{$skript->find("PPI::Statement::Include")}) {
foreach my $y (#{$x->{children}}) {
push #included, $y->{content} if (ref $y eq "PPI::Token::Word" && $y->{content} !~ /^(use|vars|constant|strict|warnings|base|Carp|no)$/);
}
}
};
my %double = ();
print "===== $file".($file ne $caller ? " (Aufgerufen von $caller)" : "")."\n" if $showStuffOtherThanUsedOrNot;
if($showStuffOtherThanUsedOrNot) {
foreach my $modul (#included) {
next unless -e createFileName($modul);
my $is_crap = ((exists($double{$modul})) ? 1 : 0);
print "\t" x $indent;
print color("blink red") if($is_crap);
print $modul;
print color("reset") if($is_crap);
print "\n";
$double{$modul} = 1;
}
}
foreach my $modul (#included) {
next unless -e createFileName($modul);
my $anyUsed = 0;
my $modulDoc = parse(createFileName($modul), $indent + 1, $file, $depth + 1);
if($modulDoc) {
my #exported = getExported($modulDoc);
print "Exported: \n" if(scalar #exported && $showStuffOtherThanUsedOrNot);
foreach (#exported) {
print(("\t" x $indent)."\t");
if(callerUsesIt($_, $file)) {
$anyUsed = 1;
print color("green"), "$_, ", color("reset") if $showStuffOtherThanUsedOrNot;
} else {
print color("red"), "$_, ", color("reset") if $showStuffOtherThanUsedOrNot;
}
print "\n" if $showStuffOtherThanUsedOrNot;
}
print(("\t" x $indent)."\t") if $showStuffOtherThanUsedOrNot;
print "Subs: " if $showStuffOtherThanUsedOrNot;
foreach my $s (findAllSubs($modulDoc)) {
my $isExported = grep($s eq $_, #exported) ? 1 : 0;
my $rot = callerUsesIt($s, $caller, $modul, $isExported) ? 0 : 1;
$anyUsed = 1 unless $rot;
if($showStuffOtherThanUsedOrNot) {
print color("red") if $rot;
print color("green") if !$rot;
print "$s, ";
print color("reset");
}
}
print "\n" if $showStuffOtherThanUsedOrNot;
print color("red"), "=========== $modul wahrscheinlich nicht in Benutzung!!!\n", color("reset") unless $anyUsed;
print color("green"), "=========== $modul in Benutzung!!!\n", color("reset") if $anyUsed;
}
}
return $skript;
}
sub createFileName {
my $file = shift;
$file =~ s#::#/#g;
$file .= ".pm";
$file = "/modules/$file";
return $file;
}
sub getExported {
my $doc = shift;
my #exported = ();
eval {
foreach my $x (#{$doc->find("PPI::Statement")}) {
my $worthATry = 0;
my $isMatch = 0;
foreach my $y (#{$x->{children}}) {
$worthATry = 1 if(ref $y eq "PPI::Token::Symbol");
if($y eq '#EXPORT') {
$isMatch = 1;
} elsif($isMatch && ref($y) ne "PPI::Token::Whitespace" && ref($y) ne "PPI::Token::Operator" && $y->{content} ne ";") {
push #exported, $y->{content};
}
}
}
};
my #realExported = ();
foreach (#exported) {
eval "\#realExported = $_";
}
return #realExported;
}
sub callerUsesIt {
my $subname = shift;
my $caller = shift;
my $namespace = shift || undef;
my $isExported = shift || 0;
$caller = `cat $caller`;
unless($namespace) {
return 1 if($caller =~ /\b$subname\b/);
} else {
$namespace = createPackageName($namespace);
my $regex = qr#$namespace(?:::|->)$subname#;
if($caller =~ $regex) {
return 1;
}
}
return 0;
}
sub findAllSubs {
my $doc = shift;
my #subs = ();
eval {
foreach my $x (#{$doc->find("PPI::Statement::Sub")}) {
my $foundName = 0;
foreach my $y (#{$x->{children}}) {
no warnings;
if($y->{content} ne "sub" && ref($y) eq "PPI::Token::Word") {
push #subs, $y;
}
use warnings;
}
}
};
return #subs;
}
sub createPackageName {
my $name = shift;
$name =~ s#/modules/##g;
$name =~ s/\.pm$//g;
$name =~ s/\//::/g;
return $name;
}
Its really ugly and maybe not 100% working, but it seems, with the tests that Ive done now, that its good for a beginning.

array to hash in perl

I have a source list from which I am picking up random items and populating the destination list. The item that are in the list have a particular format. For example:
item1{'name'}
item1{'date'}
etc and many more fields.
while inserting into the destination list I check for unique names on items and insert it into that list. For this I have to traverse the entire destination list to check if an item with a given name exists and if not insert it.
I thought it would be nice if I make the destination list as hash instead of a list again so that I can look up for the item faster and efficiently. I am new to Perl and am not getting how to do this. Anybody, Please help me on how to insert an item, find for a particular item name, and delete an item in hash?
How can I make both the name and date as key and the entire item as value?
my %hash;
Insert an item $V with a key $K?
$hash{$K} = $V
Find for a particular name / key $K?
if (exists $hash{$K}) {
print "it is in there with value '$hash{$K}'\n";
} else {
print "it is NOT in there\n"
}
Delete a particular name / key?
delete $hash{$K}
Make name and date as key and entire item as value?
Easy Way: Just string everything together
set: $hash{ "$name:$date" } = "$name:$date:$field1:$field2"
get: my ($name2,$date2,$field1,$field2) = split ':', $hash{ "$name:$date" }
del: delete $hash{ "$name:$date" }
Harder Way: Store as a hash in the hash (google "perl object")
set:
my %temp;
$temp{"name"} = $name;
$temp{"date"} = $date;
$temp{"field1"} = $field1;
$temp{"field2"} = $field2
$hash{"$name:$date"} = \$temp;
get:
my $find = exists $hash{"$name:$date"} ? $hash{"$name:$date"} : undef;
if (defined find) { # i.e. it was found
printf "field 1 is %s\n", $find->{"field1"}
} else {
print "Not found\n";
}
delete:
delete $hash{"$name:$date"}
It is not easy to understand what you are asking because you do not describe the input and the desired outputs specifically.
My best guess is something along the lines of:
#!/usr/bin/perl
use strict; use warnings;
my #list = (
q(item1{'name'}),
q(item1{'date'}),
);
my %lookup;
for my $entry ( #list ) {
my ($name, $attrib) = $entry =~ /([^{]+){'([^']+)'}/;
$lookup{ $name }{ $attrib } = $entry;
}
for my $entry ( keys %lookup ) {
my %entry = %{ $lookup{$entry} };
print "#entry{keys %entry}\n"
}
use YAML;
print Dump \%lookup;
Output:
item1{'date'} item1{'name'}
---
item1:
date: "item1{'date'}"
name: "item1{'name'}"
If you know what items, you are going to need and what order you'll need them in
for keys, then re parsing the key is of questionable value. I prefer to store
them in levels.
$hash{ $h->{name} }{ $h->{date} } = $h;
# ... OR ...
$hash{ $h->{date} }{ $h->{name} } = $h;
foreach my $name ( sort keys %hash ) {
my $name_hash = $hash{$name};
foreach my $date ( keys %$name_hash ) {
print "\$hash{$name}{$date} => " . Dumper( $name_hash->{$date} ) . "\n";
}
}
For arbitrary levels, you may want a traversal function
sub traverse_hash (&#) {
my ( $block, $hash_ref, $path ) = #_;
$path = [] unless $path;
my ( #res, #results );
my $want = wantarray;
my $want_something = defined $want;
foreach my $key ( %$hash_ref ) {
my $l_path = [ #$path, $key ];
my $value = $hash_ref->{$key};
if ( ref( $value ) eq 'HASH' ) {
#res = traverse_hash( $block, $value, $l_path );
push #results, #res if $want_something && #res;
}
elsif ( $want_something ) {
#res = $block->( $l_path, $value );
push #results, #res if #res;
}
else {
$block->( $path, $value );
}
}
return unless $want_something;
return $want ? #results : { #results };
}
So this does the same thing as above:
traverse_hash {
my ( $key_path, $value ) = #_;
print( '$hash{' . join( '}{', #$key_path ) . '} => ' . ref Dumper( $value ));
();
} \%hash
;
Perl Solution
#!/usr/bin/perl -w
use strict;
use Data::Dumper;
sub main{
my %hash;
my #keys = qw(firstname lastname age); # hash's keys
# fname lname age
# --------|--------|-----
my #arr = ( [ 'foo1', 'bar1', '1' ],
[ 'foo2', 'bar2', '2' ],
[ 'foo3', 'bar3', '3' ]
);
# test if array set up correctly
print "\$arr[1][1] : $arr[1][1] \n"; # bar2
# loads the multidimensional array into the hash
for my $row (0..$#arr){
for my $col ( 0..$#{$arr[$row]} ){
my $itemnum = "item" . ($row+1); # using the item# format you used
$hash{$itemnum}->{$keys[$col]} = $arr[$row][$col];
}
}
# manually add a 4th item
$hash{item4} = {"firstname", "foo", "lastname", "bar", "age", "35"};
# How to Retrieve
# -----------------------
# single item pull
print "item1->firstname : $hash{item1}->{firstname} \n"; # foo1
print "item3->age : $hash{item3}->{age} \n"; # 3
# whole line 1
{ local $, = " ";
print "full line :" , %{$hash{item2}} , "\n"; # firstname foo2 lastname bar2 age 2
}
# whole line 2
foreach my $key (sort keys %{$hash{item2}}){
print "$key : $hash{item2}{$key} \n";
}
# Clearer description
#print "Hash:\n", Dumper %hash;
}
main();
This should be used in addition to the accepted answer. Your question was a little vague on the array to hash requirement, perhaps this is the model you are looking for?