MATLAB: determine dependencies from 'command line' excluding built in dependencies - matlab

Is there a way to determine all the dependencies of an .m file and any of the dependencies of the files it calls using a command in a script (command-line)?
There was a question like this before and it was really good because it suggested using the depfun function. BUT the issue with this was that it is outputting the MATLAB related files that it depends on as well.
EXAMPLE:
testing.m
disp('TESTING!!');
The output of depfun('testing')
'C:\testing.m'
'C:\MATLAB\R2008a\toolbox\matlab\datatypes\#opaque\char.m'
'C:\MATLAB\R2008a\toolbox\matlab\datatypes\#opaque\double.m'
'C:\MATLAB\R2008a\toolbox\matlab\datatypes\#opaque\toChar.m'
'C:\MATLAB\R2008a\toolbox\matlab\elfun\log10.m'
'C:\MATLAB\R2008a\toolbox\matlab\elmat\ans.m'
etc.
The list is a little bit longer.
The point here is that I was hoping there would be some similar function or a flag that would remove these unwanted dependencies.

Here are a couple of links I found helpful when I wrote up a simple function to create a table of contents for an m-file:
A thread discussing the undocumented function MLINTMEX
FDEP by Urs Schwarz on the MathWorks File Exchange
FARG by Urs Schwarz on the MathWorks File Exchange
EDIT: Since this problem piqued my curiosity, I started trying out a few ways I might approach it. Finding the dependencies on non-toolbox .m and .mex files was relatively trivial (I did this in MATLAB version 7.1.0.246):
fcnName = 'myfile.m';
fcnList = depfun(fcnName,'-quiet');
listIndex = strmatch('C:\Program Files\MATLAB71\toolbox',fcnList);
fcnList = fcnList(setdiff(1:numel(fcnList),listIndex));
Here, I just used DEPFUN to get the dependencies, then I removed any files that began with 'C:\Program Files\MATLAB71\toolbox', where the MATLAB toolboxes are located on my machine. Note that this assumes you aren't placing any of your own code in these MATLAB directories (which you shouldn't do anyway).
To get dependencies on .mat and .txt files, I took another approach. For each of the files you get from the above code, you could load the text of the file into MATLAB and parse it with a regular expression to find strings that end in a '.mat' or '.txt':
fid = fopen(fcnName,'rt');
fcnText = fscanf(fid,'%c');
fclose(fid);
expr = '[^\'']\''([^\''\n\r]+(?:\w\.(?:mat|txt)){1})\''[^\'']';
dataFiles = regexp(fcnText,expr,'tokens');
dataFiles = unique([dataFiles{:}]).';
There are a few limitations to the regular expression I used:
If you have a string like 'help.txt' that appears in a comment (such as the help comment block of a function), it will still be detected by the regular expression. I tried to get around this with a lookaround operator, but that took too long to run.
If you build a string from variables (like "fileString = [someString '.mat']"), it will not be detected by the regular expression.
The returned strings of file names will be relative path strings. In other words, if you have the strings 'help.txt' or 'C:\temp\junk.mat' in the function, the regular expression matching will return 'help.txt' or 'C:\temp\junk.mat', exactly as they appear in the function. To find the full path, you can use the WHICH function on each data file (assuming the files reside somewhere on the MATLAB path).
Hope you find these useful! =)

Try DepSubFun from TMW FileExchange.

