I have a weird problem I can't figure out. I created a simple sequence in Perl with anonymous functions.
sub{($data, sub{($data, sub{($data, sub{($data, empty)})})})};
And it works but I tired to implement tail optimizing and got some weird behaviour. Example. The iter function below works.
sub iter {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
$func->($data);
#_ = ($func, $next);#This #_ update works fine
goto &iter;
}
}
while this implementation of iter fails.
sub iter {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
$func->($data);
$_[1] = $next; #This #_ update fails
goto &iter;
}
}
Both updates of #_ yield the same values for #_ but the code behaves differently when it continues.. To see what I'm talking about try running the complete code below.
#! /usr/bin/env perl
package Seq;
use 5.006;
use strict;
use warnings;
sub empty {
sub{undef};
}
sub add {
my ($data, $seq) = #_;
sub{($data, $seq)};
}
sub iter {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
$func->($data);
#_ = ($func, $next);#This works fine
#$_[1] = $next; #This fails
goto &iter;
}
}
sub smap {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
sub{($func->($data), Seq::smap($func, $next))};
}else {
empty();
}
}
sub fold {
my ($func, $acc, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
#_ = ($func, $func->($acc, $data), $next);
goto &Seq::fold;
}else {
$acc;
}
}
1;
package main;
use warnings;
use strict;
use utf8;
use List::Util qw(reduce);
my $seq =
reduce
{Seq::add($b, $a)}
Seq::empty,
(4143, 1234, 4321, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10);
Seq::iter(sub{my ($data) = #_; STDOUT->print("$data\n")}, $seq);
my $seq2 = Seq::smap(sub{my ($data) = #_; $data * 2}, $seq);
STDOUT->print("\n\n");
Seq::iter(sub{my ($data) = #_; STDOUT->print("$data\n")}, $seq2);
STDOUT->print("\n\n");
my $ans = Seq::fold(sub{my ($acc, $data) = #_; $acc + $data}, 0, $seq);
my $ans2 = Seq::fold(sub{my ($acc, $data) = #_; $acc + $data}, 0, $seq2);
STDOUT->print("$ans\n");
STDOUT->print("$ans2\n");
exit (0);
The code should work for both examples of iter but it doesn't.. Any pointers why?
Writing to $_[1] writes to the second scalar passed to the sub.
$ perl -E'$x = "abc"; say $x; sub { $_[0] = "def"; say $_[0]; }->($x); say $x;'
abc
def
def
So you are clobbering the caller's variables. Assigning to #_ replaces the scalars it contains rather than writing to them.
$ perl -E'$x = "abc"; say $x; sub { #_ = "def"; say $_[0]; }->($x); say $x;'
abc
def
abc
You can replace a specific element using splice.
$ perl -E'$x = "abc"; say $x; sub { splice(#_, 0, 1, "def"); say $_[0]; }->($x); say $x;'
abc
def
abc
It's far more convenient for iterators to return an empty list when they are exhausted. For starters, it allows them to return undef.
Furthermore, I'd remove the expensive recursive calls with quicker loops. These loops can be made particularly simple because of the change mentioned above.
The module becomes:
package Seq;
use strict;
use warnings;
sub empty { sub { } }
sub add {
my ($data, $seq) = #_;
return sub { $data, $seq };
}
sub iter {
my ($func, $seq) = #_;
while ( (my $data, $seq) = $seq->() ) {
$func->($data);
}
}
sub smap {
my ($func, $seq) = #_;
if ( (my $data, $seq) = $seq->() ) {
return sub { $func->($data), smap($func, $seq) };
} else {
return sub { };
}
}
sub fold {
my ($func, $acc, $seq) = #_;
while ( (my $data, $seq) = $seq->() ) {
$acc = $func->($acc, $data);
}
return $acc;
}
1;
Also, for speed reasons, replace
sub { my ($data) = #_; $data * 2 }
sub { my ($acc, $data) = #_; $acc + $data }
with
sub { $_[0] * 2 }
sub { $_[0] + $_[1] }
Anybody help me make a virtual file system in Perl.
Very simple, 2 depth level, as
/subdir
subdir-l2
file2.txt
/file1.txt
I try use Fuse.pm, but not understand how create subdir level. I create %files hash, and if go to subdir, recreate it with new records. It's for test only.
#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use Fuse;
use POSIX qw(ENOENT EISDIR EINVAL);
my (%files) = (
'.' => {
type => 0040,
mode => 0755,
ctime => 1490603721
},
subdir => {
type => 0040,
mode => 0755,
ctime => 1490603721
},
"file1.txt" => {
type => 0100,
mode => 0755,
ctime => 1490603721
}
);
sub filename_fixup {
my ($file) = shift;
$file =~ s,^/,,;
$file = '.' unless length($file);
return $file;
}
sub getdir {
my $tmp = shift;
if ($tmp eq '/') {
return (keys %files),0;
} else {
(%files) = (
'.' => {
type => 0040,
mode => 0755,
ctime => 1490603721
},
# /subdir/subdir-l2
"subdir-l2" => {
type => 0040,
mode => 0755,
ctime => 1490603721
} ,
# /subdir/a-l2.file
"file2.txt" => {
cont => "File 'al2'.\n",
type => 0100,
mode => 0755,
ctime => 1490603721
}
);
return (keys %files),0;
}
}
sub getattr {
my ($file) = filename_fixup(shift);
$file =~ s,^/,,;
$file = '.' unless length($file);
return -ENOENT() unless exists($files{$file});
my ($size) = exists($files{$file}{cont}) ? length($files{$file}{cont}) : 0;
$size = $files{$file}{size} if exists $files{$file}{size};
my ($modes) = ($files{$file}{type}<<9) + $files{$file}{mode};
my ($dev, $ino, $rdev, $blocks, $gid, $uid, $nlink, $blksize) = (0,0,0,1,0,0,1,1024);
my ($atime, $ctime, $mtime);
$atime = $ctime = $mtime = $files{$file}{ctime};
return ($dev,$ino,$modes,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks);
}
Fuse::main(
mountpoint => "/tmp/123",
getdir => \&getdir,
getattr => \&getattr,
);
one level mount fine, but if go to deeper i get
?????????? ? ? ? ? ? file2.txt
?????????? ? ? ? ? ? subdir-l2
I'm really not a regular user of the Fuse module, neither of FUSE system. Tinkered with this issue out of pure curiosity. Thus, although I can't explain in very much details how to use the plain Fuse module to achieve your goal, I have a working code that does create the wanted filesystem (at least on my system, and seems that it is capable of creating any arbitrary filesystem tree), and I can explain how I got this code working.
So first of all I discovered the Fuse::Simple module on CPAN.
Its SYNOPSIS shows that it provides a really simple API to the Fuse module for creating arbitrary filesystems from a hash structure. Its source code isn't that huge, so I just created 'listing.pl' script file and copied there most of the functions (except fserr that caused a Modification of a read-only value exception), put the main sub contents out, so they will be the main script's flow, hardcoded the filesystem structure ($fs var), and made some little adjustments here and there (like declare vars with my to prevent exceptions), and finally got the filesystem mounted, with all directories listed and files readable. So this is the code I got at last:
#!/usr/bin/env perl
use strict;
use warnings;
use diagnostics;
use Carp;
use Fuse;
use Errno qw(:POSIX); # ENOENT EISDIR etc
use Fcntl qw(:DEFAULT :mode); # S_IFREG S_IFDIR, O_SYNC O_LARGEFILE etc.
use Switch;
my $debug = 0;
my %codecache = ();
my $ctime = time();
my $uid = $>;
my $gid = $) + 0;
my $fs = {
"file1.txt" => "File 1 contents",
"subdir" => {
"subdir-l2" => {},
"file2.txt" => "File 2 contents"
}
};
# some default args
my %args = (
"mountpoint" => "listing",
"debug" => $debug,
"fuse_debug" => 0,
"threaded" => 0,
"/" => $fs
);
# the default subs
my %fs_subs = (
"chmod" => \&fs_not_imp,
"chown" => \&fs_not_imp,
"flush" => \&fs_flush,
"fsync" => \&fs_not_imp,
"getattr" => \&fs_getattr,
"getdir" => \&fs_getdir,
"getxattr" => \&fs_not_imp,
"link" => \&fs_not_imp,
"listxattr" => \&fs_not_imp,
"mkdir" => \&fs_not_imp,
"mknod" => \&fs_not_imp,
"open" => \&fs_open,
"read" => \&fs_read,
"readlink" => \&fs_readlink,
"release" => \&fs_release,
"removexattr" => \&fs_not_imp,
"rmdir" => \&fs_not_imp,
"rename" => \&fs_not_imp,
"setxattr" => \&fs_not_imp,
"statfs" => \&fs_statfs,
"symlink" => \&fs_not_imp,
"truncate" => \&fs_truncate,
"unlink" => \&fs_not_imp,
"utime" => sub{return 0},
"write" => \&fs_write,
);
# except extract these ones back out.
$debug = delete $args{"debug"};
$args{"debug"} = delete( $args{"fuse_debug"} ) || 0;
delete $args{"/"};
# add the functions, if not already defined.
# wrap in debugger if debug is set.
for my $name (keys %fs_subs) {
my $sub = $fs_subs{$name};
# $sub = wrap($sub, $name) if $debug;
$args{$name} ||= $sub;
}
Fuse::main(%args);
sub fetch {
my ($path, #args) = #_;
my $obj = $fs;
for my $elem (split '/', $path) {
next if $elem eq ""; # skip empty // and before first /
$obj = runcode($obj); # if there's anything to run
# the dir we're changing into must be a hash (dir)
return ENOTDIR() unless ref($obj) eq "HASH";
# note that ENOENT and undef are NOT the same thing!
return ENOENT() unless exists $obj->{$elem};
$obj = $obj->{$elem};
}
return runcode($obj, #args);
}
sub runcode {
my ($obj, #args) = #_;
while (ref($obj) eq "CODE") {
my $old = $obj;
if (#args) { # run with these args. don't cache
delete $codecache{$old};
print "running $obj(",quoted(#args),") NO CACHE\n" if $debug;
$obj = saferun($obj, #args);
} elsif (exists $codecache{$obj}) { # found in cache
print "got cached $obj\n" if $debug;
$obj = $codecache{$obj}; # could be undef, or an error, BTW
} else {
print "running $obj() to cache\n" if $debug;
$obj = $codecache{$old} = saferun($obj);
}
if (ref($obj) eq "NOCACHE") {
print "returned a nocache() value - flushing\n" if $debug;
delete $codecache{$old};
$obj = $$obj;
}
print "returning ",ref($obj)," ",
defined($obj) ? $obj : "undef",
"\n" if $debug;
}
return $obj;
}
sub saferun {
my ($sub, #args) = #_;
my $ret = eval { &$sub(#args) };
my $died = $#;
if (ref($died)) {
print "+++ Error $$died\n" if ref($died) eq "ERROR";
return $died;
} elsif ($died) {
print "+++ $died\n";
# stale file handle? moreorless?
return ESTALE();
}
return $ret;
}
sub nocache {
return bless(\ shift, "NOCACHE"); # yup, utter abuse of bless :-)
}
sub dump_open_flags {
my $flags = shift;
printf " flags: 0%o = (", $flags;
for my $bits (
[ O_ACCMODE(), O_RDONLY(), "O_RDONLY" ],
[ O_ACCMODE(), O_WRONLY(), "O_WRONLY" ],
[ O_ACCMODE(), O_RDWR(), "O_RDWR" ],
[ O_APPEND(), O_APPEND(), "|O_APPEND" ],
[ O_NONBLOCK(), O_NONBLOCK(), "|O_NONBLOCK" ],
[ O_SYNC(), O_SYNC(), "|O_SYNC" ],
[ O_DIRECT(), O_DIRECT(), "|O_DIRECT" ],
[ O_LARGEFILE(), O_LARGEFILE(), "|O_LARGEFILE" ],
[ O_NOFOLLOW(), O_NOFOLLOW(), "|O_NOFOLLOW" ],
) {
my ($mask, $flag, $name) = #$bits;
if (($flags & $mask) == $flag) {
$flags -= $flag;
print $name;
}
}
printf "| 0%o !!!", $flags if $flags;
print ")\n";
}
sub accessor {
my $var_ref = shift;
croak "accessor() requires a reference to a scalar var\n"
unless defined($var_ref) && ref($var_ref) eq "SCALAR";
return sub {
my $new = shift;
$$var_ref = $new if defined($new);
return $$var_ref;
}
}
sub fs_not_imp { return -ENOSYS() }
sub fs_flush {
# we're passed a path, but finding my coderef stuff from a path
# is a bit of a 'mare. flush the lot, won't hurt TOO much.
print "Flushing\n" if $debug;
%codecache = ();
return 0;
}
sub easy_getattr {
my ($mode, $size) = #_;
return (
0, 0, # $dev, $ino,
$mode,
1, # $nlink, see fuse.sourceforge.net/wiki/index.php/FAQ
$uid, $gid, # $uid, $gid,
0, # $rdev,
$size, # $size,
$ctime, $ctime, $ctime, # actually $atime, $mtime, $ctime,
1024, 1, # $blksize, $blocks,
);
}
sub fs_getattr {
my $path = shift;
my $obj = fetch($path);
# undef doesn't actually mean "file not found", it could be a coderef
# file-sub which has returned undef.
return easy_getattr(S_IFREG | 0200, 0) unless defined($obj);
switch (ref($obj)) {
case "ERROR" { # this is an error to be returned.
return -$$obj;
}
case "" { # this isn't a ref, it's a real string "file"
return easy_getattr(S_IFREG | 0644, length($obj));
}
# case "CODE" should never happen - already been run by fetch()
case "HASH" { # this is a directory hash
return easy_getattr(S_IFDIR | 0755, 1);
}
case "SCALAR" { # this is a scalar ref. we use these for symlinks.
return easy_getattr(S_IFLNK | 0777, 1);
}
else { # what the hell is this file?!?
print "+++ What on earth is ",ref($obj)," $path ?\n";
return easy_getattr(S_IFREG | 0000, 0);
}
}
}
sub fs_getdir {
my $obj = fetch(shift);
return -$$obj if ref($obj) eq "ERROR"; # THINK this is a good idea.
return -ENOENT() unless ref($obj) eq "HASH";
return (".", "..", sort(keys %$obj), 0);
}
sub fs_open {
# doesn't really need to open, just needs to check.
my $obj = fetch(shift);
my $flags = shift;
dump_open_flags($flags) if $debug;
# if it's undefined, and we're not writing to it, return an error
return -EBADF() unless defined($obj) or ($flags & O_ACCMODE());
switch (ref($obj)) {
case "ERROR" { return -$$obj; }
case "" { return 0 } # this is a real string "file"
case "HASH" { return -EISDIR(); } # this is a directory hash
else { return -ENOSYS(); } # what the hell is this file?!?
}
}
sub fs_read {
my $obj = fetch(shift);
my $size = shift;
my $off = shift;
return -ENOENT() unless defined($obj);
return -$$obj if ref($obj) eq "ERROR";
# any other types of refs are probably bad
return -ENOENT() if ref($obj);
if ($off > length($obj)) {
return -EINVAL();
} elsif ($off == length($obj)) {
return 0; # EOF
}
return substr($obj, $off, $size);
}
sub fs_readlink {
my $obj = fetch(shift);
return -$$obj if ref($obj) eq "ERROR";
return -EINVAL() unless ref($obj) eq "SCALAR";
return $$obj;
}
sub fs_release {
my ($path, $flags) = #_;
dump_open_flags($flags) if $debug;
return 0;
}
sub fs_statfs {
return (
255, # $namelen,
1,1, # $files, $files_free,
1,1, # $blocks, $blocks_avail, # 0,0 seems to hide it from df?
2, # $blocksize,
);
}
sub fs_truncate {
my $obj = fetch(shift, ""); # run anything to set it to ""
return -$$obj if ref($obj) eq "ERROR";
return 0;
}
sub fs_write {
my ($path, $buf, $off) = #_;
my $obj = fetch($path, $buf, $off); # this runs the coderefs!
return -$$obj if ref($obj) eq "ERROR";
return length($buf);
}
Final word: I didn't try to use the module itself (it's not listed in my distro package repository, and I was too lazy (sorry) to install it by cpanm or other way). But I think that if I'll have to just use FUSE with Perl, I'll probably just use Fuse::Simple instead of Fuse, maybe forking it. I'd use plain Fuse only for my academic research, I think...
Hope this helps.
I can't see any information in the Azure Blob Service Error Code list https://msdn.microsoft.com/en-us/library/dd179439.aspx that relates to error 596.
I am trying to upload some blocks to the Azure service and am getting a response back from the API with code 596 and description 'Broken pipe'.
Has anyone encountered this before ?
(N.B. Yes, I know the code below is not complete yet in that the code as-is does not upload the final chunk)
#!/usr/bin/perl
use 5.014;
use strict;
use warnings;
use autodie;
use Data::Dumper;
use Digest::MD5 qw(md5_base64);
use Crypt::PRNG::Fortuna qw(random_bytes_b64u random_bytes);
use Digest::SHA qw(hmac_sha256_base64);
use Getopt::Long;
use Sys::Syslog qw( :DEFAULT setlogsock);
use File::stat;
use AnyEvent;
use AnyEvent::HTTP;
use Time::Piece;
use Encode qw(decode encode);
use MIME::Base64 qw(encode_base64 decode_base64 encode_base64url);
use FileHandle;
use Fcntl ':flock', 'SEEK_SET';
delete #ENV{'PATH', 'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
use sigtrap 'handler' => \&term_handler, 'normal-signals';
####### PARAMS
my $script="upload.pl";
my $maxSingleUpload=1048576; # Maximum size of a single attempt upload (in bytes);
my $multiChunkSize=4194304; # Maximum size of a single block (in bytes)
my $multiLimit=6; # Maximum number of parallel HTTP requests
####### AZURE
my $azureKey="<REMOVED>";
my $azureKeyBin=decode_base64($azureKey);
####### ARGS
my ($vault,$container,$localfile,$remotefile);
my $debug=0;
GetOptions(
"vault|v=s" => \$vault,
"container|c=s" => \$container,
"localfile|l=s" => \$localfile,
"remotefile|r=s" => \$remotefile,
"debug|d+" => \$debug
);
if (!defined $vault || !defined $container || !defined $localfile || !defined $remotefile) {
say "USAGE: -v <vault> -c <container> -l <localfile> -r <remotefile> [-d (debug)]";
exit 1;
}
if (!-e $localfile) {
say "Local file does not exist !";
exit 1;
}
####### Vars
my ($wholeChunks,$chunkRemainder,$runID,$condvar,#offsets,#blocklist);
my $activeCount=0;
my $putBlockURL="https://${vault}.blob.core.windows.net/${container}/${remotefile}?comp=block&blockid=";
####### FUNCTIONS
# Quotient remainder calculator
sub qrem {
use integer;
my( $dividend, $divisor ) = #_;
my $quotient = $dividend / $divisor;
my $remainder = $dividend % $divisor;
my #result = ( $quotient, $remainder );
return #result;
}
# Do pad
sub doPad {
my ($raw) = #_;
while (length($raw) % 4) {
$raw .= '=';
}
return $raw;
}
# Random
sub getRandom {
my ($len) = #_;
#return doPad(random_bytes_b64u($len));
return doPad(encode_base64(random_bytes($len)));
}
# Term handler
sub term_handler {
doLog("err","term_handler: Program terminated early due to user input");
exit 2;
}
# Log sub
sub doLog {
my ($priority,$msg) = #_;
return 0 unless ($priority =~ /info|err|debug/);
setlogsock('unix');
openlog($script, 'pid,cons', 'user');
syslog($priority, $msg);
closelog();
return 1;
}
# Get file size
sub fileSz {
my($file) = #_;
my $stat = stat($file);
return $stat->size;
}
# Get data
sub readData {
my ($file,$length,$offset)=#_;
my $fh = FileHandle->new;
my ($data);
if ($debug) { say "Reading ${file} offset ${offset} for length ${length}";}
#open ($fh,"<",$file);
$fh->open("< $file");
binmode($fh);
seek($fh,$offset,SEEK_SET);
read($fh,$data,$length);
if ($debug) { say "readData read ".byteSize($data);}
#close($fh);
$fh->close;
return $data;
}
# Calc MD5
sub calcMD5 {
my ($data)=#_;
my $hash = md5_base64($data);
return doPad($hash);
}
# Populate offsets
sub populateOffsets {
my ($count,$offsetSize)=#_;
if (!defined $count || !defined $offsetSize) {exit 1;}
my $offset=0;
my #offsets;
for my $i (1..$count) {
push #offsets,$offset;
$offset = $offset + $offsetSize;
}
return #offsets;
}
# Calc auth string
sub azureAuth {
my($t,$signstring)=#_;
if (!defined $signstring) { exit 1;}
if ($debug) {say "String to sign:${signstring}";}
my $auth;
$auth=doPad(hmac_sha256_base64($signstring,$azureKeyBin));
if ($debug) { say "Sig:${auth}";}
return $auth;
}
# Byte size
sub byteSize {
use bytes;
my ($inval)=#_;
return length($inval);
}
# Process
sub doProcess {
return if $activeCount >= $multiLimit;
my $offset = shift #offsets;
return if !defined $offset;
$activeCount++;
if ($debug) { say "Active:${activeCount}, Offset:${offset}";}
$condvar->begin;
my $t = localtime;
my $tNow = $t->strftime();
my $blockid = getRandom(8);
my $subRunID=getRandom(5);
my $contentLength=$multiChunkSize-1;
my $content = readData($localfile,$contentLength,$offset);
my $hash = calcMD5($content);
if ($debug) { say "Block ID:${blockid}, Hash: ${hash}";}
my $url = $putBlockURL.$blockid;
my $canocResource="/${vault}/${container}/${remotefile}\nblockid:${blockid}\ncomp:block";
my $hdrs="x-ms-client-request-id:${runID}\nx-ms-date:${tNow}\nx-ms-version:2009-09-19";
my $byteLength=byteSize(${content});
my $canocHeaders=encode('UTF-8',"PUT\n\n\n${byteLength}\n${hash}\n\n\n\n\n\n\n\n${hdrs}\n${canocResource}",Encode::FB_CROAK);
my $authData=azureAuth($t,$canocHeaders);
if ($debug) {say "Length:${byteLength}";say "Sig: ${authData}"; say "URL:${url}";}
my $azureArr = {
"Authorization"=>"SharedKey ${vault}:${authData}",
"Content-Length"=>${byteLength},
"Content-MD5"=>${hash},
"x-ms-version"=>"2009-09-19",
"x-ms-date"=>${tNow},
"x-ms-client-request-id"=>"${runID}"
};
####### ERROR OCCURS HERE ....
http_request "PUT" => $url,
persistent=>0,
headers=>$azureArr,
body=>$content,
sub {
my ($body, $hdr) = #_;
say Dumper($hdr);
#say "received, Size: ", length $body;
#say $body;
$activeCount--;
$condvar->end;
doProcess();
};
return 1;
}
####### MAIN
$runID=getRandom(5);
doLog("info","${runID} Starting upload for ${localfile} (${remotefile})");
if (fileSz($localfile)<$maxSingleUpload) {
if ($debug) {say "Using single upload method";}
} else {
if ($debug) {say "Using multi-upload method";}
# Calculate chunk quantity
my #chunks = qrem(fileSz($localfile),$multiChunkSize);
$wholeChunks=$chunks[0];
$chunkRemainder=$chunks[1];
if ($debug) {say "Whole chunks (${multiChunkSize}):${wholeChunks}, Remainder:${chunkRemainder}";}
# Init
#offsets=populateOffsets(${wholeChunks},${multiChunkSize});
say Dumper(#offsets);
$condvar = AnyEvent->condvar;
# DO IT
for (1..$multiLimit) {
doProcess();
}
$condvar->recv;
}
doLog("info","${runID} Upload complete");
exit 0;
Error 596 is a client-side error returned by AnyEvent::HTTP. You need to investigate locally to see why you are hitting this error.
See this page for more info:
https://metacpan.org/pod/AnyEvent::HTTP
596 - errors during TLS negotiation, request sending and header processing.
In this example:
$logger->debug({
filter => \&Data::Dumper::Dumper,
value => $ref
});
I can pretty print my references instead of ARRAY(0xFFDFKDJ). But it's too boring to type that long code every time. I just want:
$logger->preprocessor({
filter => \&Data::Dumper::Dumper,
value => $ref
});
$logger->debug( $ref, $ref2 );
$logger->info( $array );
And $ref, $ref2, and $array will be dumped by Data::Dumper.
It there a way to do this?
UPD
With help of your answers I do the patch
Now you just:
log4perl.appender.A1.layout=FallbackLayout
log4perl.appender.A1.layout.chain=PatternLayout
log4perl.appender.A1.layout.chain.ConversionPattern=%m%n
log4perl.appender.A1.warp_message = sub { $#_ = 2 if #_ > 3; \
return #_; }
# OR
log4perl.appender.A1.warp_message = main::warp_my_message
sub warp_my_message {
my( #chunks ) = #_;
use Data::Dump qw/ pp /;
for my $msg ( #chunks ) {
$msg = pp $msg if ref $msg;
}
return #chunks;
}
UPD2
Or you can use this small module
log4perl.appender.SomeAPP.warp_message = Preprocess::Messages::msg_filter
log4perl.appender.SomeAPP.layout = Preprocess::Messages
package Preprocess::Messages;
sub msg_filter {
my #chunks = #_;
for my $msg ( #chunks ) {
$msg = pp $msg if ref $msg;
}
return #chunks;
};
sub render {
my $self = shift;
my $layout = Log::Log4perl::Layout::PatternLayout->new(
'%d %P %p> %c %F:%L %M%n %m{indent=2}%n%n'
);
$_[-1] += 1; # increase level of the caller
return $layout->render( join $Log::Log4perl::JOIN_MSG_ARRAY_CHAR, #{ shift() }, #_ );
}
sub new {
my $class = shift;
$class = ref ($class) || $class;
return bless {}, $class;
}
1;
Yes, of course you can set 'warp_message = 0' and combine msg_filter and render together.
log4perl.appender.SomeAPP.warp_message = 0
log4perl.appender.SomeAPP.layout = Preprocess::Messages
sub render {
my($self, $message, $category, $priority, $caller_level) = #_;
my $layout = Log::Log4perl::Layout::PatternLayout->new(
'%d %P %p> %c %F:%L %M%n %m{indent=2}%n%n'
);
for my $item ( #{ $message } ) {
$item = pp $item if ref $item;
}
$message = join $Log::Log4perl::JOIN_MSG_ARRAY_CHAR, #$message;
return $layout->render( $message, $category, $priority, $caller_level+1 );
}
The easy way: use warp_message
The easiest way to do this is to create a custom appender and set the warp_message parameter so you can get the original references that were passed to the logger:
package DumpAppender;
use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Terse = 1;
sub new {
bless {}, $_[0];
}
sub log {
my($self, %params) = #_;
print ref($_) ? Dumper($_) : $_ for #{ $params{message} };
print "\n";
}
package main;
use strict;
use warnings;
use Log::Log4perl;
Log::Log4perl->init(\q{
log4perl.rootLogger=DEBUG,Dump
log4perl.appender.Dump=DumpAppender
log4perl.appender.Dump.layout=NoopLayout
log4perl.appender.Dump.warp_message=0
});
my $logger = Log::Log4perl->get_logger;
$logger->debug(
'This is a string, but this is a reference: ',
{ foo => 'bar' },
);
Output:
This is a string, but this is a reference: {'foo' => 'bar'}
Unfortunately, if you take this approach, you're stuck writing your own code to handle layouts, open files, etc. I wouldn't take this approach except for very simple projects that only need to print to screen.
A better way: composite appender
A better approach is to write your own composite appender. A composite appender forwards messages on to another appender after manipulating them somehow, e.g. filtering or caching them. With this approach, you can write only the code for dumping the references and let an existing appender do the heavy lifting.
The following shows how to write a composite appender. Some of this is explained in the docs for Log::Log4perl::Appender, but I copied much of it from Mike Schilli's Log::Log4perl::Appender::Limit:
package DumpAppender;
use strict;
use warnings;
our #ISA = qw(Log::Log4perl::Appender);
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Terse = 1;
sub new {
my ($class, %options) = #_;
my $self = {
appender => undef,
%options
};
# Pass back the appender to be limited as a dependency to the configuration
# file parser.
push #{ $options{l4p_depends_on} }, $self->{appender};
# Run our post_init method in the configurator after all appenders have been
# defined to make sure the appenders we're connecting to really exist.
push #{ $options{l4p_post_config_subs} }, sub { $self->post_init() };
bless $self, $class;
}
sub log {
my ($self, %params) = #_;
# Adjust call stack so messages are reported with the correct caller and
# file
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2;
# Dump all references with Data::Dumper
$_ = ref($_) ? Dumper($_) : $_ for #{ $params{message} };
$self->{app}->SUPER::log(
\%params,
$params{log4p_category},
$params{log4p_level}
);
}
sub post_init {
my ($self) = #_;
if(! exists $self->{appender}) {
die "No appender defined for " . __PACKAGE__;
}
my $appenders = Log::Log4perl->appenders();
my $appender = Log::Log4perl->appenders()->{$self->{appender}};
if(! defined $appender) {
die "Appender $self->{appender} not defined (yet) when " .
__PACKAGE__ . " needed it";
}
$self->{app} = $appender;
}
package main;
use strict;
use warnings;
use Log::Log4perl;
Log::Log4perl->init(\q{
log4perl.rootLogger=DEBUG, Dump
log4perl.appender.Dump=DumpAppender
log4perl.appender.Dump.appender=SCREEN
log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
log4perl.appender.SCREEN.layout=PatternLayout
log4perl.appender.SCREEN.layout.ConversionPattern=%d %p %m%n
});
my $logger = Log::Log4perl->get_logger;
$logger->debug(
'This is a string, but this is a reference: ',
{ foo => 'bar' },
);
Output:
2015/09/14 13:38:47 DEBUG This is a string, but this is a reference: {'foo' => 'bar'}
Note that you have to take some extra steps if you initialize Log::Log4perl via the API instead of via a file. This is documented in the composite appenders section of the Log::Log4perl::Appender documentation.
I'm trying to write a wrapper for Oracle Connection(see the Ora package).
I'm using it like the following:
$fine->dbconnect()or die $_;
my $h = $fine->execSql("update qot set qot_sup_xpressfeed='$s' where qot_id=$h->{$k}->{'QOT_ID'}") ;
print "update qot set qot_sup_xpressfeed='$s' where qot_id=$h->{$k}->{'QOT_ID'}";
$fine->dbdisconnect() or die $_;
And here the Ora class:
package Ora;
use strict;
use warnings;
use DBI;
use DBD::Oracle;
use DBD::Oracle qw(:ora_types);
use Utils;
sub new
{
my ($class, $dbname, $user) = #_;
my $self = {
_dbname => lc($dbname),
_user => lc($user),
# _sth => {}
};
bless $self, $class;
return $self;
}
sub dbconnect
{
use Ora::Ora_db;
my ($this) = #_;
my $dberror = "";
my $dbdriver;
my $OS = $^O;
$ENV{'ORACLE_SID'} = $this->{_dbname};
$ENV{'ORACLE_TERM'} = "vt220";
if ($OS =~ /linux/ )
{
$ENV{'ORACLE_HOME'} = "/opt/oracle/product/10.2";
$ENV{'ORACLE_BASE'} = "/opt/oracle";
$ENV{'TNS_ADMIN'} = "/opt/oracle/product/10.2/network/admin";
$ENV{'ORA_NLS33'} = "/opt/oracle/product/10.2/ocommon/nls/admin/data"; ## TODO: Weg, wenn nur noch 1 Client!!
$ENV{'NLS_LANG'} = "GERMAN_GERMANY.WE8ISO8859P1";
}
$dbdriver = DBI->install_driver('Oracle')
or return("DB-Treiber konnte nicht geladen werden");
my $utils=new Utils();
$utils->meldung( 'Basis',"Starte DB-Verbindung|". $this->{_dbname});
my $oradb = new Ora_db($this->{_dbname});
$this->{_connection} = $dbdriver->connect(
$this->{_dbname},
"QF",
$oradb->getParam() ,
{
RaiseError => 1,
AutoCommit => 0
}) || die "Database connection not made: $DBI::errstr";
return 1;
}
sub dbdisconnect
{
my ($this ) = (#_);
return($this->{_connection}->disconnect);
}
sub execSql
{
my ($this, $mysql, $key) = (#_);
my $sth;
my $i=0;
my #rs_to; # 2dim Array!
$sth = $this->{_connection}->prepare($mysql) || die "$mysql -> ".$this->{_connection}->errstr;
$sth->execute() or die "Fehler bei sth->execute: ".$this->{_connection}->errstr;
##my $rs = $this->_toArray($sth);
my $rs = $this->_toHash($sth, $key);
$sth->finish();
$this->{_connection}->commit;
return $rs;
}
sub _toHash
{
my ($this, $sth, $key) =#_;
$sth->fetchall_hashref($key)or die($_);
}
But I'm getting this error:
Assertion i == (((((SV *) (name_av))->sv_flags & 0x00008000)) ? Perl_mg_size(my_perl, (SV *) name_av) : ((XPVAV*) (name_av)->sv_any)->xav_fill)+1 failed: file "DBI.xs", line 1844 at /usr/lib/perl5/site_perl/5.8.7/i586-linux-thread-multi/DBI.pm line 1999.
Issuing rollback() for database handle being DESTROY'd without explicit disconnect().
Could anyone give me any clue what am I doing wrong?
TIA,
Greetings
r.
I got it...This solved my problem!
my $rs ;
$rs = $this->_toHash($sth, $key) if ($key);
$sth->finish();
$this->{_connection}->commit;
return $rs;
Greetings & thanks!