RegSvr32 registering yet nothing actually registered - perl

A rather odd experience. Using the latest PDK (v7.3) from ActiveState, I used perlctrl to build a COM DLL. Perlctrl ran without a hitch. OLEView read the typelib okay. RegSvr32 registered it okay. However ... there's no sign of it in registry, and anything that tries to use it fails. I hunted for the various UIDs using RegEdit and they're just not there.
The code is below. It's a wrapping of Lingua::ZH::WordSegmenter, but with the encoding changed to utf8 rather than gbk.
It's probably something obvious ...
package ZHWordSeg;
use strict;
use warnings;
use utf8;
use ws;
use Encode;
use constant STX => chr( 2 ); #[
use constant ETX => chr( 3 ); #]
use constant FS => chr( 28 ); #^
use constant RS => chr( 30 ); #~
use constant TAB_SEPARATOR => 0;
use constant CARET_SEPARATOR => 1;
use constant FS_SEPARATOR => 2;
use constant SPACE_SEPARATOR => 3;
use constant AS_ARRAY => 4;
use feature 'switch';
our $segmenter;
sub ZHWordSeg_Setup {
my $dic = shift;
my $dic_encoding = shift;
my $separator = shift;
my $verbose = shift;
$dic_encoding = 'utf8' unless defined( $dic_encoding );
$separator = " " unless defined( $separator );
$verbose = 0 unless defined( $verbose );
if ( defined( $dic ) ) {
$segmenter = ws->new( dic => $dic, dic_encoding => $dic_encoding, seperator => $separator, verbose => $verbose );
} else {
$segmenter = ws->new( dic_encoding => $dic_encoding, seperator => $separator, verbose => $verbose );
}
}
sub ZHWordSeg {
my $source = shift;
print STDERR $source;
my $sepcode = shift;
$source = encode("utf8",$source);
my $stringres = $segmenter->seg($source);
my #arrayres;
given ($sepcode) {
when (TAB_SEPARATOR) {
$stringres =~ tr/ /\t/;
return $stringres;
}
when (CARET_SEPARATOR) {
$stringres =~ tr/ /^/;
$stringres .= "^";
return $stringres;
}
when (FS_SEPARATOR) {
$stringres =~ s/ /FS/eg;
$stringres .= FS;
return $stringres;
}
when (SPACE_SEPARATOR) {
return $stringres;
}
default {
#arrayres = split( / /, $stringres );
return \#arrayres;
}
}
}
sub SetDictionary {
my ($source) = shift;
my $res = set_dic($source);
return $res;
}
1;
=pod
=begin PerlCtrl
%TypeLib = (
PackageName => 'ZHWordSeg',
DocString => 'Chinese word segmentation',
HelpContext => 1,
TypeLibGUID => '{F6C9BD66-7CA1-4610-B77F-E219A7122C18}', # do NOT edit this line
ControlGUID => '{45D47C6A-2B9A-4D62-9CFD-F18C95DC00C5}', # do NOT edit this line either
DispInterfaceIID=> '{007E4E7A-3B75-4DC3-864C-7746860941B3}', # or this one
ControlName => 'BOCWS',
ControlVer => 2, # increment if new object with same ProgID
# create new GUIDs as well
ProgID => 'ZHWordSeg.BOCWS',
LCID => 0,
DefaultMethod => 'ChineseWordSegmenter',
Methods => {
'ChineseWordSegmenter' => {
RetType => VT_VARIANT,
TotalParams => 2,
NumOptionalParams => 1,
ParamList =>
[ 'source' => VT_BSTR,
'sepcode' => VT_I4
]
},
'ChineseWordSegmenter_Setup' => {
RetType => VT_VARIANT,
TotalParams => 4,
NumOptionalParams => 4,
ParamList =>
[ 'dic' => VT_BSTR,
'dic_encoding' => VT_BSTR,
'separator' => VT_BSTR,
'verbose' => VT_BSTR
]
}
}, # end of 'Methods'
Properties => {
TAB_SEPARATOR => {
DocString => "Separate items with TAB (0x0)",
Type => VT_I4,
DispID => 3,
ReadOnly => 1,
},
CARET_SEPARATOR => {
DocString => "Separate items with ^ (0x1)",
Type => VT_I4,
DispID => 4,
ReadOnly => 1,
},
FS_SEPARATOR => {
DocString => "Separate items with ascii 28 (0x2)",
Type => VT_I4,
DispID => 5,
ReadOnly => 1,
},
SPACE_SEPARATOR => {
DocString => "Separate items with space (0x3)",
Type => VT_I4,
DispID => 6,
ReadOnly => 1,
},
AS_ARRAY => {
DocString => "Separate items as array (0x4)",
Type => VT_I4,
DispID => 7,
ReadOnly => 1,
}
}, # end of 'Properties'
); # end of %TypeLib
=end PerlCtrl
=cut
This is the .perlctrl file, in case it matters:
#!C:\Program Files\ActiveState Perl Dev Kit 7.3 Deployment\bin\lib\pai.exe
PAP-Version: 1.0
Packer: C:\Program Files\ActiveState Perl Dev Kit 7.3 Deployment\bin\perlctrl.exe
Script: ZHWordSeg.ctrl
Cwd: P:\BOCWS
Byref: 0
Clean: 0
Date: 2008-10-24 18:05:42
Debug: 127.0.0.1:2000
Dependent: 0
Dyndll: 0
Exe: BOCWS.dll
Force: 1
Gui: 0
Hostname: xi
No-Compress: 0
No-Gui: 0
No-Logo: 0
Runlib:
Shared: none
Singleton: 0
Tmpdir:
Verbose: 0
Version-Comments:
Version-CompanyName:
Version-FileDescription: Wrapper of Lingua::ZH::WordSegmenter.pm
Version-FileVersion: 1.0
Version-InternalName: ZHWordSeg
Version-LegalCopyright:
Version-LegalTrademarks:
Version-OriginalFilename: ZHWordSeg.ctrl
Version-ProductName: BOChineseWordSegmenter
Version-ProductVersion: 1.0
Warnings: 0
Xclude: 1

