Introducing Lync 2010 Super Simple Auto Answer Video Kiosk with Full Screen
winforms - How to interact with an application programmatically - Stack Overflow
AutoIt - AutoItScript
Using Overloaded Win32 API functions to interact with other applications - vbCity - The .NET Developer Community
java - How to write a program that can interact with other programs - Stack Overflow
Quick introduction to Windows API
martes, 25 de marzo de 2014
miércoles, 12 de marzo de 2014
user-list.pl - programa en Perl para leer un formato determinado y crear una lista de usuarios
use strict;
use feature "switch";
open my $outfh, '>:encoding(utf8)', 'user-list.txt';
my %NOT_COLLECTED;
my @UNCLASSIFIED_FILE;
sub print_not_collected {
print $outfh "-----------------------------------------\n";
for (keys %NOT_COLLECTED) {
print $outfh $_ . ' ' . join(' ', keys %{+{map +($_ => undef), @{$NOT_COLLECTED{$_}}}}) . "\n";
}
print $outfh "-----------------------------------------\n";
print $outfh join "\n", @UNCLASSIFIED_FILE;
close($outfh);
exit(0);
}
use sigtrap 'handler' => \&print_not_collected, qw(INT QUIT);
my @tmp_PIV;
while(<user-pivot-*.txt>) {
my ($class) = /\d+/g;
open my $ph, "<:encoding(utf8)", $_;
push @tmp_PIV, \%{+{map {/(.*)/; $1=>$class} grep /.+/, <$ph>}};
}
my %DUP;
for my $i (0..$#tmp_PIV-1) {
for my $j ($i+1..$#tmp_PIV) {
for (keys %{$tmp_PIV[$i]}) {
$DUP{$_}{$tmp_PIV[$i]{$_}} = $tmp_PIV[$j]{$_} if exists $tmp_PIV[$j]{$_};
}
}
}
for my $name (keys %DUP) {
for my $i (keys %{$DUP{$name}}) {
print "$name $i ${DUP{$name}{$i}}\n";
}
}
die "Duplicated class entries." unless (keys %DUP)==0;
my %PIV_EQ_CLASS;
for (@tmp_PIV) {
%PIV_EQ_CLASS = (%PIV_EQ_CLASS, %{$_});
}
my %NOT_PIV;
open my $nph, "<:encoding(utf8)", "user-not-pivot.txt";
%NOT_PIV = %{+{map {/(.*)/; $1=>0} grep /.+/, <$nph>}};
$NOT_PIV{''} = 0; # we don't want to consider blank pivots
my @tmp = grep exists($NOT_PIV{$_}), keys %PIV_EQ_CLASS;
die 'Ambiguity pivot not pivot: ' . join "\n", @tmp unless @tmp==0;
local $/ = undef;
while(glob "HTML/**") {
print "$_\n";
open my $fh, "<:encoding(utf8)", $_;
my $fname = $_;
my $text = <$fh>;
$text =~ /<!-- Parsed text .*-->\n/g;
my @tmp = $text =~ /<!-- .* -->/g;
my $text2 = join '', map {; s/<!-- //; s/ -->//; $_; } @tmp;
$text2 =~ s/- ( *)(?=-)/-$1/g;
my @FILE_CLASS;
for ($text2 =~ /FriendlyName="(.*?)"/g) {
push @FILE_CLASS, $PIV_EQ_CLASS{$_} if exists $PIV_EQ_CLASS{$_};
push @{$NOT_COLLECTED{$_}}, $fname if not exists $PIV_EQ_CLASS{$_} and not exists $NOT_PIV{$_};
}
print $outfh $fname . ' ' . join(' ', keys %{+{map +($_ => undef), @FILE_CLASS}}) . "\n" unless @FILE_CLASS==0;
push @UNCLASSIFIED_FILE, $fname if @FILE_CLASS==0;
}
print_not_collected;
use feature "switch";
open my $outfh, '>:encoding(utf8)', 'user-list.txt';
my %NOT_COLLECTED;
my @UNCLASSIFIED_FILE;
sub print_not_collected {
print $outfh "-----------------------------------------\n";
for (keys %NOT_COLLECTED) {
print $outfh $_ . ' ' . join(' ', keys %{+{map +($_ => undef), @{$NOT_COLLECTED{$_}}}}) . "\n";
}
print $outfh "-----------------------------------------\n";
print $outfh join "\n", @UNCLASSIFIED_FILE;
close($outfh);
exit(0);
}
use sigtrap 'handler' => \&print_not_collected, qw(INT QUIT);
my @tmp_PIV;
while(<user-pivot-*.txt>) {
my ($class) = /\d+/g;
open my $ph, "<:encoding(utf8)", $_;
push @tmp_PIV, \%{+{map {/(.*)/; $1=>$class} grep /.+/, <$ph>}};
}
my %DUP;
for my $i (0..$#tmp_PIV-1) {
for my $j ($i+1..$#tmp_PIV) {
for (keys %{$tmp_PIV[$i]}) {
$DUP{$_}{$tmp_PIV[$i]{$_}} = $tmp_PIV[$j]{$_} if exists $tmp_PIV[$j]{$_};
}
}
}
for my $name (keys %DUP) {
for my $i (keys %{$DUP{$name}}) {
print "$name $i ${DUP{$name}{$i}}\n";
}
}
die "Duplicated class entries." unless (keys %DUP)==0;
my %PIV_EQ_CLASS;
for (@tmp_PIV) {
%PIV_EQ_CLASS = (%PIV_EQ_CLASS, %{$_});
}
my %NOT_PIV;
open my $nph, "<:encoding(utf8)", "user-not-pivot.txt";
%NOT_PIV = %{+{map {/(.*)/; $1=>0} grep /.+/, <$nph>}};
$NOT_PIV{''} = 0; # we don't want to consider blank pivots
my @tmp = grep exists($NOT_PIV{$_}), keys %PIV_EQ_CLASS;
die 'Ambiguity pivot not pivot: ' . join "\n", @tmp unless @tmp==0;
local $/ = undef;
while(glob "HTML/**") {
print "$_\n";
open my $fh, "<:encoding(utf8)", $_;
my $fname = $_;
my $text = <$fh>;
$text =~ /<!-- Parsed text .*-->\n/g;
my @tmp = $text =~ /<!-- .* -->/g;
my $text2 = join '', map {; s/<!-- //; s/ -->//; $_; } @tmp;
$text2 =~ s/- ( *)(?=-)/-$1/g;
my @FILE_CLASS;
for ($text2 =~ /FriendlyName="(.*?)"/g) {
push @FILE_CLASS, $PIV_EQ_CLASS{$_} if exists $PIV_EQ_CLASS{$_};
push @{$NOT_COLLECTED{$_}}, $fname if not exists $PIV_EQ_CLASS{$_} and not exists $NOT_PIV{$_};
}
print $outfh $fname . ' ' . join(' ', keys %{+{map +($_ => undef), @FILE_CLASS}}) . "\n" unless @FILE_CLASS==0;
push @UNCLASSIFIED_FILE, $fname if @FILE_CLASS==0;
}
print_not_collected;
lunes, 10 de marzo de 2014
DB2 - Consultas de metadatos - Consultas recursivas
DB2 – consulta de metadatos
Catalog
Schema: Doc original / standard name: syscat à DB2 alias: ibm
triggers
select text
from sysibm.sysTRIGGERS where tbname
secuencias
select *
from sysibm.syssequences where owner
stored
procedure / function
select *
from SYSIBM.sysroutines where owner
PK, unique
constraint, FK,
select *
from SYSIBM.syskeycoluse where constname
select *
from SYSIBM.SYSRELS where RELNAME
select *
from SYSIBM.SYSFOREIGNKEYS where relname
tables
FROM
SYSIBM.SYSTABLES
FROM
SYSIBM.SYSCOLUMNS where tbname and tbcreator
Dummy
sysibm.sysdummy1
Consultas recursivas en DB2 (jerarquía jerárquicas hierarchy hierarchial recursive)
/************************************************************************/
/************************************************************************/
/******************* COMPARE THE
FOLLOWING 2 QUERIES *******************/
/************************************************************************/
/************************************************************************/
-- TOP-DOWN
with MY_HIERARCHY (MY_NODE, MY_PARENTNODE) as (
-- non-recursive exit
select ROOT.MY_NODE, ROOT.MY_PARENTNODE
from THETABLE ROOT where MY_NODE='value' -- the root node in the tree
union all
-- recursive loop (it needs the
non-recursive part in order not to be an empty set)
select CHILD.MY_NODE, CHILD.MY_PARENTNODE
from MY_HIERARCHY PARENT, THETABLE CHILD
where CHILD.MY_PARENTNODE = PARENT.MY_NODE -- top-down join
)
select * from MY_HIERARCHY
-- BOTTOM-UP
with MY_HIERARCHY (MY_NODE, MY_PARENTNODE) as (
-- non-recursive exit
select LEAF.MY_NODE, LEAF.MY_PARENTNODE
from THETABLE LEAF where MY_NODE='value' -- the leaf node in the tree
union all
-- recursive loop (it needs the
non-recursive part in order not to be an empty set)
select CHILD.MY_NODE, CHILD.MY_PARENTNODE
from MY_HIERARCHY PARENT, THETABLE CHILD
where CHILD.MY_NODE = PARENT.MY_PARENTNODE -- bottom-up join
)
select * from MY_HIERARCHY
martes, 18 de febrero de 2014
Tokens V2
Tokens: Programme to discover tokens, where there are not.
Now available at https://puszcza.gnu.org.ua/projects/tokens/
This is Version 2, for version 1, go here.
Synopsis:
use TokensV2;
sub printFile;
my @FORMAT = (
['<Message Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From>(?:<User FriendlyName=".*?"/>)+</From><To>(?:<User FriendlyName=".*?"/>)+</To><Text(?: Style=".*?")?>.*?</Text></Message>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Message Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?">(<From>(?:<User FriendlyName=".*?"/>)+</From>)<To>(?:<User FriendlyName=".*?"/>)+</To><Text(?: Style="(.*?)")?>(.*?)</Text></Message>|;
my $F = join '<br />', $f =~ m|<User FriendlyName="(.*?)"/>|g;
print $fh "<p><font size=\"-2\">($d $t)</font> $F<br /><span style=\"$s\">$T</span></p>";
}
],
['<Invitation Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><File>.*?</File><Text(?: Style=".*?")?>.*?</Text></Invitation>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Invitation Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><File>.*?</File><Text(?: Style="(.*?)")?>(.*?)</Text></Invitation>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
],
['<InvitationResponse Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><File>.*?</File><Text(?: Style=".*?")?>.*?</Text></InvitationResponse>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<InvitationResponse Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><File>.*?</File><Text(?: Style="(.*?)")?>(.*?)</Text></InvitationResponse>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
],
['<Invitation Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><Application>.*?</Application><Text(?: Style=".*?")?>.*?</Text></Invitation>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Invitation Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><Application>.*?</Application><Text(?: Style="(.*?)")?>(.*?)</Text></Invitation>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
],
['<InvitationResponse Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><Application>.*?</Application><Text(?: Style=".*?")?>.*?</Text></InvitationResponse>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<InvitationResponse Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><Application>.*?</Application><Text(?: Style="(.*?)")?>(.*?)</Text></InvitationResponse>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
],
['<Join Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><User FriendlyName=".*?"/><Text(?: Style=".*?")?>.*?</Text></Join>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Join Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><User FriendlyName="(.*?)"/><Text(?: Style="(.*?)")?>(.*?)</Text></Join>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
],
['<Leave Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><User FriendlyName=".*?"/><Text(?: Style=".*?")?>.*?</Text></Leave>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Leave Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><User FriendlyName="(.*?)"/><Text(?: Style="(.*?)")?>(.*?)</Text></Leave>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
]
);
sub printFile {
return if @_==1;
if (@_==2) {
my $fh = $_[1];
${_[0]} =~ s/</</g;
print $fh "<p>${_[0]}</p>\n";
return;
}
# @_==5
printFile @{$_[1]}, $_[4];
my $coderef = $FORMAT[$_[3]][1];
&$coderef($_[0], $_[4]);
my $fh = $_[4];
print $fh "\n";
printFile @{$_[2]}, $_[4];
}
sub joinParseTree {
return if @_==0;
if (@_==1) {
return ${_[0]};
}
# @_==4
return joinParseTree(@{$_[1]}) . $_[0] . joinParseTree(@{$_[2]});
}
open my $fH, "<:encoding(utf8)", "tokens-processed.txt"; # H for HASH, not handle
my %HASH = map { /([^\s]*)/; $1 => undef } grep $_ ne "\n", <$fH>;
close $fH;
open $fH, ">>:encoding(utf8)", "tokens-processed.txt";
print $fH "----------bookmark----------\n";
local $/ = undef;
my $regex = join "\n", map $$_[0], @FORMAT;
while(glob "TXT/**") {
print "$_\n";
next if exists $HASH{$_};
open my $fh, "<:encoding(utf8)", $_;
my $text = <$fh>;
my $oName = $_;
$oName =~ s/TXT/HTML/;
$oName =~ s/\.txt/.html/;
my @parse_tree;
eval {
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
alarm 5;
@parse_tree = parse($text, $regex);
alarm 0;
};
if ($@) {
die unless $@ eq "alarm\n"; # propagate unexpected errors
# timed out
print $fH "$_ timed out\n";
next;
}
my $parse_text = joinParseTree @parse_tree;
open $fhHTML, ">:encoding(utf8)", $oName;
print $fhHTML <<ENDDOC
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html;charset=utf-8" />
</head>
<body>
ENDDOC
;
printFile @parse_tree, $fhHTML;
$text =~ s/-( *)(?=-)/- \1/g;
$text =~ s/(.{1,512})/<!-- \1 -->\n/g;
print $fhHTML "
<!-- Original text (cut on every 512 Char, -( *)(?=-) sequences escaped as - \\1):-->
$text";
$parse_text =~ s/-( *)(?=-)/- \1/g;
$parse_text =~ s/(.{1,512})/<!-- \1 -->\n/g;
print $fhHTML "
<!-- Parsed text (cut on every 512 Char, -( *)(?=-) sequences escaped as - \\1):-->
$parse_text
</body>
</html>";
close $fhHTML;
print $fH "$_\n";
}
TokensV2.pm file:
=pod
Tokens: Programme to discover tokens, where there are not.
Copyright 2013 Gabriel Czernikier
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see .
=cut
use strict;
#package declarations
sub digest_single;
sub parse_programme;
sub printAll;
my @REGEX;
my @MASK;
my $long_tokens;
my @DIGEST_SINGLE;
my $literal_char_count;
sub digest_single { # $target, $regex, $eaten_left_literal_chars, $eaten_right_literal_chars
#return unless $_[1] ne '';
#return if length $_[1] < 8; # x>(.*?)<
return unless ($_[2]+$_[3])/$literal_char_count<0.999999;
return @{$DIGEST_SINGLE[$_[2]][$_[3]]} if defined $DIGEST_SINGLE[$_[2]][$_[3]];
pos($_[0]) = undef;
goto VISITING unless $_[0] =~ /(${_[1]})/g;
my $digit = 2;
while( my $cg = eval '$'.$digit++ ) {
my @suspicious_tokens = $cg =~ /$long_tokens/g;
goto VISITING if @suspicious_tokens>=2;
}
my $pff = (pos $_[0]);
my $pii = $pff - (length $1) if defined $pff;
$DIGEST_SINGLE[$_[2]][$_[3]] = [$_[2], $_[3], $pii, $pff];
return @{$DIGEST_SINGLE[$_[2]][$_[3]]};
VISITING:
my $re = $_[1];
# strip off left shelter, also understood as walking righwards across the regex .+? stopping at a hopefuly serviceable string
goto VISITING_2 unless $re =~ s/(.+?)(.\(\.\*\?\).|\([^.])/\2/; # .+? is also the "shelter"
my $increment_eaten_literal_chars = $+[1];
$increment_eaten_literal_chars -= 5 if $1 =~ /\(\.\*\?\)/; # discount the single occurrence of non-literal chars: (.*?), left alone surrounding ""
# expansions
$re =~ s/^\(\?:(?:[^)]|\)[^?+*])+\)\*//;
$re =~ s/^\(\?:((?:[^)]|\)[^?+*])+)\)\+/\1\(\?:\1\)\*/;
$re =~ s/^\(\?:((?:[^)]|\)[^?+*])+)\)\?/\1/;
my ($el, $er, $pi, $pf) = digest_single $_[0], $re, $_[2]+$increment_eaten_literal_chars, $_[3];
VISITING_2:
$re = $_[1];
# strip off right shelter, also understood as walking leftwards across the regex .+? stopping at a hopefuly serviceable string
goto SUBDIGEST unless $re =~ s/(.*(?:.\(\.\*\?\).|\)[?+*]))(.+?)$/\1/; # .+? is the "shelter"
$increment_eaten_literal_chars = $+[2] - $-[2];
$increment_eaten_literal_chars -= 5 if $2 =~ /\(\.\*\?\)/; # discount the single occurrence of non-literal chars: (.*?), left alone surrounding ""
# expansions
$re =~ s/\(\?:(?:[^)]|\)[^?+*])+\)\*$//;
$re =~ s/\(\?:((?:[^)]|\)[^?+*])+)\)\+$/\(\?:\1\)\*\1/;
$re =~ s/\(\?:(?:[^)]|\)[^?+*])+\)\?$//;
my ($el2, $er2, $pi2, $pf2) = digest_single $_[0], $re, $_[2], $_[3]+$increment_eaten_literal_chars;
SUBDIGEST:
$DIGEST_SINGLE[$_[2]][$_[3]] = [$el, $er, $pi, $pf] if (defined $pi) && ($er+$el<=$er2+$el2 || !defined $pi2);
return @{$DIGEST_SINGLE[$_[2]][$_[3]]} if defined $DIGEST_SINGLE[$_[2]][$_[3]];
$DIGEST_SINGLE[$_[2]][$_[3]] = [$el2, $er2, $pi2, $pf2] if (defined $pi2) && ($er2+$el2<$er+$el || !defined $pi);
return @{$DIGEST_SINGLE[$_[2]][$_[3]]} if defined $DIGEST_SINGLE[$_[2]][$_[3]];
$DIGEST_SINGLE[$_[2]][$_[3]] = [];
return @{$DIGEST_SINGLE[$_[2]][$_[3]]};
}
sub digest_multiple {
my $regex_num = 0;
my $Pos_Ini;
my $Eaten_Left;
my $Eaten_Right;
my $Pos_Fin;
my $Regex_Num;
my @DIGEST_MULTIPLE = ();
for my $regex (@REGEX) {
@DIGEST_SINGLE = undef;
my @literal_chars = $regex =~ /[^.*(?:)+]/g;
$literal_char_count = scalar @literal_chars;
my ($eaten_left, $eaten_right, $pos_ini, $pos_fin) = digest_single $_[0], $regex, 0, 0;
return $eaten_left, $eaten_right, $pos_ini, $pos_fin, $regex_num if(($eaten_right+$eaten_left)/$literal_char_count<0.2);
push @DIGEST_MULTIPLE, [$eaten_left, $eaten_right, $pos_ini, $pos_fin, $regex_num] if defined $pos_ini && $pos_fin!=0;
$regex_num++;
}
$regex_num = 0;
while(@DIGEST_MULTIPLE!=0) {
my ($eaten_left, $eaten_right, $pos_ini, $pos_fin) = @{shift @DIGEST_MULTIPLE};
if($eaten_right+$eaten_left<$Eaten_Right+$Eaten_Left || !defined $Pos_Ini) {
$Pos_Ini = $pos_ini;
$Eaten_Left = $eaten_left;
$Eaten_Right = $eaten_right;
$Pos_Fin = $pos_fin;
$Regex_Num = $regex_num;
}
$regex_num++;
}
return $Eaten_Left, $Eaten_Right, $Pos_Ini, $Pos_Fin, $Regex_Num if defined $Pos_Ini;
}
sub parse_programme {
return if $_[0] eq '';
return $_[0] if length $_[0] < 8; # <x>y</x>
my ($eaten_left, $eaten_right, $pos_ini, $pos_fin, $regex_num) = digest_multiple($_[0]);
if(not defined $pos_ini) {
#my $oldfh = select;
#select STDERR;
#print "$ARGV[1], [ini-no-parseable]${target}[fin-no-parseable]\n";
#select $oldfh;
return $_[0];
}
my $mask_right = @MASK[$regex_num];
$mask_right =~ s/.*(.{$eaten_right})/\1/;
my $mask_left = @MASK[$regex_num];
$mask_left =~ s/(.{$eaten_left}).*/\1/;
my $match_length = $pos_fin-$pos_ini;
my ($target_left,$match,$target_right) = $_[0] =~ /(.{$pos_ini})(.{$match_length})(.*)/;
shift; # discard unused argument
return $mask_left.$match.$mask_right, +[parse_programme $target_left], +[parse_programme $target_right], $regex_num;
}
sub printAll {
return if @_==0;
if (@_==1) {
print "[ini-nonparse]${_[0]}[fin-nonparse]\n";
return;
}
printAll @{$_[1]};
print "[ini-prod]${_[0]}[fin-prod]\n";
printAll @{$_[2]};
}
sub parse {
@REGEX = ();
@MASK = ();
my $target = shift;
my $regex = shift;
while($regex =~ /^(.+)$/mg) {
my $_ = $1;
my $other = $_;
# strip out non-literal chars from MASK
$other =~ s/\(\?:(.+?)\)\+/\1/g;
$other =~ s/\(\?:(.+?)\)\?/\1/g;
$other =~ s/\.\*\?//g;
push @MASK, $other;
# surround wildcards with capturing group for REGEX
s/(\.\*\?)/\(\1\)/g;
push @REGEX, $_;
}
$long_tokens = '\b' . join '\b|\b', grep length>=3,keys %{+{ map +($_=>undef), map /\w+/g, @REGEX }};
$long_tokens = $long_tokens . '\b';
parse_programme $target;
}
1;
Now available at https://puszcza.gnu.org.ua/projects/tokens/
This is Version 2, for version 1, go here.
Synopsis:
use TokensV2;
sub printFile;
my @FORMAT = (
['<Message Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From>(?:<User FriendlyName=".*?"/>)+</From><To>(?:<User FriendlyName=".*?"/>)+</To><Text(?: Style=".*?")?>.*?</Text></Message>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Message Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?">(<From>(?:<User FriendlyName=".*?"/>)+</From>)<To>(?:<User FriendlyName=".*?"/>)+</To><Text(?: Style="(.*?)")?>(.*?)</Text></Message>|;
my $F = join '<br />', $f =~ m|<User FriendlyName="(.*?)"/>|g;
print $fh "<p><font size=\"-2\">($d $t)</font> $F<br /><span style=\"$s\">$T</span></p>";
}
],
['<Invitation Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><File>.*?</File><Text(?: Style=".*?")?>.*?</Text></Invitation>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Invitation Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><File>.*?</File><Text(?: Style="(.*?)")?>(.*?)</Text></Invitation>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
],
['<InvitationResponse Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><File>.*?</File><Text(?: Style=".*?")?>.*?</Text></InvitationResponse>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<InvitationResponse Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><File>.*?</File><Text(?: Style="(.*?)")?>(.*?)</Text></InvitationResponse>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
],
['<Invitation Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><Application>.*?</Application><Text(?: Style=".*?")?>.*?</Text></Invitation>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Invitation Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><Application>.*?</Application><Text(?: Style="(.*?)")?>(.*?)</Text></Invitation>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
],
['<InvitationResponse Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><Application>.*?</Application><Text(?: Style=".*?")?>.*?</Text></InvitationResponse>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<InvitationResponse Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><Application>.*?</Application><Text(?: Style="(.*?)")?>(.*?)</Text></InvitationResponse>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
],
['<Join Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><User FriendlyName=".*?"/><Text(?: Style=".*?")?>.*?</Text></Join>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Join Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><User FriendlyName="(.*?)"/><Text(?: Style="(.*?)")?>(.*?)</Text></Join>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
],
['<Leave Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><User FriendlyName=".*?"/><Text(?: Style=".*?")?>.*?</Text></Leave>',
sub {
my $fh = $_[1];
my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Leave Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><User FriendlyName="(.*?)"/><Text(?: Style="(.*?)")?>(.*?)</Text></Leave>|;
print $fh "<p><font size=\"-2\">($d $t)</font> $f<br /><span style=\"$s\">$T</span></p>";
}
]
);
sub printFile {
return if @_==1;
if (@_==2) {
my $fh = $_[1];
${_[0]} =~ s/</</g;
print $fh "<p>${_[0]}</p>\n";
return;
}
# @_==5
printFile @{$_[1]}, $_[4];
my $coderef = $FORMAT[$_[3]][1];
&$coderef($_[0], $_[4]);
my $fh = $_[4];
print $fh "\n";
printFile @{$_[2]}, $_[4];
}
sub joinParseTree {
return if @_==0;
if (@_==1) {
return ${_[0]};
}
# @_==4
return joinParseTree(@{$_[1]}) . $_[0] . joinParseTree(@{$_[2]});
}
open my $fH, "<:encoding(utf8)", "tokens-processed.txt"; # H for HASH, not handle
my %HASH = map { /([^\s]*)/; $1 => undef } grep $_ ne "\n", <$fH>;
close $fH;
open $fH, ">>:encoding(utf8)", "tokens-processed.txt";
print $fH "----------bookmark----------\n";
local $/ = undef;
my $regex = join "\n", map $$_[0], @FORMAT;
while(glob "TXT/**") {
print "$_\n";
next if exists $HASH{$_};
open my $fh, "<:encoding(utf8)", $_;
my $text = <$fh>;
my $oName = $_;
$oName =~ s/TXT/HTML/;
$oName =~ s/\.txt/.html/;
my @parse_tree;
eval {
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
alarm 5;
@parse_tree = parse($text, $regex);
alarm 0;
};
if ($@) {
die unless $@ eq "alarm\n"; # propagate unexpected errors
# timed out
print $fH "$_ timed out\n";
next;
}
my $parse_text = joinParseTree @parse_tree;
open $fhHTML, ">:encoding(utf8)", $oName;
print $fhHTML <<ENDDOC
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html;charset=utf-8" />
</head>
<body>
ENDDOC
;
printFile @parse_tree, $fhHTML;
$text =~ s/-( *)(?=-)/- \1/g;
$text =~ s/(.{1,512})/<!-- \1 -->\n/g;
print $fhHTML "
<!-- Original text (cut on every 512 Char, -( *)(?=-) sequences escaped as - \\1):-->
$text";
$parse_text =~ s/-( *)(?=-)/- \1/g;
$parse_text =~ s/(.{1,512})/<!-- \1 -->\n/g;
print $fhHTML "
<!-- Parsed text (cut on every 512 Char, -( *)(?=-) sequences escaped as - \\1):-->
$parse_text
</body>
</html>";
close $fhHTML;
print $fH "$_\n";
}
TokensV2.pm file:
=pod
Tokens: Programme to discover tokens, where there are not.
Copyright 2013 Gabriel Czernikier
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see .
=cut
use strict;
#package declarations
sub digest_single;
sub parse_programme;
sub printAll;
my @REGEX;
my @MASK;
my $long_tokens;
my @DIGEST_SINGLE;
my $literal_char_count;
sub digest_single { # $target, $regex, $eaten_left_literal_chars, $eaten_right_literal_chars
#return unless $_[1] ne '';
#return if length $_[1] < 8; # x>(.*?)<
return unless ($_[2]+$_[3])/$literal_char_count<0.999999;
return @{$DIGEST_SINGLE[$_[2]][$_[3]]} if defined $DIGEST_SINGLE[$_[2]][$_[3]];
pos($_[0]) = undef;
goto VISITING unless $_[0] =~ /(${_[1]})/g;
my $digit = 2;
while( my $cg = eval '$'.$digit++ ) {
my @suspicious_tokens = $cg =~ /$long_tokens/g;
goto VISITING if @suspicious_tokens>=2;
}
my $pff = (pos $_[0]);
my $pii = $pff - (length $1) if defined $pff;
$DIGEST_SINGLE[$_[2]][$_[3]] = [$_[2], $_[3], $pii, $pff];
return @{$DIGEST_SINGLE[$_[2]][$_[3]]};
VISITING:
my $re = $_[1];
# strip off left shelter, also understood as walking righwards across the regex .+? stopping at a hopefuly serviceable string
goto VISITING_2 unless $re =~ s/(.+?)(.\(\.\*\?\).|\([^.])/\2/; # .+? is also the "shelter"
my $increment_eaten_literal_chars = $+[1];
$increment_eaten_literal_chars -= 5 if $1 =~ /\(\.\*\?\)/; # discount the single occurrence of non-literal chars: (.*?), left alone surrounding ""
# expansions
$re =~ s/^\(\?:(?:[^)]|\)[^?+*])+\)\*//;
$re =~ s/^\(\?:((?:[^)]|\)[^?+*])+)\)\+/\1\(\?:\1\)\*/;
$re =~ s/^\(\?:((?:[^)]|\)[^?+*])+)\)\?/\1/;
my ($el, $er, $pi, $pf) = digest_single $_[0], $re, $_[2]+$increment_eaten_literal_chars, $_[3];
VISITING_2:
$re = $_[1];
# strip off right shelter, also understood as walking leftwards across the regex .+? stopping at a hopefuly serviceable string
goto SUBDIGEST unless $re =~ s/(.*(?:.\(\.\*\?\).|\)[?+*]))(.+?)$/\1/; # .+? is the "shelter"
$increment_eaten_literal_chars = $+[2] - $-[2];
$increment_eaten_literal_chars -= 5 if $2 =~ /\(\.\*\?\)/; # discount the single occurrence of non-literal chars: (.*?), left alone surrounding ""
# expansions
$re =~ s/\(\?:(?:[^)]|\)[^?+*])+\)\*$//;
$re =~ s/\(\?:((?:[^)]|\)[^?+*])+)\)\+$/\(\?:\1\)\*\1/;
$re =~ s/\(\?:(?:[^)]|\)[^?+*])+\)\?$//;
my ($el2, $er2, $pi2, $pf2) = digest_single $_[0], $re, $_[2], $_[3]+$increment_eaten_literal_chars;
SUBDIGEST:
$DIGEST_SINGLE[$_[2]][$_[3]] = [$el, $er, $pi, $pf] if (defined $pi) && ($er+$el<=$er2+$el2 || !defined $pi2);
return @{$DIGEST_SINGLE[$_[2]][$_[3]]} if defined $DIGEST_SINGLE[$_[2]][$_[3]];
$DIGEST_SINGLE[$_[2]][$_[3]] = [$el2, $er2, $pi2, $pf2] if (defined $pi2) && ($er2+$el2<$er+$el || !defined $pi);
return @{$DIGEST_SINGLE[$_[2]][$_[3]]} if defined $DIGEST_SINGLE[$_[2]][$_[3]];
$DIGEST_SINGLE[$_[2]][$_[3]] = [];
return @{$DIGEST_SINGLE[$_[2]][$_[3]]};
}
sub digest_multiple {
my $regex_num = 0;
my $Pos_Ini;
my $Eaten_Left;
my $Eaten_Right;
my $Pos_Fin;
my $Regex_Num;
my @DIGEST_MULTIPLE = ();
for my $regex (@REGEX) {
@DIGEST_SINGLE = undef;
my @literal_chars = $regex =~ /[^.*(?:)+]/g;
$literal_char_count = scalar @literal_chars;
my ($eaten_left, $eaten_right, $pos_ini, $pos_fin) = digest_single $_[0], $regex, 0, 0;
return $eaten_left, $eaten_right, $pos_ini, $pos_fin, $regex_num if(($eaten_right+$eaten_left)/$literal_char_count<0.2);
push @DIGEST_MULTIPLE, [$eaten_left, $eaten_right, $pos_ini, $pos_fin, $regex_num] if defined $pos_ini && $pos_fin!=0;
$regex_num++;
}
$regex_num = 0;
while(@DIGEST_MULTIPLE!=0) {
my ($eaten_left, $eaten_right, $pos_ini, $pos_fin) = @{shift @DIGEST_MULTIPLE};
if($eaten_right+$eaten_left<$Eaten_Right+$Eaten_Left || !defined $Pos_Ini) {
$Pos_Ini = $pos_ini;
$Eaten_Left = $eaten_left;
$Eaten_Right = $eaten_right;
$Pos_Fin = $pos_fin;
$Regex_Num = $regex_num;
}
$regex_num++;
}
return $Eaten_Left, $Eaten_Right, $Pos_Ini, $Pos_Fin, $Regex_Num if defined $Pos_Ini;
}
sub parse_programme {
return if $_[0] eq '';
return $_[0] if length $_[0] < 8; # <x>y</x>
my ($eaten_left, $eaten_right, $pos_ini, $pos_fin, $regex_num) = digest_multiple($_[0]);
if(not defined $pos_ini) {
#my $oldfh = select;
#select STDERR;
#print "$ARGV[1], [ini-no-parseable]${target}[fin-no-parseable]\n";
#select $oldfh;
return $_[0];
}
my $mask_right = @MASK[$regex_num];
$mask_right =~ s/.*(.{$eaten_right})/\1/;
my $mask_left = @MASK[$regex_num];
$mask_left =~ s/(.{$eaten_left}).*/\1/;
my $match_length = $pos_fin-$pos_ini;
my ($target_left,$match,$target_right) = $_[0] =~ /(.{$pos_ini})(.{$match_length})(.*)/;
shift; # discard unused argument
return $mask_left.$match.$mask_right, +[parse_programme $target_left], +[parse_programme $target_right], $regex_num;
}
sub printAll {
return if @_==0;
if (@_==1) {
print "[ini-nonparse]${_[0]}[fin-nonparse]\n";
return;
}
printAll @{$_[1]};
print "[ini-prod]${_[0]}[fin-prod]\n";
printAll @{$_[2]};
}
sub parse {
@REGEX = ();
@MASK = ();
my $target = shift;
my $regex = shift;
while($regex =~ /^(.+)$/mg) {
my $_ = $1;
my $other = $_;
# strip out non-literal chars from MASK
$other =~ s/\(\?:(.+?)\)\+/\1/g;
$other =~ s/\(\?:(.+?)\)\?/\1/g;
$other =~ s/\.\*\?//g;
push @MASK, $other;
# surround wildcards with capturing group for REGEX
s/(\.\*\?)/\(\1\)/g;
push @REGEX, $_;
}
$long_tokens = '\b' . join '\b|\b', grep length>=3,keys %{+{ map +($_=>undef), map /\w+/g, @REGEX }};
$long_tokens = $long_tokens . '\b';
parse_programme $target;
}
1;
martes, 11 de febrero de 2014
Subir archivos a un sistema z/OS a través de TSO
La subida de archivos a Mainframe a través del lenguaje de TSO (entendido en dicho lenguaje como 'IND$FILE PUT'), cuando el destino no es un 'dataset' sino un 'member', no acepta los mismos parámetros que la bajada ('IND$FILE GET').
En particular, no se aceptan las opciones: LRECL(n), BLKSIZE(n), RECFM(x), and SPACE(n,[n1]) unit (Referencia: http://www3.rocketsoftware.com/bluezone/help/v51/en/bz/DISPLAY/IND$FILE/IND$FILE_Technical_Reference.htm).
El panel de upload/download del emulador de Windows (por ejemplo Terminal 3270) genera esas opciones por defecto, para configurar qué opciones se incluyen en el string del comando TSO, hay un menú: Edición -> Preferencias -> Transferir.
Ahí, hay que crear un nuevo tipo de transferencia, y quitar las opciones Formato de registro y Longitud de registro, las cuales corresponden con las opciones TSO
LRECL(n), RECFM(x). Otras opciones también se pueden configurar desde acá, ver la referencia más citada arriba
Los tipos de transferencia son settings predeterminados de opciones, que se apendean a la línea de comando TSO cuando son seleccionados (por ejemplo: si dentro del panel de download selecciono tipo de transferencia='text', al generarse la línea de comando TSO se apendean las opciones ASCII CRLF RECFM LRECL) .
Cuando la subida de archivos es hacia un dataset, todas las opciones de línea de comando son aceptadas, pudiendo por ende utilizar algún tipo de transferencia instalado por default en el software de subida de archivos.
Para detectar si el destino del upload es un dataset o un mienbro dentro de un dataset particionado:
Dataset: tienen la forma 'IND$FILE PUT HOST$.LIBRERIA.DATASET', siempre separado por (.)
Member: tienen la forma 'IND$FILE PUT HOST$.LIBRERIA.DATASET(MIEMBRO)', con paréntesis al rededor del miembro.
En particular, no se aceptan las opciones: LRECL(n), BLKSIZE(n), RECFM(x), and SPACE(n,[n1]) unit (Referencia: http://www3.rocketsoftware.com/bluezone/help/v51/en/bz/DISPLAY/IND$FILE/IND$FILE_Technical_Reference.htm).
El panel de upload/download del emulador de Windows (por ejemplo Terminal 3270) genera esas opciones por defecto, para configurar qué opciones se incluyen en el string del comando TSO, hay un menú: Edición -> Preferencias -> Transferir.
Ahí, hay que crear un nuevo tipo de transferencia, y quitar las opciones Formato de registro y Longitud de registro, las cuales corresponden con las opciones TSO
LRECL(n), RECFM(x). Otras opciones también se pueden configurar desde acá, ver la referencia más citada arriba
Los tipos de transferencia son settings predeterminados de opciones, que se apendean a la línea de comando TSO cuando son seleccionados (por ejemplo: si dentro del panel de download selecciono tipo de transferencia='text', al generarse la línea de comando TSO se apendean las opciones ASCII CRLF RECFM LRECL) .
Cuando la subida de archivos es hacia un dataset, todas las opciones de línea de comando son aceptadas, pudiendo por ende utilizar algún tipo de transferencia instalado por default en el software de subida de archivos.
Para detectar si el destino del upload es un dataset o un mienbro dentro de un dataset particionado:
Dataset: tienen la forma 'IND$FILE PUT HOST$.LIBRERIA.DATASET', siempre separado por (.)
Member: tienen la forma 'IND$FILE PUT HOST$.LIBRERIA.DATASET(MIEMBRO)', con paréntesis al rededor del miembro.
sábado, 25 de enero de 2014
extract-txt-bin-portions.pl: programa el Perl para encontrar cadenas UTF-8 en archivos binarios sin formato
# Lee un archivo mixto UTF-8 - no UTF-8
# output:
# Repeticiones de las líneas de texto:
# "bin: " byte-inicial-secuencia-no-UTF-8 byte-final-secuencia-no-UTF-8
# "txt: " byte-inicial-secuencia-UTF-8 byte-final-secuencia-UTF-8
# por orden de aparición de las secuencias (orden normal de los bytes dentro del archivo)
open my $fh, "<:raw", @ARGV[0] or die "cannot open < @ARGV[0]: $!";
my $i = 0;
my $ini_ciclo_bin = 1;
my $length = read $fh, my $byte, 1;
$i += $length;
# print "a ".unpack("B*", $byte) . "\n";
my $ini_bin;
my $fin_bin;
my $ini_txt;
my $fin_txt;
while($length) {
# ciclo bin
while($length and not unpack("B*", $byte) =~ /^(0|110|1110|11110|111110|1111110).*/) {
$length = read $fh, $byte, 1;
$i += $length;
# print "b ".unpack("B*", $byte) . "\n";
}
# ciclo txt
# inicialización secuencia txt
$ini_txt = $i;
$fin_txt = 0; # no def
my $s_val = 1; # boolean TRUE, secuencia txt válida (secuencia de caracteres)
while($length and unpack("B*", $byte) =~ /^(0|110|1110|11110|111110|1111110).*/ and $s_val) {
# inicialización 1 caracter
my $l = index(unpack("B*", $byte),'0');
if($l eq 0) {
$l = 1;
}
my $ini_sec_bytes = $i;
# lectura 1 caracter
while($length and $i-$ini_sec_bytes+1 lt $l and $s_val) {
$length = read $fh, $byte, 1;
$i += $length;
# print "c ".unpack("B*", $byte) . "\n";
if(not unpack("B*", $byte) =~ /^10.*/) {
$s_val = 0; # boolean FALSE
}
}
if($s_val and $i-$ini_sec_bytes+1 eq $l) {
$fin_txt = $i; # def
$length = read $fh, $byte, 1;
$i += $length;
# print "d ".unpack("B*", $byte) . "\n";
}
}
# delimitar secuencias
if($fin_txt) { # secuencia txt no vacía
if($ini_txt ne $ini_ciclo_bin) { # secuencia binaria no vacía
$ini_bin = $ini_ciclo_bin;
$fin_bin = $ini_txt - 1;
print "bin: $ini_bin $fin_bin\n";
}
print "txt: $ini_txt $fin_txt\n";
$ini_ciclo_bin = $fin_txt + 1; # para la vuelta entrante
} # si no las condiciones continúan igual para reentrar el ciclo-bin
}
# delimitación final
if($i) { # archivo no vacío
if($fin_txt and $fin_txt ne $i) { # secuencia txt no vacía ($fin_txt) and quedaron ($i-$fin_txt) bytes bin al final del archivo
$ini_bin = $fin_txt + 1;
$fin_bin = $i;
print "bin: $ini_bin $fin_bin\n";
}
elsif($fin_txt eq 0) { # último ciclo txt vacío ==> todo el ciclo corresponde a datos bin
$ini_bin = $ini_ciclo_bin;
$fin_bin = $i;
print "bin: $ini_bin $fin_bin\n";
}
# si no si ($fin_txt eq $i) el archivo termina justo en una secuencia txt, último OUTPUT emitido en ciclo txt
}
close $fh;
# output:
# Repeticiones de las líneas de texto:
# "bin: " byte-inicial-secuencia-no-UTF-8 byte-final-secuencia-no-UTF-8
# "txt: " byte-inicial-secuencia-UTF-8 byte-final-secuencia-UTF-8
# por orden de aparición de las secuencias (orden normal de los bytes dentro del archivo)
open my $fh, "<:raw", @ARGV[0] or die "cannot open < @ARGV[0]: $!";
my $i = 0;
my $ini_ciclo_bin = 1;
my $length = read $fh, my $byte, 1;
$i += $length;
# print "a ".unpack("B*", $byte) . "\n";
my $ini_bin;
my $fin_bin;
my $ini_txt;
my $fin_txt;
while($length) {
# ciclo bin
while($length and not unpack("B*", $byte) =~ /^(0|110|1110|11110|111110|1111110).*/) {
$length = read $fh, $byte, 1;
$i += $length;
# print "b ".unpack("B*", $byte) . "\n";
}
# ciclo txt
# inicialización secuencia txt
$ini_txt = $i;
$fin_txt = 0; # no def
my $s_val = 1; # boolean TRUE, secuencia txt válida (secuencia de caracteres)
while($length and unpack("B*", $byte) =~ /^(0|110|1110|11110|111110|1111110).*/ and $s_val) {
# inicialización 1 caracter
my $l = index(unpack("B*", $byte),'0');
if($l eq 0) {
$l = 1;
}
my $ini_sec_bytes = $i;
# lectura 1 caracter
while($length and $i-$ini_sec_bytes+1 lt $l and $s_val) {
$length = read $fh, $byte, 1;
$i += $length;
# print "c ".unpack("B*", $byte) . "\n";
if(not unpack("B*", $byte) =~ /^10.*/) {
$s_val = 0; # boolean FALSE
}
}
if($s_val and $i-$ini_sec_bytes+1 eq $l) {
$fin_txt = $i; # def
$length = read $fh, $byte, 1;
$i += $length;
# print "d ".unpack("B*", $byte) . "\n";
}
}
# delimitar secuencias
if($fin_txt) { # secuencia txt no vacía
if($ini_txt ne $ini_ciclo_bin) { # secuencia binaria no vacía
$ini_bin = $ini_ciclo_bin;
$fin_bin = $ini_txt - 1;
print "bin: $ini_bin $fin_bin\n";
}
print "txt: $ini_txt $fin_txt\n";
$ini_ciclo_bin = $fin_txt + 1; # para la vuelta entrante
} # si no las condiciones continúan igual para reentrar el ciclo-bin
}
# delimitación final
if($i) { # archivo no vacío
if($fin_txt and $fin_txt ne $i) { # secuencia txt no vacía ($fin_txt) and quedaron ($i-$fin_txt) bytes bin al final del archivo
$ini_bin = $fin_txt + 1;
$fin_bin = $i;
print "bin: $ini_bin $fin_bin\n";
}
elsif($fin_txt eq 0) { # último ciclo txt vacío ==> todo el ciclo corresponde a datos bin
$ini_bin = $ini_ciclo_bin;
$fin_bin = $i;
print "bin: $ini_bin $fin_bin\n";
}
# si no si ($fin_txt eq $i) el archivo termina justo en una secuencia txt, último OUTPUT emitido en ciclo txt
}
close $fh;
jueves, 9 de enero de 2014
Notas sobre dd
Interpretación de la pág. man dd:
Extracto: "Si la opción bs=bytes se dio, y no se especificó una conversión aparte de sync, noerror, o notrunc, escribe la cantidad de datos leídos (que podría ser menor de la pedida) en un bloque de salida separado."
Interpretación de "escribe la cantidad de datos leídos": significa que bs=x ==es equiv. a== ibs=x y obs=x, en las circunstancias descriptas.
Interpretación de "bloque de salida separado": Así como "sed" tiene un "pattern space" y "otro buffer auxiliar" en donde se escribe el input y se puede manipular antes de que salga el output, algo similar es la forma de trabajo de "dd" con su "bloque de salida" ("separado" = nuevo / a parte de cualquier bloque de salida existente).
Interpretación de la pág. man dd:
Extracto: "...poner bs no es equivalente a poner ibs y obs a su mismo valor, al menos si no se ha especificado una conversión aparte de sync, noerror y notrunc"
Corrección: "...poner bs *SÍ* es equivalente a poner ibs y obs a su mismo valor, al menos si no se ha especificado una conversión aparte de sync, noerror y notrunc"
Representación en lenguaje de conjuntos:
{conversiones suministradas como parám. "conv"} - {conversión: conversión E {sync, noerror, notrunc}}={} => bs=x == ibs=x y obs=x
Interpretación:
Si el usuario no suministra parám conv o suministra conv=Partes del conj. {sync,noerror,notrunc}, entonces => suministrar bs=x *SÍ* equivale funcionalmente a ibs=x y obs=x.
Extracto: "Si la opción bs=bytes se dio, y no se especificó una conversión aparte de sync, noerror, o notrunc, escribe la cantidad de datos leídos (que podría ser menor de la pedida) en un bloque de salida separado."
Interpretación de "escribe la cantidad de datos leídos": significa que bs=x ==es equiv. a== ibs=x y obs=x, en las circunstancias descriptas.
Interpretación de "bloque de salida separado": Así como "sed" tiene un "pattern space" y "otro buffer auxiliar" en donde se escribe el input y se puede manipular antes de que salga el output, algo similar es la forma de trabajo de "dd" con su "bloque de salida" ("separado" = nuevo / a parte de cualquier bloque de salida existente).
Interpretación de la pág. man dd:
Extracto: "...poner bs no es equivalente a poner ibs y obs a su mismo valor, al menos si no se ha especificado una conversión aparte de sync, noerror y notrunc"
Corrección: "...poner bs *SÍ* es equivalente a poner ibs y obs a su mismo valor, al menos si no se ha especificado una conversión aparte de sync, noerror y notrunc"
Representación en lenguaje de conjuntos:
{conversiones suministradas como parám. "conv"} - {conversión: conversión E {sync, noerror, notrunc}}={} => bs=x == ibs=x y obs=x
Interpretación:
Si el usuario no suministra parám conv o suministra conv=Partes del conj. {sync,noerror,notrunc}, entonces => suministrar bs=x *SÍ* equivale funcionalmente a ibs=x y obs=x.
Suscribirse a:
Entradas (Atom)