Another way is just to exclude folders you don't need:
localdep = depfunresult(cellfun(#isempty,regexp(a,'toolbox')));
You can use any regexp pattern there.

Thank you for the responses so far.
I do not think that these are quite what I am looking to accomplish.
I was hoping there was already something that would determine local functions called within the main m-file, add them to the list, and proceed to look in each one until there are none left. It doesn't seem that any of these solutions do this
I have come up with a scheme that I will try to implement. It may be a bit brute force and the design might change as I work on it, but here is the concept.
There are quite a few assumptions made in this initial design but since it is mostly for me and a few others I don't think it will be a big issue for my general solution.
Files types to look for: .m .mat .mex* .txt (will be updated as needed)
Determine matlabpath and weed out toolbox paths (this is where it is an assumption your working directories are not called toolbox or that you don't have any special m-files you added to the other toolboxes)
hopefully leaving you only with directories you use and can call functions from. (also assumes you don't hardcode some type of [run 'C:\random\myscript.m']
brute force part:
look for the file types you are interested in and make a list of the ones in your working directory (pwd) and the remaining matlab paths
remove filenames that match one in the working directory.
iterate through searching the main m-file for each filename, if found add it to the array of dependent files. remove dependent files from the original list. search dependent files list with the "new" original list, repeat until no files left or no matches at all.
So far this is just the concept I have, I will also be searching a little more as well.

I got this script finally running today, it is a windows matlab based one as it makes a '!findstr "something" file.txt' call. (I would have preferred a grep but didn't know matlab equivalent.
I am going to ask my boss if I am allowed to post it on the matlab file exchange to share with others so hopefully I will update this soon with the link.
gnovice:
I don't have enough rep to comment on gnovice's comment of my description I wrote prior to writing the code.
But basically to determine which what it does is takes the filename of all files (broken into category of filetype), strips off the fullpathname and the extension, uses the above mentioned !findstr command to search it in the .m file that you are building the dependency for and outputs that to a temp.txt file (this is because I couldn't figure out a way to get a 1 or 0 or isempty return on the output of the command)
here is a breakdown of what I personally search for to determine if each file is used:
.m : 'filename ' or 'filename(' % covers the 'filename (' case
.mex* : same as above
.mat : was doing same as above but am going to change to some sort of load and the 'filename.mat' working on this probably tomorrow
.txt : simply searches for 'filename.txt'
With this method you may end up with a few extra text files or .m files but the key here is you should at least have all the files you need.
It also recursively calls itself on all the dependent files so that their dependencies are taken into account too.
-TaRDy

I wrote code a long time ago to do this for octave. I use it mainly to generate .dot files for graphviz to visualize the dependencies, but I also use it in makefiles for wrapping up dependencies when compiling code. it is perl code, unfortunately, but you can run it from a script by calling it via shell. it is fully recursive.
to run it, you'll have to change the OCT_BASE to point to the root directory of your code. (sorry, it is not matlab's path-variable aware). then I would probably run it as perl octavedepgrapher.pl -l
#! /bin/sh
exec perl -x -S $0 ${1+"$#"} # -*-perl-*-
#!perl
#
# octavedepgrapher.pl
# find the dependancy graph of octave file(s). prints a
# dot file suitable for graphviz
# Author: steven e. pav
# Created: 2006.07.16
# SVN: $Id$
#
# * Thu Aug 30 2007 Steven Pav
# - expanding to recognize matlabs pragma of %#function funcname
# version 0.3 2007.04.17
# add raw output mode.
# version 0.2 2007.03.05
# add media selection
# version 0.1 2006.08.24
# fixed multiple functions within file.
# added multiple edgeout capability.
# adding clusters for files.
# version 0.0 2006.07.16
# created.
#
#
########################################################################
########################################
# change only this
########################################
##OCT_BASE = qw(/home/spav/sys/octave/m/ ./ $ENV{OCTAVE});
#OCT_BASE = qw(/home/spav/sys/octave/m/ ./);
########################################################################
$VERSION = "octavedepgrapher version 0.02 2006.08.23\n";
########################################################################
use Getopt::Long;
$Getopt::Long::ignorecase = 0;
$Getopt::Long::order = $PERMUTE;
%OPT_MEANINGS = (
'H' => 'show Help.',
'l' => 'list the dependencies to standard out. do not make a dot file.',
'p' => 'give full path names.',
'm' => 'multi-edge. one for each function call.',
'g' => 'map connections from functions to global variables.',
'G' => 'map connections between functions which share global variables.',
'C' => 'do not cluster files.',
'D' => 'Debug.',
'd=s' => 'dependency mode for makefiles. sets -p and -l, and but outputs in makefile suitable format. the string is the extension (with dot) to substitute for .m',
'r=s' => 'aspect ratio (can be fill, auto, compact (default))',
'B=s' => 'base directory. if given, all directories are assumed relative to this one.',
'L=s' => 'colon separated list of base directories of libraries (_overrides_ OCT_BASE). should probably include ./',
'l=s' => 'colon separated list of base directories of libraries (in addition to OCT_BASE).',
'X=s' => 'colon separated list of base directories to exclude in the search.',
'M=s' => 'media selection',
);
$OPTS = join('',(map { substr($_,0,1); } keys(%OPT_MEANINGS)));
&GetOptions(keys %OPT_MEANINGS);
$opt_H && &die_usage; #done
$opt_L && (#OCT_BASE = split(/\s*:\s*/,$opt_L));
$opt_l && (push(#OCT_BASE,split(/\s*:\s*/,$opt_l)));
$opt_X && (#OCT_BASE = #{&rm_dirs(\#OCT_BASE,$opt_X)});
if (not $opt_M)
{ $size="25,20";
} else {
($opt_M =~ m/^legal/i) and $size = '8.5,14';
($opt_M =~ m/^letter/i) and $size = '8.5,11';
($opt_M =~ m/^A0$/i) and $size = '33.1,46.8';
($opt_M =~ m/^A1$/i) and $size = '23.4,33.1';
($opt_M =~ m/^A2$/i) and $size = '16.5,23.4';
($opt_M =~ m/^A3$/i) and $size = '11.7,16.5';
($opt_M =~ m/^A4$/i) and $size = '8.3,11.7';
($opt_M =~ m/^A4dj$/i) and $size = '8.3,11.7';
($opt_M =~ m/^A5$/i) and $size = '5.8,8.3';
}
#if (not $opt_r) { $ratio = 'fill'; } else { $ratio = $opt_r; }
$ratio = $opt_r || 'fill';
if ($opt_d)
{
$opt_l = $opt_p = 1;
}
#make sure it has a tailing slash.
if ($opt_B)
{
($opt_B !~ m{/$}) && ($opt_B .= q[/]);
}
########################################################################
$| = 1;
if (! #ARGV)
{
&die_usage;
} else
{
%mfhash = &map_name_to_filename(#ARGV);
}
if ($opt_d)
{
#myargv = #ARGV;
print join(' ',map { s/\.m/$opt_d/e;$_; } #ARGV),qq[ : ];
}
if ($opt_l) {
%bdhash = &find_base_libs(#OCT_BASE);
$alldepref = &find_all_deps(\%mfhash,\%bdhash,0);
print join(' ',#{$alldepref}),qq[\n];
} else {
&print_head();
%bdhash = &find_base_libs(#OCT_BASE);
&find_all_deps(\%mfhash,\%bdhash,1);
&print_tail();
}
$opt_X && (#OCT_BASE = #{&rm_dirs(\#OCT_BASE,$opt_X)});
########################################################################
sub
rm_dirs
#remove directories from OCT_BASE
{
my $ob_ref = shift(#_);
my $oX = shift(#_);
my #excludeus = split(/\s*:\s*/,$oX);
#FIX!
}
########################################################################
sub
make_relative
#just for the sake of opt_B#FOLDUP
{
my $fullname = shift(#_);
if ($opt_B)
{
$fullname =~ s{\Q$opt_B\E}{};
}
return $fullname;
}#UNFOLD
########################################################################
sub
map_name_to_filename#FOLDUP
{
my $mfile;
my %mfiles;
my $mfstub;
while ($mfile = shift(#_))
{
$mfstub = $mfile;
$mfstub =~ s/^\s*(.*\/)?([^\/]+)\.m\s*$/$2/;
$mfiles{$mfstub} = $mfile;
}
return %mfiles;
}#UNFOLD
########################################################################
sub
find_base_libs#FOLDUP
{
my $based;
my %bdhash;
my ($mfile,$mfstub);
my #mfiles;
while ($based = shift(#_))
{
# print "|$based|\n";
#mfiles = split(/\n/,qx(cd $based && find . -name '*.m'));
while ($mfile = shift(#mfiles))
{
$mfstub = $mfile;
$mfstub =~ s/.+\/([^\/]+)\.m/$1/;
$mfile =~ s/^\s*\.\//$based/;
$bdhash{$mfstub} = $mfile;
#print STDERR "|$mfstub| -> |$mfile| |$based|\n";
}
}
return %bdhash;
}#UNFOLD
########################################################################
#returns array of all the dependencies as filename strings.
sub
find_all_deps#FOLDUP
{
my $mfhashref = shift(#_);
my $bdhashref = shift(#_);
my $doprint = shift(#_); #if 0, do not print anything out.
my #mfhashlist = %{$mfhashref};
my %bdhash = %{$bdhashref};
my $output = [];
my %globals;
my $gname;
my %doneok;
my ($mfname,$mfloc);
my ($aline,$acommand,$copyline);
my %eegraph; #store as node::node in this hash set.
#prevents edges from being written multiple times?
my %dangling = {}; #any command which has yet to be found.
#store vals a list of things which want to point in.
my $pointsin;
my $foundnewfunc;
my $foundFuncPragma; #for looking for % #function fname stuff
#my #myDependencies; #every function that I call;
my $edgestr = '';
while ($mfname = shift(#mfhashlist))#FOLDUP
{
$mfloc = shift(#mfhashlist);
$mf_alias = ($opt_p)? &make_relative($mfloc) : $mfname; #full names or not
#prevent node -> self edges.
$eegraph{qq(${mfname}::${mfname})} = 1;
if ((! $opt_C) && $doprint)
{
print qq(subgraph cluster_$mfname {\n);
print qq(rank=min\n);
print qq(ordering=out\n);
}
#node
$doprint &&
print qq{$mfname [label="$mf_alias" shape=plaintext fontsize=44]\n};
push (#{$output},$mf_alias);
$doneok{$mfname} = 1;
#open a file#FOLDUP
open (FH,"$mfloc") || die "no open $mfloc, $!";
while (! eof(FH))
{
$aline = ;
chomp($aline);
$foundFuncPragma = 0;
if ($aline =~ /^[^%]*end\s*%?\s*function/) { $mfname = ''; }
if ($mfname) #inside a function
{
if ($opt_g || $opt_G) #look for globals#FOLDUP
{
if ($aline =~ /global/)
{
$copyline = $aline;
while ($copyline =~ s/(global\s+)([^;\s]+)(\s*;)/$1$3/)
{
$gname = $2;
if (exists $globals{$gname})
{
push(#{$globals{$gname}},$mfname);
} else {
$globals{$gname} = [$mfname];
}
}
}
}#UNFOLD
#look for #function pragma
$foundFuncPragma = ($aline =~ s/%\s*#function\s+(.+)$//);
if ($foundFuncPragma)
{
$opt_D && (print STDERR "found a function pragma! |$1|\n");
#what a bummer that we can't just use this: the
#problem is that we don't really know when a function
#ends in .m code, b/c endfunction is not required. bummer.
#push (#myDependencies,split(/\s+/,$1));
#
#that is, what we would really like to do is just push onto a list
#every time we saw a command, then puke at the end of the function,
#but we do not know really when a function ends in matlab. oops.
foreach $acommand (split(/\s+/,$1))
{
$opt_D && (print STDERR "found a command! |$acommand|\n");
#push (#myDependencies,$acommand);
if (exists($bdhash{$acommand}))
{
$opt_D && (print STDERR "exists in bdhash (prolly means is a file to itself)\n");
if (! $eegraph{qq(${mfname}::${acommand})})
{
if ($opt_C) { $doprint && print "$mfname -> $acommand\n";
} else { $edgestr .= "$mfname -> $acommand\n"; }
if (! $opt_m) { $eegraph{qq(${mfname}::${acommand})} = 1; }
}
if (! $doneok{$acommand})
{
$doneok{$acommand} = 1;
push(#mfhashlist,$acommand,$bdhash{$acommand});
}
} else
{
if (exists($dangling{$acommand}))
{ push(#{$dangling{$acommand}},$mfname);
} else { $dangling{$acommand} = [$mfname]; }
}
}
}
while ($aline =~ /([a-zA-Z0-9_]+)\s*\(/)#FOLDUP
{
$aline =~ s/([a-zA-Z0-9_]+)\s*\(//;
$acommand = $1;
$opt_D && (print STDERR "found a command! |$acommand|\n");
#push (#myDependencies,$acommand);
if (exists($bdhash{$acommand}))
{
$opt_D && (print STDERR "exists in bdhash (prolly means is a file to itself)\n");
if (! $eegraph{qq(${mfname}::${acommand})})
{
if ($opt_C) { $doprint && print "$mfname -> $acommand\n";
} else { $edgestr .= "$mfname -> $acommand\n"; }
if (! $opt_m) { $eegraph{qq(${mfname}::${acommand})} = 1; }
}
if (! $doneok{$acommand})
{
$doneok{$acommand} = 1;
push(#mfhashlist,$acommand,$bdhash{$acommand});
}
} else
{
if (exists($dangling{$acommand}))
{ push(#{$dangling{$acommand}},$mfname);
} else { $dangling{$acommand} = [$mfname]; }
}
}#UNFOLD
} else #not yet inside a function.
{
$foundnewfunc = 0;
if ($aline =~ /^[^%]*function\s+[^=]*=\s*([a-zA-Z0-9_]+)\s*(\(|;|%|$)/)
{
$mfname = $1;$foundnewfunc = 1;
} elsif ($aline =~ /^[^%]*function\s+([a-zA-Z0-9_]+)\s*(\(|;|%|$)/)
{
$mfname = $1;$foundnewfunc = 1;
}
if ($foundnewfunc)
{
##myDependencies = ();
$opt_D && (print STDERR "now looking at function |$mfname|\n");
$eegraph{qq(${mfname}::${mfname})} = 1;
#subnode
$doprint && print "$mfname [shape=box]\n";
$doneok{$mfname} = 1;
$bdhash{$mfname} = 1; #innocent enough since doneok is set too.
if (exists($dangling{$mfname}))
{
while ($pointsin = shift(#{$dangling{$mfname}}))
{
$doprint && print "$pointsin -> $mfname\n";
}
}
}
}
}
close FH;#UNFOLD
if (! $opt_C)
{
$doprint && print qq(}\n);
$doprint && print $edgestr;
$edgestr = '';
}
}#UNFOLD
if ($doprint)
{
if ($opt_g)
{
foreach $key (keys(%globals))
{
print qq{$key [style=dotted label="$key" color=red shape=plaintext fontsize=44]\n};
foreach $f (#{$globals{$key}})
{
print qq{$f -> $key [color=red]\n};
}
}
} elsif ($opt_G)
{
foreach $key (keys(%globals))
{
while (defined($g = shift(#{$globals{$key}})))
{
# foreach $f (#{$globals{$key}}) { print qq{$g -- $f [color=red]\n}; }
foreach $f (#{$globals{$key}}) { print qq{$g -> $f [style=dotted label="$key" fontsize=30 fontcolor=red color=red]\n}; }
}
}
}
}
return $output;
}#UNFOLD
########################################################################
sub
print_head#FOLDUP
{
if (! $opt_m)
{
print qq[strict ];
}
# if ($opt_G) { print qq[octavedep {\n]; } else { print qq[digraph octavedep {\n]; }
print qq[digraph octavedep {\n];
print qq[nslimit=15.0\n];
print qq[mclimit=1.0\n];
print qq[ratio="$ratio"\n];
print qq[size="$size"\n];
}#UNFOLD
sub
print_tail#FOLDUP
{
print "}\n";
}#UNFOLD
########################################################################
sub
die_usage#FOLDUP
{
# print STDERR "usage: perl $0 [-$OPTS] [-$VALOPTS val] octfiles\n\n";
print STDERR "usage: perl $0 [-$OPTS] octfiles\n\n";
if ($opt_H)
{
%OPT_MEANINGS =
map {($a=$_)=~s/(.)+?[=:!]?[ifs]?/$1/;$a=>$OPT_MEANINGS{$_};}
keys %OPT_MEANINGS;
#OPTS = split(//,$OPTS);
while ($OP = shift(#OPTS)) {
print STDERR " $OP $OPT_MEANINGS{$OP}\n";
}
print STDERR "\n";
}
exit;
}#UNFOLD
########################################################################
__END__
works for me...

Though depfun doesn't provide an 'ignore-builtins' option, it does give us a '-toponly' option that we can use within our own recursive function that does exculde built-ins and runs much faster. Below is my solution:
function new_file_list = fastdepfun(paths)
% new_file_list = fastdepfun(paths)
% paths = same input as you use with depfun
[file_list] = depfun(paths,'-toponly','-quiet');
% Remove builtins (implement this part however you like)
mroot = matlabroot;
file_list = file_list(~strncmp(file_list,mroot,length(mroot)));
% Remove files already inspected (otherwise we get stuck in an infinite loop)
new_file_list = setdiff(file_list,paths);
if ~isempty(new_file_list)
new_file_list = fastdepfun(new_file_list);
end
new_file_list = unique([file_list; new_file_list]);

Related

How to Pinpoint Unmatch Segment/Parse Between Two Paths Perl

I have 2 paths that need to be compared, and if it is unmatch, I want to point out which sub-path or path that is not match. Is there any better way to do this? This is just for 2 path, I have a lot of paths that need to be compared.
#!/usr/bin/perl
use warnings;
use strict;
my $realPath= 'C/library/media/music/retro/perl.mp3'; #Absolute
my $comparedPath= 'music/classic/perl.mp3'; #Relative, a sample that need to be compare with the $realPath
my #compared_array;
my #realpath_array;
my %compared_hash;
tie %compared_hash, 'Tie::IxHash';
my %realpath_hash;
tie %realpath_hash, 'Tie::IxHash';
if ( $realPath=~ m/$comparedPath$/)
{
print "$comparedPath exist";
}
else
{
print "$comparedPath is not exist";
#compared_array=split /\//,$comparedPath;
#realpath_array=split /\//,$realPath;
}
#compared_hash{#compared_array}=1;
#realpath_hash{#realpath_array}=1;
foreach my $key (keys %compared_hash)
{
delete $compared_hash{$key} if (grep {$_ =~/$key/} (keys %realpath_hash));
#leaving only unmatch Path Segment/Parse
}
print join("\n",%compared_hash);
Output:
classic
There's several ways they could compare.
They don't overlap at all.
They overlap, but one is too short.
They partially overlap.
They overlap perfectly.
Turn the paths into arrays using File::Spec->splitpath and splitdir. Then the problem becomes a matter of comparing arrays. It's also much simpler inside its own function because we can return as soon as we reach a conclusion.
First, we can use List::MoreUtils::after_incl to find the point where they start overlapping. In your example #remainder is qw(music retro perl.mp3).
my #remainder = after_incl { $_ eq $rel_path->[0] } #$abs_path;
if( !#remainder ) {
say "The paths do not overlap";
return;
}
Then we can walk #remainder and the path together to find where they diverge. And we also need to make sure we don't walk off the path.
for my $idx (1..$#remainder) {
if( $idx > $#$rel_path ) {
say "The path is too short";
return;
}
if( $remainder[$idx] ne $rel_path->[$idx] ) {
say "The paths differ at $remainder[$idx] vs $rel_path->[$idx]";
return;
}
}
Finally, if they match we need to check if there's more on the end of the path.
if( #$rel_path > #remainder ) {
say "The path is too long";
return;
}
And if it passes all that, they overlap.
say "The path is a child";
return;
Put it all together...
use strict;
use warnings;
use v5.10;
use List::MoreUtils qw(after_incl);
sub find_difference {
my($abs_path, $rel_path) = #_;
my #remainder = after_incl { $_ eq $rel_path->[0] } #$abs_path;
if( !#remainder ) {
say "The paths do not overlap";
return;
}
for my $idx (1..$#remainder) {
if( $remainder[$idx] ne $rel_path->[$idx] ) {
say "The paths differ at $remainder[$idx] vs $rel_path->[$idx]";
return;
}
}
if( #$rel_path > #remainder ) {
say "The path is too long";
return;
}
say "The path is a child";
return;
}
find_difference(
[qw(library media music retro perl.mp3)],
[qw(music retro perl.mp3 foo bar)]
);

Perl error: not a reference

I recently migrated some Perl code from SunSolaris to a Linux(Ubuntu) box of 64 bit. After the migration Storable.pm is breaking with the following error:
Byte order is not compatible at /usr/lib/perl/5.18/Storable.pm, at /home/VD/Cache.pm line 347.
After some research on the internet I found that I need to use nfreeze instead of thaw, but now I receive the following error:
not a reference at /home/VD/Cache.pm line 347.
Any suggestions how to fix this?
sub get
{
my($self, $type, $param_ref) = #_;
#return 1 if(!$self->{'INI'}{'sf.system.cache.enabled'});
if($self->{'INI'}{'sf.system.cache.database.enabled'})
{
### DATABASE
my $param = $self->SF::Cache::convert_parameter($type, $param_ref);
if($self->SF::Cache::CACHE_TABLE_USERCONTENT && $$param{'type'} == 2)
{
### user-content
my $query = 'SELECT PARAM_CONTENT AS C, DATA AS D FROM sf_cache_usercontent WHERE SITE=? AND PARAM_USER=?';
my $bindvar = { 1=>$self->{'site'}, 2=>$$param{'user'} };
my $sth = $self->db_select($query, $bindvar);
#print SF::Util::debug_dumpquery($query, $bindvar);
return undef if($self->{'Error'});
my %usercontent;
undef(%usercontent);
while(my $hashref = $self->db_fetch($sth))
{
$usercontent{$$hashref{'C'}} = $$hashref{'D'};# ? 1 : 0;
}
return \%usercontent;
}
else
### ******************************************************************************************************
{
my $ret = $self->SF::Cache::get_database('DATA', $param);
return Storable::nfreeze($ret) if(defined $ret);
}
}
else
{
### FILESYSTEM
my $filename = $self->SF::Cache::filename($type, $param_ref);
if($filename && -e $filename)
{
if($self->{'INI'}{'sf.system.cache.lock.enabled'} && defined &lock_retrieve)
{
return lock_retrieve $filename;
}
else
{
return retrieve $filename;
}
}
else
{
$! = 0;
}
}
return undef;
}
Go back to your original system, thaw then nfreeze the file there to fix it.
perl -MStorable=nstore,retrieve -e'nstore(retrieve($ARGV[0]), $ARGV[1])' file fixed
So, "not a reference" means ... exactly what it says on the tin. Can you try printing the thingy with Data::Dumper from comments it's this line:
return Storable::nfreeze($ret) if(defined $ret)
So - what does:
print Dumper $ret;
produce? Is it a reference?
I'm not so sure though that you're right about needing nfreeze instead of thaw, because they both do different things. freeze packs a variable; thaw unpacks it. So nfreeze can replace freeze.
But the core purpose of doing this is to transfer your packed up scalar to another program on another architecture. Is this what you're doing?
If so, can I suggest instead considering transferring it as JSON or XML instead?

How can I separate print output when using asp-perl

I'm trying to use asp-perl to pre-process some files that have embedded perl, asp style (probably doesn't matter, but it's not html).
for example:
want this <%="yes"%>
not this <%print "no" %>
I would like it to yield:
want this yes
not this
and have the 'no' end up in a different file or stream.
Is there some flag/configuration to enable this? I tried looking in CGI, Apache::ASP,... and nothing's jumping out at me.
EDIT. After burning a bunch of time in the debugger, I've found that overriding these two subs gives me the result I want. a bit of a hack. I guess I only needed the first sub. The second is to avoid writing to a file.
sub Apache::ASP::InitPackageGlobals {
my $self = shift;
# unless ($self->{response_tied}) {
# # set printing to Response object
# $self->{response_tied} = 1;
# tie *RESPONSE, 'Apache::ASP::Response', $self->{Response};
# select(RESPONSE);
# }
# ---- init package objects ----
# unoptimized this because we should only call this function once
# and maybe twice if there is a defined Script_OnStart
for my $object (#Apache::ASP::Objects) {
for my $import_package (#{$self->{init_packages}}) {
my $init_var = $import_package.'::'.$object;
$$init_var = $self->{$object};
}
}
undef;
}
my $parse_results = "";
sub Apache::ASP::CGI::print {
shift;
$parse_results .= join("", map { ref($_) =~ /SCALAR/ ? $$_ : $_; } #_);
}

Perl - Prevent duplicate by checking if pattern already exist in opened file before writing

I have a perl script that manage conversion of a specific file format into csv files i can manage later.
I need this script to be able to prevent generating duplicated lines:
#get timetamp
if ((rindex $l,"ZZZZ,") > -1) {
(my $t1, my $t2, my $timestamptmp1, my $timestamptmp2) = split(",",$l);
$timestamp = $timestamptmp2." ".$timestamptmp1;
}
if (((rindex $l,"TOP,") > -1) && (length($timestamp) > 0)) {
(my #top) = split(",",$l);
my $aecrire = $SerialNumber.",".$hostnameT.",".$timestamp.",".$virtual_cpus.",".$logical_cpus.",".$smt_threads.",".$top[1];
my $i = 3;###########################################################################
while ($i <= $#top) {
$aecrire = $aecrire.','.$top[$i];
$i = $i + 1;
}
print (FIC2 $aecrire."\n");
}
My source file is FIC1 and destination file FIC2, the uniq key is $timestamp.
I want the script to check if $timestamp already exist in FIC1 (which is opened at begin of process), and if it does exclude the line from being writing to FIC2.
if $timestamp is not present, then write as normal.
Currently if a rerun the script over an already proceeded file, each line will be sorted by the timestamp and duplicated.
My goal is to be able to run this script periodically over a file without duplicating events.
I'm quite new to perl, as far as i've seen this should be achieve simply using the %seen variable within the while, but i could not yet achieve it successfully...
Thank you very much in advance for any help :-)
What you are describing is a hash.
You would define a hash in your code
my %seen = ();
Then when you read a line - before you decide to write it you could do something like:
#Check the hash to see if we have seen this line before we write it out
if ($seen{$aecrire} eq 1) {
#Do nothing - skip the line
} else {
$seen{$aecrire} = 1;
print (FIC2 $aecrire."\n");
}
I haven't checked this code but that is the jist.
I ended by adding the following code at the end of my process:
my (#final, %hash, $file) = ((), (), "");
foreach $file ($dstfile_CPU_ALL, $dstfile_MEM, $dstfile_VM, $dstfile_PROC, $dstfile_TOP ) {
if (!open FILE, "+<$file") {
print "Nothing to dedup, '$file' $!\n";
next;
}
while (<FILE>) {
if (not exists $hash{$_}) {
push #final, $_;
$hash{$_} = 1;
}
}
truncate FILE, 0;
seek FILE, 0, 0;
print FILE #final;
close FILE;
%hash = #final = ();
}

Is this code which is using Switch.pm safe?

In our company we were using this code (given at the end) for about 10 years and it worked fine.
Some days ago we faced some issues and we had to re-code the complete package, we decided to replace this code with Switch module by Damian (in order to improve the readability of code).
Everything is working fine for us.
Later I found on Perlmonks that Damian had put this module under
Damian modules you shouldn't use in production because their purpose
is to explore and prototype future core language features.
But it is working fine for us because we are not hitting the limitations of this module (I guess).
Now I ask you guys to please have a look at the both implementations (nested if else vs switch) and let me know whether using Switch in the newer implementation is fine or are we creating some future problems for us? Is using Switch in the code given below fine or are there any hidden bugs/problems?
I've already read the bugs and reviews of this module on CPAN and Perlmonks and I guess our code is far away from hitting those bugs (I think so).
We are using Perl 5.8.5.
PS: I know the alternatives of Switch, we have given/when in Perl 5.10, we can use dispatch table and other solutions which are specified here, but right now we just want to compare the new implementation which uses Switch.
Using nested if else
if ($command =~ /^enter$/) {
$self->show_main_frames();
}
elsif ($command =~ /^XYZ_MENU/i) {
$self->show_main_menu($manual, $dbot);
}
elsif ($command =~ /^DBOT/i) {
$dbot->process();
}
# XML is used for the reminders-history: Request 2666
elsif ($command =~ /^XML_DBOT/i) {
$dbot->process();
}
elsif ($command =~ /^UGS/i) {
$ugsui->process();
}
elsif ($command eq "kill") {
my $login = $self->{COMMON_HASH}{login} || "";
my $su_login = $self->{CONF}->get("start", "SU_LOGIN");
if ($login eq $su_login) {
# usually only certain user with certain permission will be
# able to do this.
$self->do_error("Daemon was killed by ".$login);
$self->db_connection->disconnect();
$self->{LOG}->write("User $login killed the daemon", 0);
exit; # this 'exit' actually kill the daemon
}
else {
$self->do_error("User $login tried to kill the daemon. ".
"This incident will be reported");
$self->{LOG}->write("User $login tried to kill the daemon", 2);
}
}
elsif ($command eq "logout") {
# check if we should delete the password cookie
my $forget_me = $self->{CGI}->param("forget_me") || 0;
if ($forget_me) {
$self->{DB_PASSWORD_COOKIE}->delete_cookie();
}
$ugsui->do_logout();
# Cliff edit remove id from logged_in
$session->remove_session($session->login());
# delete the session of the user
delete $self->{SESSIONS}{$session->id()};
if ($self->{CACHE_TO_FILE}) {
my $session_data_path =
XYZ_DIR
."/code/cache/session_data"
.$session->id();
unlink($session_data_path);
}
}
# if we just login we should create all the main frames
elsif ($command eq "login") {
# if extra_param holds "command*XXX" the XXX will be placed instead of
# the command. extra_param holds pairs that are astrics-separated
my $extra_param = $cgi->param("extra_param");
$extra_param = "" if (!defined($extra_param));
$extra_param =~ /command\*([^\*]+)/i;
my $other_command = defined($1) ? $1 : "";
if ($other_command =~ /^dbot/i) { # meanwhile - works only on dbot
# commands
$command = $other_command;
# now we will get the other parameters from the extra_param
# (actually including the command that is still in the
# $extra_param)
while ($extra_param =~ /^\*?([^\*]+)\*([^\*]+)(.*)/) {
$extra_param = $3;
my $name = $1;
my $value = $2;
$cgi->param(-name => $name,
-value => $value);
}#end while
}#end if
else{
$self->show_main_frames();
}
}#end elsif
else {
$self->show_main_frames();
}#end outer else
Using Switch
switch ($command)
{
case /^enter$/ { $self->show_main_frames() }
case /^XYZ_MENU/i { $self->show_main_menu($manual, $dbot) }
case /^DBOT/i { $dbot->process() }
case /^XML_DBOT/i { $dbot->process() }
case /^UGS/i { $ugsui->process() }
case "kill" {
my $login = $self->{COMMON_HASH}{login} || "";
my $su_login = $self->{CONF}->get("start", "SU_LOGIN");
if ($login eq $su_login) {
# usually only certain user with certain permission will be
# able to do this.
$self->do_error("Daemon was killed by ".$login);
$self->db_connection->disconnect();
$self->{LOG}->write("User $login killed the daemon", 0);
exit; # this 'exit' actually kill the daemon
}
else {
$self->do_error("User $login tried to kill the daemon. ".
"This incident will be reported");
$self->{LOG}->write("User $login tried to kill the daemon", 2);
}
}
case "logout" {
# check if we should delete the password cookie
my $forget_me = $self->{CGI}->param("forget_me") || 0;
if ($forget_me) {
$self->{DB_PASSWORD_COOKIE}->delete_cookie();
}
$ugsui->do_logout();
# Cliff edit remove id from logged_in
$session->remove_session($session->login());
# delete the session of the user
delete $self->{SESSIONS}{$session->id()};
if ($self->{CACHE_TO_FILE}) {
my $session_data_path =
XYZ_DIR
."/code/cache/session_data"
.$session->id();
unlink($session_data_path);
}
}
case "login" {
# if extra_param holds "command*XXX" the XXX will be placed instead of
# the command. extra_param holds pairs that are astrics-separated
my $extra_param = $cgi->param("extra_param");
$extra_param = "" if (!defined($extra_param));
$extra_param =~ /command\*([^\*]+)/i;
my $other_command = defined($1) ? $1 : "";
if ($other_command =~ /^dbot/i)
{ # meanwhile - works only on dbot
# commands
$command = $other_command;
# now we will get the other parameters from the extra_param
# (actually including the command that is still in the
# $extra_param)
while ($extra_param =~ /^\*?([^\*]+)\*([^\*]+)(.*)/) {
$extra_param = $3;
my $name = $1;
my $value = $2;
$cgi->param(-name => $name,
-value => $value);
}#end while
}#end if
else {$self->show_main_frames();}
}
else {$self->show_main_frames();}
} # end switch
Switch does its own parsing of the source code. This can lead to hard to diagnose errors in the code that directly uses it. The kind of problems Switch creates are not intermittent, so if your code works, you have nothing to worry about.
But really, it doesn't add much at all.
With Switch:
switch ($command) {
case /^enter$/ { $self->show_main_frames() }
case /^XYZ_MENU/i { $self->show_main_menu($manual, $dbot) }
case /^DBOT/i { $dbot->process() }
case /^XML_DBOT/i { $dbot->process() }
case /^UGS/i { $ugsui->process() }
case "kill" {
my $login = $self->{COMMON_HASH}{login} || "";
Without Switch:
for ($command) {
if (/^enter$/) { $self->show_main_frames() }
elsif (/^XYZ_MENU/i) { $self->show_main_menu($manual, $dbot) }
elsif (/^DBOT/i) { $dbot->process() }
elsif (/^XML_DBOT/i) { $dbot->process() }
elsif (/^UGS/i) { $ugsui->process() }
elsif ($_ eq "kill") {
my $login = $self->{COMMON_HASH}{login} || "";
(elsif (/^kill\z/) would also work.)
Actually Switch module does not provide you any "killer feature"; the same can be done with elsif statement which is secure, stable and does not have drawbacks that Switch does. Here is problems with Switch i got in my project (and i dont use it anymore):
Switch is made throgh Perl filters. This technique have following limits:
Your source code actually rewritten on-the-fly and replaces with
sequent elsif statements.
Some Perl error reports will refer wrong line; some of them showing code you dont have in your source (autogenerated code).
Not filter limit, but limit of module itself:
If the file(.pl or .pm) where you call use Swtich excess 1Mbyte size this can lead to "mysterious errors" (as written in doc). I can confirm these errors do not leading to Switch module and is completely unobivious, so you can have hard debug time after some weeks of coding/documentation.
I recommend to use elsif or given..when statements which is available since Perl 5.10. So if you using perl 5.8.x - use elsif.
Also you can read "Limitations" paragraph for Switch documentation.
Because Switch does own source code parsing, it does not work at all in certain circumstances. For example, it is impossible to use it with mod_perl.
However, if you have Perl 5.10 or later, there is much better replacement with effectively the same functionality: given/when
use v5.10;
given ($var) {
when (/^abc/) { $abc = 1 }
when (/^def/) { $def = 1 }
when (/^xyz/) { $xyz = 1 }
default { $nothing = 1 }
}
given is supported by Perl core (and works everywhere, including mod_perl) - you just use v5.10; and it is instantly available to you.