[26709] in Perl-Users-Digest
Perl-Users Digest, Issue: 8808 Volume: 10
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Thu Dec 29 03:05:27 2005
Date: Thu, 29 Dec 2005 00:05:04 -0800 (PST)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Thu, 29 Dec 2005 Volume: 10 Number: 8808
Today's topics:
Addressing the cursor of a VT100 style terminal emulato <""\"Remove the letters in all caps\" <jeff\"@STOPSPAMNOW.commercialventvac .com>
Re: Addressing the cursor of a VT100 style terminal emu <samwyse@gmail.com>
Re: My Regexp XML Parser -> Structured Perl Data, Cut robic0
Re: My Regexp XML Parser -> Structured Perl Data, Cut robic0
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Wed, 28 Dec 2005 22:06:19 -0800
From: Jeff Silverman <""\"Remove the letters in all caps\" <jeff\"@STOPSPAMNOW.commercialventvac .com>
Subject: Addressing the cursor of a VT100 style terminal emulator using perl
Message-Id: <43b37ce0$0$1764$8b463f8a@news.nationwide.net>
I am working on a perl program which uses VT100 style escape codes and
runs in gnome-terminal or konsole or rxterm or xterm or similar.
I want to know if there is a way to sent an escape sequence to the
terminal emulator which queries for the current size of the screen and
gets a report back. I am assuming that the user can resize the
terminal. I plan to query the terminal size at the end of each pass.
If the user resizes the terminal in the middle of pass - well - he's
going to be confused.
Does anybody know how to do this? I have looked at Term::Cap but I
don't see where that queries the current terminal size. Ditto for
Term::ANSIColor.
Many thanks,
Jeff Silverman
------------------------------
Date: Thu, 29 Dec 2005 07:33:27 GMT
From: Samwyse <samwyse@gmail.com>
Subject: Re: Addressing the cursor of a VT100 style terminal emulator using perl
Message-Id: <bjMsf.39999$BZ5.23397@newssvr13.news.prodigy.com>
Jeff Silverman <"Remove the letters in all caps" wrote:
> I am working on a perl program which uses VT100 style escape codes and
> runs in gnome-terminal or konsole or rxterm or xterm or similar.
>
> I want to know if there is a way to sent an escape sequence to the
> terminal emulator which queries for the current size of the screen and
> gets a report back. I am assuming that the user can resize the
> terminal. I plan to query the terminal size at the end of each pass.
> If the user resizes the terminal in the middle of pass - well - he's
> going to be confused.
>
> Does anybody know how to do this? I have looked at Term::Cap but I
> don't see where that queries the current terminal size. Ditto for
> Term::ANSIColor.
Actually, when a terminal is resized, your app gets a SIGWINCH signal.
You should then issue an ioctl to get the new size:
struct winsize size;
ioctl(fileno(stdout), TIOCGWINSZ, &size);
This way, you don't have to query the terminal and worry about the user
hitting a key at the wrong time. The ncurses library handles all of
this for you, I suppose that Term::Cap does as well. The next time you
call 'getch()', the library will return KEY_RESIZE to let you know what
happened. Typically, you repaint the entire screen at that point.
Googling the terms in all caps should tell you more.
------------------------------
Date: Wed, 28 Dec 2005 21:42:09 -0800
From: robic0
Subject: Re: My Regexp XML Parser -> Structured Perl Data, Cut & Paste Version, No Module's (Vol I)
Message-Id: <brs6r1lo341r3030smvs8nmoepgtmsnt2u@4ax.com>
On Tue, 20 Dec 2005 23:59:06 -0800, robic0 wrote:
Update on the code. Lots of changes:
v.902
- Fixed white space issues surrounding attributes
- Fixed \"\' issue delimiting attribute content
- Fixed root container issues
- Fixed CDATA in comments
- Fixed comments in CDATA
- Added more warnings related to root level
Will be working on the usage regarding the
remove white spaces flag. Ie: to be applied
to content only or not.
To be done -
Still havent incorporated ":" logic in attributes.
Still no special xml character conversions (easy though)
Will incorporate simple callbacks for content.
No doctype or others as of yet, will look into this.
Will make the parsing a function with error trapping
capability for the caller (down the road).
The framework is working out pretty good.
Let me know if you have any questions or comments.
Thanks
print <<EOM;
# -----------------------
# XML Regex Parser
# Version .902 - 12/28/05
# Copyright 2005,
# by robic0-At-yahoo.com
# -----------------------
EOM
use strict;
use warnings;
use Data::Dumper;
#open DATA, "sumfile.xml" or die "can't open datafile...";
#my $gabage1 = join ('', <DATA>);
#close DATA;
my $gabage4 = '
<big name="asdf" date="33" >
asdf
<in1>
<!-- howdy f*%$olks -->
<in2>jjjj</in2>
<small biz="wefwf" ueue = "second" />
<!-- and still more -->
<bar><inside>asgfasdf<insF>2</insF>sdfb</inside></bar>
</in1>
<in2>some in3 content</in2>
asdfb
</big>
';
my $gabage5 = '
<root>
<!--
wasdfvgasvbg <![CDATA[ not really a CDATA ]]>
<tag>at tag in a real comment</tag>
<![CDATA[ not a CDATA ]]>
-->
<!-- This is a real comment -->
this is some content
<stag><br>some br stuff</br>after<t>some t
</t>
</stag>
<![CDATA[ <!-- imbed comment --> some text <!-- imbed as well -->]]>
<![CDATA[ <!-- imbed comment --> some text <!-- imbed as well -->]]>
</root>
';
my $gabage6 = "
<!-- This is a real comment -->
<node1
name = 'Barney'
date = \"1/1/05\"
/>
";
my $gabage7 = "
<node1
tire = 'Michelan'
size = \"235 x 16\">
Recalled by factory</node1>
";
my $gabage8 = "
<node1
color = 'green'
vtype = \"truck'
/>
";
my $gabage9 = '
<node>this is a node</node>
<node>this is a different</node>
';
my $gabage10 = '
<Node>this is a node</node>
<node>this is a different</Node>
';
my @xml_strings = ($gabage4, $gabage5, $gabage6, $gabage7, $gabage9,
$gabage10);
my $VERSION = .902;
my $debug = 0;
my $rmv_white_space = 0;
my $ForceArray = 0;
my $KeepRoot = 0;
my $KeepComments = 0;
## -- XML, start & end regexp substitution delimiter chars --
## match side , substitution side
## -------------------------/-------------------------------
my (@S_dlim, @E_dlim);
if ($debug) {
@S_dlim = ('\[' , '['); # use these for debug
@E_dlim = ('\]' , ']');
} else {
@S_dlim = (chr(140) , chr(140)); # use these for production
@E_dlim = (chr(141) , chr(141));
}
## -- Process xml data --
##
for (@xml_strings)
{
print "\n",'*'x30,"\nXML
string:\n",'-'x15,"$_\n\nOutput:\n",'-'x15,"\n\n";
my $ROOT = {}; # container
my %cdata_elements = ();
my ($last_cnt, $cnt, $i, $attr_error) = (-1, 1, 0, 0);
## Comment/CDATA block ==================================
#### To be done first -
# -- Questionable Comments --
while (s/(<!--(.*?)-->)/$S_dlim[1]$cnt$E_dlim[1]/s) {
#print "$cnt = Questionable comment: $1\n" if
($debug);
$ROOT->{$cnt} = $1;
$cnt++;
}
#### To be done second -
# -- Real CDATA --
while (s/<!\[CDATA\[(.*?)\]\]>/$S_dlim[1]$cnt$E_dlim[1]/s)
{
# reconstitute cdata contents
my $cdata_contents = $1;
my $str = '';
while ($cdata_contents =~
s/([^$S_dlim[0]$E_dlim[0]]+)|$S_dlim[0]([\d]+)$E_dlim[0]//) {
if (defined $1) {
$str .= $1;
} elsif (defined $2 && exists $ROOT->{$2}) {
$str .= $ROOT->{$2};
delete $ROOT->{$2};
} else {} # shouldn't get here
}
print "$cnt CDATA = $str\n" if ($debug);
$ROOT->{$cnt} = $str;
$cdata_elements{$cnt} = '';
$cnt++;
}
#### To be done third -
# -- Real Comments are left --
foreach my $key (sort {$a <=> $b} keys %{$ROOT}) {
if (!exists $cdata_elements{$key}) {
$ROOT->{$key} =~ s/^<!--(.*?)-->$/$1/s;
print "$key Comment = $1\n" if ($debug);
if ($KeepComments) {
$ROOT->{$key} = { comment => $1 };
} else {delete $ROOT->{$key};}
}
}
## End Comment/CDATA block ==============================
#### Non-tag markup go here -
# -- Versioning -- <?XML-Version ?> , have to check the format
of '<?'
while (s/<\?([^<>]*)\?>//) {} # void xml versioning for now
# while (s/<\?([^<>]*)\?>/$S_dlim[1]$cnt$E_dlim[1]/)
# { print "$cnt <$1> = \n" if ($debug); $cnt++}
#### White space removal before tags ? .. TBD -
if ($rmv_white_space) {
s/>[\s]+</></g;
s/[\s]+</</g;
s/>[\s]+/>/g;
}
#### Tags here - should only need 2 iterations max
my $finished = 0;
while ($cnt != $last_cnt && $i < 20)
{
$last_cnt = $cnt;
## <Tag/> , no content
while (s/<([0-9a-zA-Z]+)\/>/$S_dlim[1]$cnt$E_dlim[1]/)
{
print "$cnt <$1> = \n" if ($debug);
$ROOT->{$cnt} = { $1 => '' };
$cnt++;
}
## <Tag Attributes/> , no content
while
(s/<([0-9a-zA-Z]+)([\s]+[0-9a-zA-Z]+[\s]*=[\s]*["'][^<]*['"])+[\s]*\/>/$S_dlim[1]$cnt$E_dlim[1]/)
{
print "$cnt <$1> = attr: $2\n" if ($debug);
my $hattrib = getAttrHash($2);
if (ref($hattrib) ne "HASH") {
print "Invalid token in attribute
asignment:\n$hattrib\n"; $attr_error = 1; last;
}
$ROOT->{$cnt} = { $1 => $hattrib };
$cnt++;
}
## <Tag> Content </Tag>
while
(s/<([0-9a-zA-Z]+)>([^<]*)<\/\1>/$S_dlim[1]$cnt$E_dlim[1]/) {
print "$cnt <$1> = $2\n" if ($debug);
my $unknown = '';
if (length($2) > 0) {
my $hcontent = getContentHash($2,
$ROOT, \%cdata_elements);
$unknown = $hcontent;
if (keys (%{$hcontent}) > 1) {
if (!$ForceArray) {
adjustForSingleItemArrays ($hcontent); }
} else {
if (exists
$hcontent->{'content'} && scalar(@{$hcontent->{'content'}}) == 1) {
if (!$ForceArray ) {
$unknown =
${$hcontent->{'content'}}[0];
} else {$unknown =
$hcontent->{'content'}; }
}
if (!$ForceArray) {
adjustForSingleItemArrays ($hcontent); }
}
}
$ROOT->{$cnt} = { $1 => $unknown };
$cnt++;
}
last if ($attr_error);
## <Tag Attributes> Content </Tag>
while
(s/<([0-9a-zA-Z]+)([\s]+[0-9a-zA-Z]+[\s]*=[\s]*["'][^<]*['"])+[\s]*>([^<]*)<\/\1>/$S_dlim[1]$cnt$E_dlim[1]/)
{
print "$cnt <$1> = attr: $2, content: $3\n" if
($debug);
my $hattrib = getAttrHash($2);
if (ref($hattrib) ne "HASH") {
print "Invalid token in attribute
asignment:\n$hattrib\n"; $attr_error = 1; last;
}
if (length($3) > 0) {
my $hcontent = getContentHash($3,
$ROOT, \%cdata_elements);
if (!$ForceArray) {
adjustForSingleItemArrays ($hcontent); }
while (my ($key,$val) = each
(%{$hcontent})) {
$hattrib->{$key} = $val;
}
}
$ROOT->{$cnt} = { $1 => $hattrib };
$cnt++;
}
last if ($attr_error);
if ($last_cnt != $cnt) {
$i++; print "** End pass $i\n" if ($debug);
} else {
last if ($finished);
## Encapsulate the xml with a "root"
$_ = "<root>$_</root>";
$last_cnt--;
$finished = 1;
}
}
last if ($attr_error);
if (/<|>/) {
print "($i) XML problem: malformed, syntax or tag
closure:\n$_";
} else {
print "\n** Itterations = $i\n** ForceArray =
$ForceArray\n** KeepRoot = $KeepRoot\n** KeepComments =
$KeepComments\n\n";
#print Dumper($ROOT);
print "The remaining string is:\n$_\n\n" if ($debug);
## Strip off the outer element (our root) to
## examine the contents for errors.
## ---------------------------------------
my $outer_element = $cnt-1;
if (exists $ROOT->{$outer_element}) {
my $hroot = $ROOT->{$outer_element};
my ($key,$val) = each (%{$hroot});
my $htodump = $val;
# check for errors in root
if (ref($htodump) ne "HASH" || exists
$htodump->{'content'}) {
print "Error, bare content at root
level ..\n";
} else {
my $dmp_keys = keys (%{$htodump});
if ($dmp_keys > 1) {
print "Warning, multiple
elements at root level ..\n";
} else {
($key,$val) = each
(%{$htodump});
my $dmp_type = ref($val);
if ($dmp_keys == 0 || (exists
$htodump->{'comment'})) {
print "Warning, no
elements at root level ..\n";
}
if ($dmp_keys == 1) {
if ($dmp_type eq
"HASH") {
$htodump =
$val if (!$KeepRoot);
}
elsif ($dmp_type eq
"ARRAY") {
if
(!$ForceArray || scalar(@{$val}) > 1) {
print
"Warning, multiple elements at root level ..\n";
}
}
}
}
}
print "\n";
my $tmp = {};
%{$tmp} = %{$htodump};
print Dumper($tmp);
} else {
print "nothing to output!\n";
}
}
}
##
sub adjustForSingleItemArrays
{
my $href = shift;
## if $val is an array ref and has one element
## set $href->{$key} equal to the element
while (my ($key,$val) = each (%{$href})) {
if (ref($val) eq "ARRAY") {
if (scalar(@{$val}) == 1) {
$href->{$key} = $val->[0];
}
}
}
}
##
sub getAttrHash
{
my $attrstr = shift;
my $ahref = {};
return $ahref unless (defined $attrstr);
while ($attrstr =~
s/[\s]*([0-9a-zA-Z]+)[\s]*=[\s]*("|')([^=]*)\2[\s]*//i) {
$ahref->{$1} = $3;
}
if ($attrstr=~/=/) {
$attrstr =~ s/^\s+//s;
$attrstr =~ s/\s+$//s;
return $attrstr
}
return $ahref;
}
##
sub getContentHash
{
my ($contstr,$hStore,$hcdata_elements) = @_;
my $ahref = {};
return $ahref unless (defined $contstr && defined $hStore &&
defined $hcdata_elements);
my @ary = ();
my $append_flag = 0;
while ($contstr =~
s/^([^<$S_dlim[0]$E_dlim[0]]+)|$S_dlim[0]([\d]+)$E_dlim[0]//s) {
if (defined $1) {
my $tmp1 = $1;
# if flagged, append it to $ary[last]
if ($append_flag && scalar(@ary) > 0) {
my $size = scalar(@ary);
$ary[$size-1] .= $tmp1;
} else {
push (@ary, $1);
}
$append_flag = 0;
}
elsif (defined $2) {
# if it doesen't exist (Comments stripped?)
# turn on append flag.
if (!exists $hStore->{$2}) {
$append_flag = 1;
next;
}
# if its a CDATA, append it to $ary[last],
# turn on append flag.
if (exists $hcdata_elements->{$2}) {
my $size = scalar(@ary);
if ($size > 0) {
$ary[$size-1] .=
$hStore->{$2};
} else {push (@ary, $hStore->{$2});}
$append_flag = 1;
next;
}
my ($key,$val) = each (%{$hStore->{$2}});
if (exists $ahref->{$key}) {
push (@{$ahref->{$key}}, $val);
} else {
$ahref->{$key} = [$val];
}
$append_flag = 0;
}
else {} # shouldn't get here
}
# store contents, strip out
# pure whitespace text elements
my $hary = [];
for (@ary) {
next if (/^\s+$/s);
push (@{$hary}, $_);
}
if (scalar(@{$hary}) > 0) {
$ahref->{'content'} = $hary;
}
## if $val is an array ref and has one element and it
## is a hash ref, set {$key} equal to hash ref
if (!$ForceArray) {
while (my ($key,$val) = each (%{$ahref})) {
if (ref($val) eq "ARRAY") {
if (scalar(@{$val}) == 1 &&
ref($val->[0]) eq "HASH") {
$ahref->{$key} = $val->[0];
}
}
}
}
return $ahref;
}
__END__
# -----------------------
# XML Regex Parser
# Version .902 - 12/28/05
# Copyright 2005,
# by robic0-At-yahoo.com
# -----------------------
******************************
XML string:
---------------
<big name="asdf" date="33" >
asdf
<in1>
<!-- howdy f*%$olks -->
<in2>jjjj</in2>
<small biz="wefwf" ueue = "second" />
<!-- and still more -->
<bar><inside>asgfasdf<insF>2</insF>sdfb</inside></bar>
</in1>
<in2>some in3 content</in2>
asdfb
</big>
Output:
---------------
** Itterations = 2
** ForceArray = 0
** KeepRoot = 0
** KeepComments = 0
$VAR1 = {
'in2' => 'some in3 content',
'date' => '33',
'name' => 'asdf',
'content' => [
'
asdf
',
'
asdfb
'
],
'in1' => {
'small' => {
'ueue' => 'second',
'biz' => 'wefwf'
},
'bar' => {
'inside' => {
'insF' => '2',
'content' => [
'asgfasdf',
'sdfb'
]
}
},
'in2' => 'jjjj'
}
};
******************************
XML string:
---------------
<root>
<!--
wasdfvgasvbg <![CDATA[ not really a CDATA ]]>
<tag>at tag in a real comment</tag>
<![CDATA[ not a CDATA ]]>
-->
<!-- This is a real comment -->
this is some content
<stag><br>some br stuff</br>after<t>some t
</t>
</stag>
<![CDATA[ <!-- imbed comment --> some text <!-- imbed as well -->]]>
<![CDATA[ <!-- imbed comment --> some text <!-- imbed as well -->]]>
</root>
Output:
---------------
** Itterations = 2
** ForceArray = 0
** KeepRoot = 0
** KeepComments = 0
$VAR1 = {
'content' => [
'
this is some content
',
'
<!-- imbed comment --> some text <!-- imbed as well -->
<!-- imbed comment --> some text <!-- imbed as well -->
'
],
'stag' => {
'br' => 'some br stuff',
'content' => 'after',
't' => 'some t
'
}
};
******************************
XML string:
---------------
<!-- This is a real comment -->
<node1
name = 'Barney'
date = "1/1/05"
/>
Output:
---------------
** Itterations = 2
** ForceArray = 0
** KeepRoot = 0
** KeepComments = 0
$VAR1 = {
'date' => '1/1/05',
'name' => 'Barney'
};
******************************
XML string:
---------------
<node1
tire = 'Michelan'
size = "235 x 16">
Recalled by factory</node1>
Output:
---------------
** Itterations = 2
** ForceArray = 0
** KeepRoot = 0
** KeepComments = 0
$VAR1 = {
'content' => '
Recalled by factory',
'tire' => 'Michelan',
'size' => '235 x 16'
};
******************************
XML string:
---------------
<node>this is a node</node>
<node>this is a different</node>
Output:
---------------
** Itterations = 2
** ForceArray = 0
** KeepRoot = 0
** KeepComments = 0
Warning, multiple elements at root level ..
$VAR1 = {
'node' => [
'this is a node',
'this is a different'
]
};
******************************
XML string:
---------------
<Node>this is a node</node>
<node>this is a different</Node>
Output:
---------------
(0) XML problem: malformed, syntax or tag closure:
<root>
<Node>this is a node</node>
<node>this is a different</Node>
</root>
------------------------------
Date: Wed, 28 Dec 2005 21:54:14 -0800
From: robic0
Subject: Re: My Regexp XML Parser -> Structured Perl Data, Cut & Paste Version, No Module's (Vol I)
Message-Id: <bcu6r1lelaee8ifpd4k5iqheo1vsbfc2as@4ax.com>
On Wed, 28 Dec 2005 21:42:09 -0800, robic0 wrote:
>On Tue, 20 Dec 2005 23:59:06 -0800, robic0 wrote:
>
>Update on the code. Lots of changes:
>
>v.902
>- Fixed white space issues surrounding attributes
>- Fixed \"\' issue delimiting attribute content
>- Fixed root container issues
>- Fixed CDATA in comments
>- Fixed comments in CDATA
>- Added more warnings related to root level
>
Oh and
- Fixed case sensitivity of tag names
-t
------------------------------
Date: 6 Apr 2001 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 6 Apr 01)
Message-Id: <null>
Administrivia:
#The Perl-Users Digest is a retransmission of the USENET newsgroup
#comp.lang.perl.misc. For subscription or unsubscription requests, send
#the single line:
#
# subscribe perl-users
#or:
# unsubscribe perl-users
#
#to almanac@ruby.oce.orst.edu.
NOTE: due to the current flood of worm email banging on ruby, the smtp
server on ruby has been shut off until further notice.
To submit articles to comp.lang.perl.announce, send your article to
clpa@perl.com.
#To request back copies (available for a week or so), send your request
#to almanac@ruby.oce.orst.edu with the command "send perl-users x.y",
#where x is the volume number and y is the issue number.
#For other requests pertaining to the digest, send mail to
#perl-users-request@ruby.oce.orst.edu. Do not waste your time or mine
#sending perl questions to the -request address, I don't have time to
#answer them even if I did know the answer.
------------------------------
End of Perl-Users Digest V10 Issue 8808
***************************************