The only "solution" that I've found was suggested over on news:comp.os.ms-windows.programmer.win32
i am not a PDK user but from experience i can tell you, that you should check the DllRegister exports code and what it internally does, since this is what the regsvr32 calls and this code is creating the registry keys for your com server/proxy, etc, ...
You can track the registry for changes with sysinternal tools like regmon or procmon, just to make sure!
Ultimately, I gave up and went back to a previous version that worked and tweaked it.

Related

Perl Log::Dispatch: Change logging location mid-run?

I'm using Log::Dispatch in a large Mooseified app, via MooseX::LogDispatch. My setup is more or less:
use Moose;
with 'MooseX::LogDispatch';
has log_dispatch_conf => (
is => 'ro',
isa => 'HashRef',
lazy => 1,
required => 1,
default => sub {
my $self = shift;
return {
class => 'Log::Dispatch::File',
min_level => 'debug',
filename => $self->config->{logfile},
mode => '>>',
newline => 1
};
},
);
Is there any way I can change the location of the log file in the middle of a running process? My specific use case is that I'm processing a number of different large [things], which are passed in at runtime, and I'd like each [thing] to log to its own file. Something like this:
foreach my $thing (#things) {
my $logfile = $self->config->{log_base} . $thing->{name} . time() . ".log";
# do something here to set log location
$self->logger->info("Start processing " . $thing->{name} . " at " . scalar localtime());
# process $thing
}
Right. I abandoned MooseX::LogDispatch and did it myself.
When we have a new [thing], I just call a trigger to fire a _set_logger method:
sub _set_logger {
my ($self, $thing) = #_;
my $log_dir = $self->config->{log_dir}; # /path/to/log_dir
my $log_file_base = $self->config->{log_file_base}; # e.g. process-thing-log
my $t = localtime;
my $logfile = $log_dir . "/" . $log_file_base . $thing->{name} . "-" . $t->ymd . ".log";
my $logger = Log::Dispatch->new(
outputs => [
[ 'File',
min_level => 'debug',
filename => $logfile,
mode => '>>',
newline => 1,
],
],
);
$self->logger($logger);
$self->logger->info("Started run at " . scalar localtime);
}
Don't know if it's "right", but it's working smoothly.

What is the Win32::Daemon context hash keyword for delayed auto-start?

In Win32::Daemon's doc, it says:
start_type An integer specifying how (or whether) the service is to be started. The default is SERVICE_AUTO_START.
I don't find anywhere that it says what the value is for delayed autostart.
A look at the source behind Win32::Daemon might help but I don't know how to find it. Apparently it's loaded via a perl bootstrap function.
There is no value you can pass to the start_type parameter of CreateService() that will do what you want. You need to call ChangeServiceConfig2(), as per this answer. You can use Win32::API to call it.
Code:
use My::Win32::Service qw( :ALL );
my $ServiceName = ...;
my $SCManager;
my $Service ;
if (!eval {
$SCManager = OpenSCManager(undef, undef, SC_MANAGER_ALL_ACCESS)
or die("Can't open the service control manager: $^E\n");
$Service = OpenService($SCManager, $ServiceName, SERVICE_CHANGE_CONFIG)
or die("Can't open the service: $^E\n");
ChangeServiceConfig2($Service, SERVICE_CONFIG_DELAYED_AUTO_START_INFO, pack_SERVICE_DELAYED_AUTO_START_INFO(1))
or die("Can't set the service to delayed auto-start: $^E\n");
CloseServiceHandle($Service);
CloseServiceHandle($SCManager);
return 1; # No exception
}) {
my $e = $#;
CloseServiceHandle($Service) if $Service;
CloseServiceHandle($SCManager) if $SCManager;
die($e);
}
My/Win32/Service.pm:
package My::Win32::Service;
use strict;
use warnings;
use feature qw( state );
use Encode qw( decode );
use Exporter qw( import );
use Win32::API qw( );
our %EXPORT_TAGS;
our #EXPORT_OK = qw(
OpenSCManager
OpenService
CloseServiceHandle
ChangeServiceConfig2
pack_SERVICE_DELAYED_AUTO_START_INFO
);
# -----
use constant {
GENERIC_READ => 0x80000000,
GENERIC_WRITE => 0x40000000,
GENERIC_EXECUTE => 0x20000000,
GENERIC_ALL => 0x10000000,
};
$EXPORT_TAGS{GENERIC} = [qw(
GENERIC_READ
GENERIC_WRITE
GENERIC_EXECUTE
GENERIC_ALL
)];
use constant {
STANDARD_RIGHTS_REQUIRED => 0xF0000,
};
push #EXPORT_OK, qw(
STANDARD_RIGHTS_REQUIRED
);
use constant {
SC_MANAGER_CREATE_SERVICE => 0x0002,
SC_MANAGER_CONNECT => 0x0001,
SC_MANAGER_ENUMERATE_SERVICE => 0x0004,
SC_MANAGER_LOCK => 0x0008,
SC_MANAGER_MODIFY_BOOT_CONFIG => 0x0020,
SC_MANAGER_QUERY_LOCK_STATUS => 0x0010,
};
use constant {
SC_MANAGER_ALL_ACCESS =>
STANDARD_RIGHTS_REQUIRED
| SC_MANAGER_CREATE_SERVICE
| SC_MANAGER_CONNECT
| SC_MANAGER_ENUMERATE_SERVICE
| SC_MANAGER_LOCK
| SC_MANAGER_MODIFY_BOOT_CONFIG
| SC_MANAGER_QUERY_LOCK_STATUS,
};
$EXPORT_TAGS{SC_MANAGER} = [qw(
SC_MANAGER_CREATE_SERVICE
SC_MANAGER_CONNECT
SC_MANAGER_ENUMERATE_SERVICE
SC_MANAGER_LOCK
SC_MANAGER_MODIFY_BOOT_CONFIG
SC_MANAGER_QUERY_LOCK_STATUS
SC_MANAGER_ALL_ACCESS
)];
use constant {
SERVICE_CHANGE_CONFIG => 0x0002,
SERVICE_ENUMERATE_DEPENDENTS => 0x0008,
SERVICE_INTERROGATE => 0x0080,
SERVICE_PAUSE_CONTINUE => 0x0040,
SERVICE_QUERY_CONFIG => 0x0001,
SERVICE_QUERY_STATUS => 0x0004,
SERVICE_START => 0x0010,
SERVICE_STOP => 0x0020,
SERVICE_USER_DEFINED_CONTROL => 0x0100,
};
use constant {
SERVICE_ALL_ACCESS =>
STANDARD_RIGHTS_REQUIRED
| SERVICE_CHANGE_CONFIG
| SERVICE_ENUMERATE_DEPENDENTS
| SERVICE_INTERROGATE
| SERVICE_PAUSE_CONTINUE
| SERVICE_QUERY_CONFIG
| SERVICE_QUERY_STATUS
| SERVICE_START
| SERVICE_STOP
| SERVICE_USER_DEFINED_CONTROL;
};
$EXPORT_TAGS{SERVICE} = [qw(
SERVICE_CHANGE_CONFIG
SERVICE_ENUMERATE_DEPENDENTS
SERVICE_INTERROGATE
SERVICE_PAUSE_CONTINUE
SERVICE_QUERY_CONFIG
SERVICE_QUERY_STATUS
SERVICE_START
SERVICE_STOP
SERVICE_USER_DEFINED_CONTROL
SERVICE_ALL_ACCESS
)];
use constant {
SERVICE_CONFIG_DELAYED_AUTO_START_INFO => 3,
SERVICE_CONFIG_DESCRIPTION => 1,
SERVICE_CONFIG_FAILURE_ACTIONS => 2,
SERVICE_CONFIG_FAILURE_ACTIONS_FLAG => 4,
SERVICE_CONFIG_PREFERRED_NODE => 9,
SERVICE_CONFIG_PRESHUTDOWN_INFO => 7,
SERVICE_CONFIG_REQUIRED_PRIVILEGES_INFO => 6,
SERVICE_CONFIG_SERVICE_SID_INFO => 5,
SERVICE_CONFIG_TRIGGER_INFO => 8,
SERVICE_CONFIG_LAUNCH_PROTECTED => 12,
};
$EXPORT_TAGS{SERVICE_CONFIG} = [qw(
SERVICE_CONFIG_DELAYED_AUTO_START_INFO
SERVICE_CONFIG_DESCRIPTION
SERVICE_CONFIG_FAILURE_ACTIONS
SERVICE_CONFIG_FAILURE_ACTIONS_FLAG
SERVICE_CONFIG_PREFERRED_NODE
SERVICE_CONFIG_PRESHUTDOWN_INFO
SERVICE_CONFIG_REQUIRED_PRIVILEGES_INFO
SERVICE_CONFIG_SERVICE_SID_INFO
SERVICE_CONFIG_TRIGGER_INFO
SERVICE_CONFIG_LAUNCH_PROTECTED
)];
{
my %export_ok;
++$export_ok{$_}
for
#EXPORT_OK,
( map {#$_, values %EXPORT_TAGS );
#EXPORT_OK = sort keys %export_ok;
$EXPORT_TAGS{ALL} = \#EXPORT_OK;
}
# -----
# https://msdn.microsoft.com/en-ca/library/windows/desktop/aa383751(v=vs.85).aspx
# typedef int BOOL;
# typedef unsigned long DWORD;
# typedef PVOID HANDLE;
# typedef void* PVOID;
# *** I'm pretty sure some of these are wrong on 64-bit builds of Perl. ***
use constant {
WAPI_FORMAT_PTR => 'I', PACK_FORMAT_PTR => 'i',
};
use constant {
WAPI_FORMAT_BOOL => 'I', PACK_FORMAT_BOOL => 'i',
WAPI_FORMAT_DWORD => 'N', PACK_FORMAT_DWORD => 'L',
WAPI_FORMAT_HANDLE => WAPI_FORMAT_PVOID, PACK_FORMAT_HANDLE => PACK_FORMAT_PTR,
};
# -----
sub encode_LPCWSTR {
my ($s) = #_;
return undef if !defined($s);
return encode('UTF-16le', $s."\0");
}
# Inefficient. Needs a C implementation.
sub decode_LPCWSTR {
my ($ptr) = #_;
return undef if !$ptr;
my $sW = '';
while (1){
my $chW = unpack('P2', pack(PACK_FORMAT_PTR, $ptr));
last if $chW eq "\0\0";
$sW .= $chW;
$ptr += 2;
}
return decode('UTF-16le', $sW);
}
# -----
sub pack_SERVICE_DELAYED_AUTO_START_INFO {
my ($DelayedAutostart) = #_;
return pack(PACK_FORMAT_BOOL, $DelayedAutostart ? 1 : 0);
}
# -----
# https://msdn.microsoft.com/en-us/library/windows/desktop/ms684323(v=vs.85).aspx
# On error, returns false. Use $^E to get the error message.
# Close returned handle using CloseServiceHandle.
sub OpenSCManager {
my ($MachineName, $DatabaseName, $DesiredAccess) = #_;
my $packed_MachineName = encode_LPCWSTR($MachineName);
my $packed_DatabaseName = encode_LPCWSTR($DatabaseName);
state $OpenSCManager = Win32::API->new(
'advapi32.dll',
'OpenSCManagerW',
'P' . 'P' . WAPI_FORMAT_DWORD,
WAPI_FORMAT_HANDLE,
);
return $OpenSCManager->Call($packed_MachineName, $packed_DatabaseName, $DesiredAccess);
}
# https://msdn.microsoft.com/en-us/library/windows/desktop/ms684330(v=vs.85).aspx
# On error, returns false. Use $^E to get the error message.
# Close returned handle using CloseServiceHandle.
sub OpenService(
my ($SCManager, $ServiceName, $DesiredAccess) = #_;
my $packed_ServiceName = encode_LPCWSTR($ServiceName);
state $OpenService = Win32::API->new(
'advapi32.dll',
'OpenServiceW',
WAPI_FORMAT_HANDLE . 'P' . WAPI_FORMAT_DWORD,
WAPI_FORMAT_HANDLE,
);
return $OpenSCManager->Call($packed_MachineName, $packed_DatabaseName, $DesiredAccess);
}
# https://msdn.microsoft.com/en-us/library/windows/desktop/ms682028(v=vs.85).aspx
# On error, returns false. Use $^E to get the error message.
sub CloseServiceHandle {
my ($SCObject) = #_;
state $CloseServiceHandle = Win32::API->new(
'advapi32.dll',
'CloseServiceHandle',
WAPI_FORMAT_HANDLE,
WAPI_FORMAT_BOOL,
);
return $CloseServiceHandle->Call($SCObject);
}
# https://msdn.microsoft.com/en-us/library/windows/desktop/ms681988(v=vs.85).aspx
# Info must be a packed structure.
# On error, returns false. Use $^E to get the error message.
sub ChangeServiceConfig2 {
my ($Service, $InfoLevel, $packed_Info) = #_;
state $CloseServiceHandle = Win32::API->new(
'advapi32.dll',
'CloseServiceHandle',
WAPI_FORMAT_HANDLE . WAPI_FORMAT_DWORD . 'P',
WAPI_FORMAT_BOOL,
);
return $ChangeServiceConfig2->Call($Service, $InfoLevel, $packed_Info);
}
# -----
1;
Completely untested. In fact, I think it's buggy in 64-bit builds of Perl.

Params::Validate, how to require one of two parameters?

If I have a method that takes either one or the other of two named parameters, exactly one of which must be present, is there a way to handle that with Params::Validate?
$store->put( content_ref => $stringref );
or
$store->put( path => $path_to_file );
I'm not seeing it in the docs, but it seems like an obvious use case, so I thought I should ask.
You can use callbacks to achieve something along those lines:
#!/usr/bin/env perl
use strict;
use warnings;
package My::Class;
use Params::Validate;
use YAML;
sub new { bless {} => shift }
sub _xor_param {
my $param = shift;
return sub { defined($_[0]) and not defined($_[1]->{$param}) }
}
my %validation_spec = (
content_ref => {
'default' => undef,
callbacks => {
"Provided only if no 'path' is given"
=> _xor_param('path')
},
},
path => {
'default' => undef,
callbacks => {
"Provided only if no 'content_ref' is given"
=> _xor_param('content_ref')
},
},
);
sub put {
my $self = shift;
validate(#_, \%validation_spec);
print Dump \#_;
}
package main;
my $x = My::Class->new;
$x->put(path => 'some path');
$x->put(content_ref => \'some content');
$x->put(path => 'another_path', content_ref => \'some other content');
Output:
---
- path
- some path
---
- content_ref
- !!perl/ref
=: some content
The 'content_ref' parameter ("SCALAR(0xab83cc)") to My::Class::put did not pass
the 'Provided only if no 'path' is given' callback
at C:\temp\v.pl line 37
My::Class::put(undef, 'path', 'another_path', 'content_ref',
'SCALAR(0xab83cc)') called at C:\temp\v.pl line 47

How do you get MotherDogRobot to birth an array of puppy objects using map and a hash of hashes?

Puppy meta data gets read in from config file using (General::Config) and creates this hash of hashes
$puppy_hashes = {
puppy_blue => { name => 'charlie', age => 4 },
puppy_red => { name => 'sam', age => 9 },
puppy_yellow => { name => 'jerry', age => 2 },
puppy_green => { name => 'phil', age => 5 },
}
the MotherDogRobot package consumes the puppies hash to birth an array of puppy objects (lol)
package MotherDogRobot;
use Moose;
use Puppy;
use Data::Dumper;
#moose includes warn and strict
sub init_puppy{
my($self,%options) = #_;
my $puppy = Puppy->new( %options );
return ($puppy);
}
sub birth_puppies{
my($self,$puppy_hashes) = #_;
my #keys = keys %{$puppy_hashes};
my #puppies = map { $self->init_puppy( $puppy_hashes->{$_} ) } #keys;
return(#puppies);
}
sub show_me_new_puppies{
my($self,$puppy_hashes) #_;
print Dumper($self->birth_puppies($puppy_hashes));
}
Error odd number of arguments
passing %options to Puppy->new(%options)
no luck birthing puppies -- which means I can't put lasers on their heads =/
UPDATE
I think the problem is that I'm passing a Hash Ref to init_puppy() instead of an array or hash, so when I try to pass %options to the new constructor, it's not getting a proper ( key => value) pair -- hence the odd number of arguments error.
But from this standpoint I've been looking at this code too long I cant figure out how to dereference this properly.
btw this is my official day 22 of using Perl!
you're using empty variables as if they're not empty, that is, you're not doing anything at all
print "hi $_ " for my #foo;
This assumes that the incomplete snippet you've shown is what you're really using
update: Similarly in sub init_puppy, you never initialize my($self,%options)=#_;
#!/usr/bin/perl --
use strict;
use warnings;
Main( #ARGV );
exit( 0 );
sub Main {
my $puppy_hashes = {
puppy_blue => { name => 'charlie', age => 4 },
puppy_red => { name => 'sam', age => 9 },
puppy_yellow => { name => 'jerry', age => 2 },
puppy_green => { name => 'phil', age => 5 },
};
for my $puppy ( MotherDogRobot->birth_puppies($puppy_hashes) ) {
print join ' ', $puppy, $puppy->name, $puppy->age, $puppy->dump, "\n";
}
}
BEGIN {
package Puppy;
BEGIN { $INC{'Puppy.pm'} = __FILE__; }
use Any::Moose;
has 'name' => ( is => 'rw', isa => 'Str' );
has 'age' => ( is => 'rw', isa => 'Int' );
package MotherDogRobot;
BEGIN { $INC{'MotherDogRobot.pm'} = __FILE__; }
use Moose;
use Puppy;
sub init_puppy {
my ( $self, %options ) = #_;
my $puppy = Puppy->new(%options);
return ($puppy);
}
sub birth_puppies {
my ( $self, $puppy_hashes ) = #_;
my #puppies = map { $self->init_puppy( %{$_} ) } values %$puppy_hashes;
return (#puppies);
}
no Moose;
}
The standard Moose constructor will accept both
->new( %{ $puppy_hashes->{$_} } )
and
->new( $puppy_hashes->{$_} )
if $puppy_hashes contains what you say it does, and $_ is an existing key.
Furthermore, Moose will not give the error Error odd number of argments when you pass no arguments. (You're not assigning anything to %config.)
I can't tell which part of what you said is wrong, but what you said doesn't add up.

Populating an array of hashes with arrays of hashes

I am currently developing a piece of monitoring software that takes an input file of server names and ip addresses and creates a rudimentary database of information. I want to default some values as it processes the config file and it works fine for the first time round the loop but any subsequent entries get created with weird (well weird to me was the best way to describe it as it is probably correct and the code is wrong, as in the code is doing exactly what i have asked it to do but not necessarily what i want it to do).
the output from the code below looks like:
$VAR1 = [
{
'IPAddress' => '196.8.150.163',
'Boxname' => 'MPLRDFDSOAK1',
'CurrentStatusInfo' => {
'LineHandlersRunning' => [
{
'NumberOfGaps' => 0,
'LineHandlerName' => 'DEFAULT',
'NumberOfCommLinkDowns' => 0,
'LineHandlerUpTime' => 0,
'MemoryUsage' => 0
}
]
},
'PreviousStatusInfo' => {
'LineHandlersRunning' =>
$VAR1->[0]{'CurrentStatusInfo'}{'LineHandlersRunning'}[0]
]
}
},
{
'IPAddress' => '196.8.150.164',
'Boxname' => 'MPLRDFDSOAK2',
'CurrentStatusInfo' => {
'LineHandlersRunning' =>
$VAR1->[0]{'CurrentStatusInfo'}{'LineHandlersRunning'}
},
'PreviousStatusInfo' => {
'LineHandlersRunning' =>
$VAR1->[0]{'PreviousStatusInfo'}{'LineHandlersRunning'}
}
}
];
The following is the code:
#######################################################################################
# Version History #
#######################################################################################
# example of the ini file
#box=>MPLRDFDSOAK1;ip=>196.8.150.163
#box=>MPLRDFDSOAK2;ip=>196.8.150.164
use strict;
use warnings;
# include the library to allow easy access to command line arguments
use Getopt::Long;
# include the data dumper utility
use Data::Dumper;
my $usageInstructions = "Some instructions\n";
my $showMeTheInstructions = "";
my $iniFileToReadIn = "";
my #boxes;
# read in the command line arguments
GetOptions( "ini=s" => \$iniFileToReadIn,
"H|h|?!" => \$showMeTheInstructions);
if ($showMeTheInstructions)
{
print $usageInstructions;
exit 0;
}
readInINIFileIn($iniFileToReadIn, \#boxes) if ($iniFileToReadIn ne "");
print Dumper(\#boxes);
print "\n\#\n\# END OF DATA DUMP\n\#\n\n";
exit 0;
#######################################################################################
# subroutine to read in the ini file and create the empty records for the boxes
# specified
sub readInINIFileIn
{
my ($iniFile, $pointerToBoxes) = #_;
my $noCRLFOnString = "";
# open the file
open (ConfigFile, "<$iniFile") || die $!;
# read in all the lines into an array
my #configurationItems = <ConfigFile>;
# close the file
close (ConfigFile);
# temporary record storage
my %tempRecord;
# create the defaults for all boxes
my #LineHandlersRunning;
my %tmpLineHandlerRunning = ( LineHandlerName => "DEFAULT",
LineHandlerUpTime => 0,
NumberOfCommLinkDowns => 0,
NumberOfGaps => 0,
MemoryUsage => 0 );
push (#LineHandlersRunning, {%tmpLineHandlerRunning});
my %CurrentStatusInfo;
my %PreviousStatusInfo;
push #{ $CurrentStatusInfo{'LineHandlersRunning'} }, #LineHandlersRunning;
push #{ $PreviousStatusInfo{'LineHandlersRunning'} }, #LineHandlersRunning;
# loop through the config file and create the defaults for the database of boxes
foreach my $configLine (#configurationItems)
{
my #TokenisedLineFromFileItems = ();
my #TokenisedLineFromFileNameValuePairs = ();
# store parameters
# each line will be ; separated then => separated, as in each one will have a number of items separated by ;'s and
# each item will be be a name & value pair separated by =>'s
#TokenisedLineFromFileItems = split(/;/,$configLine);
# remove quote marks around the outside of each element of the newly created array
s/^"|"$//g foreach #TokenisedLineFromFileItems;
# create information in database record to add to boxes
foreach my $NameValuePair (#TokenisedLineFromFileItems)
{
#TokenisedLineFromFileNameValuePairs = split(/=>/,$NameValuePair);
$noCRLFOnString = $TokenisedLineFromFileNameValuePairs[1];
$noCRLFOnString =~ s/(\n|\r)//g;
$tempRecord{'Boxname'} = $noCRLFOnString if ($TokenisedLineFromFileNameValuePairs[0] eq "box");
$tempRecord{'IPAddress'} = $noCRLFOnString if ($TokenisedLineFromFileNameValuePairs[0] eq "ip");
}
# add all other defaults as blank
$tempRecord{'CurrentStatusInfo'} = {%CurrentStatusInfo};
$tempRecord{'PreviousStatusInfo'} = {%PreviousStatusInfo};
push(#$pointerToBoxes, {%tempRecord});
}
}
I don't have the patience to wade through all of your code, but I'll bet your problem is related to this aspect of the Data::Dumper output:
$VAR1->[0]{'CurrentStatusInfo'}{'LineHandlersRunning'}[0]
In other words, your data structure contains a reference to other parts of the structure.
Perhaps you think you are making a copy of part of the data structure, but instead you are getting a shallow copy rather than a deep copy? For example, I'm suspicious of this code:
$tempRecord{'CurrentStatusInfo'} = {%CurrentStatusInfo};
$tempRecord{'PreviousStatusInfo'} = {%PreviousStatusInfo};
If indeed the problem is related to shallow copying, the Clone module might help.
Use lexical filehandles, declare variables in the smallest possible scope. I do not know what your problem is, but it is most likely caused by some variable persisting longer than you think it does.
I'm guessing it's because these two lines end up pushing the same hash reference into two locations - so if you alter the hashref contents in one location, the other will change as well which is probably not what you want for default values.
As FM pointed out, this is why you have the circular reference in your Dumper output.
If someone I'm waiting to get off the phone takes long enough i'll refactor your code for you.
Update: ok, so without knowing the full scenario it's hard to say if this is a sensible approach. certainly you should look at the various INI parsing modules in CPAN, but here is a very quick tweak of your code, leaving your existing logic structure in place:
use strict;
use warnings;
use Getopt::Long;
use Data::Dumper;
my $cmd_help = "Some instructions\n";
my $show_help = "";
my $ini_file_path = "";
# read in the command line arguments
GetOptions( "ini=s" => \$ini_file_path,
"H|h|?!" => \$show_help );
if ($show_help) {
print $cmd_help;
exit 0;
}
if (! -f $ini_file_path) {
die "File '$ini_file_path' doesn't seem to exist.";
}
my $boxes = read_ini_file($ini_file_path);
print Dumper($boxes);
exit 0;
=head2 read_ini_file
read in the ini file and create the empty records for the boxes
=cut
sub read_ini_file {
my ($ini_file) = #_;
my #boxes;
my #config_lines;
{
# consider using File::Slurp
open (my $ini_fh, '<', $ini_file_path) || die $!;
#config_lines = <$ini_fh>;
chomp #config_lines; # remove \r\n
# file handle will close when $ini_fh goes out of scope
}
# create the defaults for all boxes
my %line_handlers_running_defaults = ( LineHandlerName => "DEFAULT",
LineHandlerUpTime => 0,
NumberOfCommLinkDowns => 0,
NumberOfGaps => 0,
MemoryUsage => 0 );
# loop through the config file and create the defaults for the database of boxes
foreach my $line (#config_lines) {
my %record;
my #token_pairs = map { s/^"//; s/^$//; $_ } split(/;/,$line);
# create information in database record to add to boxes
foreach my $pair (#token_pairs) {
my ($key, $val) = split(/=>/,$pair);
$record{Boxname} = $val if $key eq "box";
$record{IPAddress} = $val if $key eq "ip";
}
# add all other defaults as blank
$record{CurrentStatusInfo} = { LineHandlersRunning => [{%line_handlers_running_defaults}] };
$record{PreviousStatusInfo} = { LineHandlersRunning => [{%line_handlers_running_defaults}] };
push #boxes, \%record;
}
return \#boxes;
}
gives this output:
$VAR1 = [
{
'IPAddress' => '196.8.150.163',
'CurrentStatusInfo' => {
'LineHandlersRunning' => [
{
'NumberOfGaps' => 0,
'LineHandlerName' => 'DEFAULT',
'NumberOfCommLinkDowns' => 0,
'LineHandlerUpTime' => 0,
'MemoryUsage' => 0
}
]
},
'Boxname' => 'MPLRDFDSOAK1',
'PreviousStatusInfo' => {
'LineHandlersRunning' => [
{
'NumberOfGaps' => 0,
'LineHandlerName' => 'DEFAULT',
'NumberOfCommLinkDowns' => 0,
'LineHandlerUpTime' => 0,
'MemoryUsage' => 0
}
]
}
},
{
'IPAddress' => '196.8.150.164',
'CurrentStatusInfo' => {
'LineHandlersRunning' => [
{
'NumberOfGaps' => 0,
'LineHandlerName' => 'DEFAULT',
'NumberOfCommLinkDowns' => 0,
'LineHandlerUpTime' => 0,
'MemoryUsage' => 0
}
]
},
'Boxname' => 'MPLRDFDSOAK2',
'PreviousStatusInfo' => {
'LineHandlersRunning' => [
{
'NumberOfGaps' => 0,
'LineHandlerName' => 'DEFAULT',
'NumberOfCommLinkDowns' => 0,
'LineHandlerUpTime' => 0,
'MemoryUsage' => 0
}
]
}
}
];