From: merlyn, Richard Lee, Jerald Sheets, Rob Dixon Currently I own a 'learning perl' 3rd edition and I noticed that 5th
version is coming out in june.
What I didn't realize was that learning perl 4th edition's been out
since 2005.

I was going to order 5th version in june but does anyone in here know
the different between 3rd and 4th version?
Is there a big difference?

From: John W. Krahn, Octavian Rasnita, sivasakthi, Beau E. Cox Hi all,


How to comment Multiple lines in Perl?



Thanks,
Siva

From: Rob Dixon, anthony brooke, Chas. Owens Hello, I am using Wordnet::QueryData which allow access to a very huge dictionary data. The initialization of object
my $wn = WordNet::QueryData->new;

took
2 wallclock secs ( 2.36 usr + 0.07 sys = 2.43 CPU)

Then the subsequent request for the data is exetremely fast

For the lines below took
0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU)

print "Synset: ", join(", ", $wn->querySense("cat#n#7", "syns")), "\n";
print "Hyponyms: ", join(", ", $wn->querySense("cat#n#1", "hypo")), "\n";
print "Parts of Speech: ", join(", ", $wn->querySense("run")), "\n";
print "Senses: ", join(", ", $wn->querySense("run#v")), "\n";
print "Forms: ", join(", ", $wn->validForms("lay down#v")), "\n";
print "Noun count: ", scalar($wn->listAllWords("noun")), "\n";
print "Antonyms: ", join(", ", $wn->queryWord("dark#n#1", "ants")), "\n";

I
am developing a web application, is there a way to make the
initialization of object permanently in memory ? I tried to use the
Storable module. But that only give me a little increase in
performance. Anybody's idea is very much appreciated, Thank you.


William

Send instant messages to your online friends http://uk.messenger.yahoo.com

From: Li, Jialin, ANJAN PURKAYASTHA Hi,
here is a problem I'm working on. It's not PERL-specific, rather it is a
problem in sorting followed by grouping.
Suppose I have a set of lines that have tab-delimited text, thus:
1 w 3 wer
2 a 4 rte
4 w 2 weg
6 d 4 fhg
5 d 7 dfl
6 w 4 ald
8 a 3 dsl

I would like to first sort the lines based on the 2nd token (w,a, w, d, etc)
and then group the lines based on the 2nd token.

At the end of this sorting/grouping I should have the lines grouped thus:
2 a 4 rte
8 a 3 dsl

6 d 4 fhg
5 d 7 dfl

1 w 3 wer
4 w 2 weg
6 w 4 ald


I can figure out the sorting. Are they any command/modules to do the
grouping based on identical tokens?

appreciate your input.


tia,
anjan



--
ANJAN PURKAYASTHA, PhD.
Senior Computational Biologist
==========================

1101 King Street, Suite 310,
Alexandria, VA 22314.
703.518.8040 (office)
703.740.6939 (mobile)

email:
anjan@vbi.vt.edu;
anjan.purkayastha@gmail.com

http://www.vbi.vt.edu

==========================

From: oryann9, Jerald Sheets, Dr.Ruud, Omega -1911 Does anyone know what happened to this website: http://web.archive.org/web/20041123005900/http://www.raycosoft.com/rayco/support/perl_tutor.html
It says its not available. I thought it was a great reference and explained the diffs between map and grep and even sort.
Does anyone have a softcopy of its data that you can send me?

thank you!

From: roger61611, Gunnar Hjalmarsson Hello, Is there someplace I can get perl (for Windows) with modules
like OLE and Spreadsheet and such included already ? The PC here is
sort of old and it would be neat to just download oerl (w/ modules)
and start working vs downloading perl and then downlading/installing
module by module.

Thank you.

From: Robert Hicks, Chas. Owens just "bad" pseudo code:

sub one {
$process->name(\$html) || $errors_from_one( $process->error() );

$process->name(\$text) || $errors_from_one( $process->error() );
}

sub errors_from_one {
my $error = @_;

push (my @errors, $error);

# do stuff to make sure the errors are uniq

return my @uniq_error_list;
}


I want to be able to get at those errors later. Will something like that
work?

Robert

From: Tech list, Levente Kovacs, Gunnar Hjalmarsson, Li, Jialin what is the correct way to get the number of items in an array?

I used to use $#array

From: John W. Krahn, Richard Lee, Li, Jialin, Dr.Ruud I am running this command on over 2 gigs worth of lines....

which one should be faster?

cut -d'|' -f21 * | sort | uniq -c | sort


perl -F"\|" -lane 'print $F[21]' * | sort | uniq -c | sort


or is there faster ways to do this on perl?

From: Rob Coops, Richard Lee Hi guys again!

I am sure this questions been around for while but I am not sure where
to begin.

I am trying to grep a html page given a URL and then extract some
information from the source code.
So something like

open FH, "www.example.com/index.html | " , or die "no way : $!\n";
@array = <FH>;

my $code;
while (@array) {
next if /bleh/;
if ( /^From: (.*)/ ) {
$code = $1;
}
}

You get the idea.. so anyway I did the search
on google

'how to grep a web page source using perl' -- no luck
web perl modules ---> reading
http://www.perl.com/pub/a/2002/08/20/perlandlwp.html

I guess the reason I wrote this out is to see if anyone else begining
perl webpage can use my search or perhaps someone can tell me I am doing
something stupid
as perl and web seems to be pretty common operation but this is only way
I know how to at this point.

anyway, just sharing on this... and also look for feedback

From: Munzilla, Gunnar Hjalmarsson Hi, I'm 100% new to Perl but I've been given a project with it anyway,
so I have some pretty basic questions.
The script is used to process a form submitted in PHP. I have it
working fine, but I need to add an email address field now. i was
told that Perl doesn't like the "@" character (which makes sense), and
I know that I could use the backslash, but does Perl treat the
submitted field as an object, or will I have to add some functionality
which adds the backslashes before the form is submitted to the Perl?
Basically, do I need to even worry about the @ symbol if I'm working
with the submitted form fields in Perl, or will the @ still crash the
script?
Thanks.
Munz

From: anthony brooke Hello, I am using Wordnet::QueryData which allow access to a very huge dictionary data. The initialization of object
my $wn = WordNet::QueryData->new;

took
2 wallclock secs ( 2.36 usr + 0.07 sys = 2.43 CPU)

Then the subsequent request for the data is exetremely fast

For the lines below took
0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU)

print "Synset: ", join(", ", $wn->querySense("cat#n#7", "syns")), "\n";
print "Hyponyms: ", join(", ", $wn->querySense("cat#n#1", "hypo")), "\n";
print "Parts of Speech: ", join(", ", $wn->querySense("run")), "\n";
print "Senses: ", join(", ", $wn->querySense("run#v")), "\n";
print "Forms: ", join(", ", $wn->validForms("lay down#v")), "\n";
print "Noun count: ", scalar($wn->listAllWords("noun")), "\n";
print "Antonyms: ", join(", ", $wn->queryWord("dark#n#1", "ants")), "\n";

I am developing a web application, is there a way to make the initialization of object permanently in memory ? I tried to use the Storable module. But that only give me a little increase in performance. Anybody's idea is very much appreciated, Thank you.


William


Send instant messages to your online friends http://uk.messenger.yahoo.com

From: Irfan.Sayed, John W. Krahn, Rob Dixon #! /usr/tools/deployment/bin/perl

use lib "/home/m.belgaonkar/";
use lib "/home/p.gupta/";
$i=0;
$p=0;
$l=0;
$dt=qx(date);
@dt1=split(' ',$dt);
@dt2[0]=@dt1[2];
@dt2[1]=@dt1[1];
@dt2[2]=@dt1[3];
@dt2[3]=@dt1[5];
chomp($dt_fin=join(":",@dt2));

system ("clear");
print "$dt_fin\n";
print "****************************************************\n";
print "******************Merge Tool************************\n";

$ap_nm=`pwd`;
if ($ap_nm =~ /view/){print "You are in the view:$ap_nm\n";}else{print "You are not in any clearcase view \n"; exit 1;}
if ($ap_nm =~ /oms/)
{
$ap_nm=oms;
print "Application name:oms\n";
}
elsif ($ap_nm =~ /akb/)
{
$ap_nm=akb;
print "Application name:akb\n";
}
elsif ($ap_nm =~ /cia/)
{
$ap_nm=cia;
print "Application name:cia\n";
}
elsif ($ap_nm =~ /crm/)
{
$ap_nm=crm;
print "Application name:crm\n";
}
elsif ($ap_nm =~ /dps/)
{
$ap_nm=dps;
print "Application name:dps\n";
}
elsif ($ap_nm =~ /hmy/)
{
$ap_nm=hmy;
print "Application name:hmy\n";
}
elsif ($ap_nm =~ /vss/)
{
$ap_nm=vss;
print "Application name:vss\n";
}
elsif ($ap_nm =~ /ccb/)
{
$ap_nm=ccb;
print "Application name:ccb\n";
}
elsif ($ap_nm =~ /wsp/)
{
$ap_nm=wsp;
print "Application name:wsp\n";
}
elsif ($ap_nm =~ /prs/)
{
$ap_nm=prs;
print "Application name:prs\n";
}
else
{
print "You does not seems to be in any application\n";
print "Exiting\n";
exit 1;
}

config_spec_chk();
env();
sub config_spec_chk()
{
%hash = (
oms => 'oms.rel.02.23.000',
akb => 'akb.rel.01.00.000',
cia => 'ci1.rel.02.00.000',
crm => 'crm.rel.03.00.000',
dps => 'dps.rel.01.00.000',
hmy => 'hmy.rel.00.00.000',
vss => 'vss.int.00.00.000',
prs => 'prs.rel.01.09.000',
ccb => 'ccb.rel.01.02.000',
wsp => 'wsp.rel.00.00.000',
);

%hash_const = (
"element /vob/support/tools/deployment/repository" => '/main/LATEST',
"element /vob/lib/repository/..." => '/main/LATEST',
"element /vob/lib/rep_v1/..." => '/main/LATEST',
"element /vob/support/tools/deployment/packages/..." => '/main/LATEST',
"element /vob/lib/packages/..." => '/main/LATEST',
"element /vob/support/tools/deployment/specs/..." => 'CHECKEDOUT',
"element /vob/support/tools/deployment/specs/..." => '/main/LATEST',
"element /vob/support/tools/deployment/initfiles/..." => 'CHECKEDOUT',
"element /vob/support/tools/deployment/initfiles/..." => '/main/LATEST',
"element /vob/support/tools/deployment/relnotespecs/..." => 'CHECKEDOUT',
"element /vob/support/tools/deployment/relnotespecs/..." => '/main/LATEST',
"element /vob/support/tools/deployment/mergespecs/..." => 'CHECKEDOUT',
"element /vob/support/tools/deployment/mergespecs/..." => '/main/LATEST',
"element /vob/support/tools/deployment/scripts/..." => '/main/LATEST',
"element /vob/support/tools/deployment/global_env_files/..." => '/main/LATEST',
"element -directory /vob/support/tools/deployment" => '/main/LATEST',
"element -directory /vob/support/tools" => '/main/LATEST',
"element -directory /vob/support" => '/main/LATEST',
"element -directory /vob/lib" => '/main/LATEST',
);

#qx(ct catcs | tee /home/m.belgaonkar/curr_conf_spec_$dt_fin);
open(fh, ">/tmp/config") || die "Can't open file:\n";
while (($key,$value)=each(%hash))
{

if (($key eq oms) && ($ap_nm =~ /oms/))
{
$rel_br=$value;
print fh "element /vob/support/tools/deployment/specs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/initfiles/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/relnotespecs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/mergespecs/... CHECKEDOUT\n";

print fh "\n";

foreach (keys %hash_const)
{
print fh "$_ $hash_const{$_}\n";
}

print fh "\n";
print fh "element * CHECKEDOUT\n";
print fh "element * .../$value/LATEST\n";
print fh "element * /main/0 -mkbranch $value\n";
}
elsif (($key eq akb) && ($ap_nm =~/akb/))
{
$rel_br=$value;
print fh "element /vob/support/tools/deployment/specs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/initfiles/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/relnotespecs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/mergespecs/... CHECKEDOUT\n";

print fh "\n";

foreach (keys %hash_const)
{
print fh "$_ $hash_const{$_}\n";
}

print fh "\n";
print fh "element * CHECKEDOUT\n";
print fh "element * .../$value/LATEST\n";
print fh "element * /main/0 -mkbranch $value\n";
}
elsif (($key eq cia) && ($ap_nm =~ /cia/))
{
$rel_br=$value;
print fh "element /vob/support/tools/deployment/specs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/initfiles/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/relnotespecs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/mergespecs/... CHECKEDOUT\n";

print fh "\n";

foreach (keys %hash_const)
{
print fh "$_ $hash_const{$_}\n";
}

print fh "\n";
print fh "element * CHECKEDOUT\n";
print fh "element * .../$value/LATEST\n";
print fh "element * /main/0 -mkbranch $value\n";
}
elsif (($key eq crm) && ($ap_nm =~ /crm/))
{
$rel_br=$value;
print fh "element /vob/support/tools/deployment/specs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/initfiles/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/relnotespecs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/mergespecs/... CHECKEDOUT\n";

print fh "\n";

foreach (keys %hash_const)
{
print fh "$_ $hash_const{$_}\n";
}

print fh "\n";
print fh "element * CHECKEDOUT\n";
print fh "element * .../$value/LATEST\n";
print fh "element * /main/0 -mkbranch $value\n";
}
elsif (($key eq dps) && ($ap_nm =~ /dps/))
{
$rel_br=$value;
print fh "element /vob/support/tools/deployment/specs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/initfiles/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/relnotespecs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/mergespecs/... CHECKEDOUT\n";

print fh "\n";
foreach (keys %hash_const)
{
print fh "$_ $hash_const{$_}\n";
}

print fh "\n";
print fh "element * CHECKEDOUT\n";
print fh "element * .../$value/LATEST\n";
print fh "element * /main/0 -mkbranch $value\n";
}
elsif (($key eq hmy) && ($ap_nm =~ /hmy/))
{
$rel_br=$value;
print fh "element /vob/support/tools/deployment/specs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/initfiles/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/relnotespecs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/mergespecs/... CHECKEDOUT\n";

print fh "\n";
foreach (keys %hash_const)
{
print fh "$_ $hash_const{$_}\n";
}

print fh "\n";
print fh "element * CHECKEDOUT\n";
print fh "element * .../$value/LATEST\n";
print fh "element * /main/0 -mkbranch $value\n";
}
elsif (($key eq vss) && ($ap_nm =~ /vss/))
{
$rel_br=$value;
print fh "element /vob/support/tools/deployment/specs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/initfiles/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/relnotespecs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/mergespecs/... CHECKEDOUT\n";

print fh "\n";

foreach (keys %hash_const)
{
print fh "$_ $hash_const{$_}\n";
}

print fh "\n";
print fh "element * CHECKEDOUT\n";
print fh "element * .../$value/LATEST\n";
print fh "element * /main/0 -mkbranch $value\n";
}
elsif (($key eq prs) && ($ap_nm =~ /prs/))
{
$rel_br=$value;
print fh "element /vob/support/tools/deployment/specs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/initfiles/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/relnotespecs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/mergespecs/... CHECKEDOUT\n";
print fh "\n";
foreach (keys %hash_const)
{
print fh "$_ $hash_const{$_}\n";
}

print fh "\n";
print fh "element * CHECKEDOUT\n";
print fh "element * .../$value/LATEST\n";
print fh "element * /main/0 -mkbranch $value\n";
}
elsif (($key eq ccb) && ($ap_nm =~ /ccb/))
{
$rel_br=$value;
print fh "element /vob/support/tools/deployment/specs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/initfiles/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/relnotespecs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/mergespecs/... CHECKEDOUT\n";
print fh "\n";
foreach (keys %hash_const)
{
print fh "$_ $hash_const{$_}\n";
}

print fh "\n";
print fh "element * CHECKEDOUT\n";
print fh "element * .../$value/LATEST\n";
print fh "element * /main/0 -mkbranch $value\n";
}
elsif (($key eq wsp) && ($ap_nm =~ /wsp/))
{
$rel_br=$value;
print fh "element /vob/support/tools/deployment/specs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/initfiles/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/relnotespecs/... CHECKEDOUT\n";
print fh "element /vob/support/tools/deployment/mergespecs/... CHECKEDOUT\n";
print fh "\n";
foreach (keys %hash_const)
{
print fh "$_ $hash_const{$_}\n";
}

print fh "\n";
print fh "element * CHECKEDOUT\n";
print fh "element * .../$value/LATEST\n";
print fh "element * /main/0 -mkbranch $value\n";
}

else{}
}
if ($?=0){print "Config spec generation failed\n";exit 1;}
else{print "Config spec of the destination view is being created\n"; print "Config spec :Done\n";}
close (fh);

print "Setting the destination config spec to the current view\n";
`/usr/atria/bin/cleartool setcs /tmp/config`;
if ($?){print "Config spec not set correctly\n check the same and try once again\n"; exit 1;}
else{print "Config spec set correctly\n";}
# print "Reexecuting the config spec \n";
# `usr/atria/bin/cleartool setcs -current`;
# if ($?){print "Execution of config spec failed\n check the same and try once again\n"; exit 1;}
# else{print "Done\n";}

}

sub env()
{
print "Enter the baseline:";
chomp($bl = <STDIN>);
chomp($rel_lbl_fin=$bl);
print "Enter the update:";
chomp($up_bl = <STDIN>);

print "Enter the no. of packages needs to be merged:";
chomp($ct_pkg = <STDIN>);

for ($i=1;$i<=$ct_pkg;$i++)
{
print "Enter the release note for package $i :";
chomp($pk = <STDIN>);
print "Enter the update:";
chomp($up = <STDIN>);
print "Enter the development branch name for package $i :";
chomp($br_name_fin = <STDIN>);
$dev_lbl=$pk;
# $br_name=$dev_lbl;
# $br_name_fin=lc $br_name;
if ($up != 0){
chomp($depl_lbl="D." . "$pk" . ".$up");
}else{chomp($depl_lbl="D." . $pk);}

`/usr/atria/bin/cleartool lstype lbtype:$depl_lbl 2>/dev/null`;
if ($?)
{
print"Depl. Label $depl_lbl is not exist\n";
print "Creating the deployment label and applying it to all files which has development label\n";
`/usr/atria/bin/cleartool mklbtype -nc $depl_lbl`;
if ($?){print "Deployment label creation failed. Please check and try once again\n"; exit 1;}
else{
print "Deployment label created successfully\n";
}
}
else{
print "Deployment label for this package would be : $depl_lbl\n";}
#if ($pk =~ /(.*)\./) {
# print "$1\n";
# $dev_lbl=$1;
#}
`/usr/atria/bin/cleartool lstype lbtype:$dev_lbl 2>/dev/null`;
if ($?)
{
print"Dev. Label $dev_lbl is not exist\n";
print "Create the devlopment label,apply it to all files and directories and then start merge\n";
exit 1;}
else{
print "Devlopment label for this package would be : $dev_lbl\n";}

`/usr/atria/bin/cleartool lstype brtype:$br_name_fin 2>/dev/null`;
if ($?){ print "Dev. branch $br_name_fin is not exist\n"; exit 1;}
else{print "Dev. branch is $br_name_fin\n";}
compare();

push (@pkg_lst,$pk);
}
rel_label();
}

sub compare()
{
print "Compairing files with development label and deployment label\n";

chomp($ct_fil_depl=`/usr/atria/bin/cleartool find -all -version "lbtype($depl_lbl) && brtype($br_name_fin)" -print | wc -l`);
chomp($ct_fil_dev=`/usr/atria/bin/cleartool find -all -version "lbtype($dev_lbl) && brtype($br_name_fin)" -print | wc -l`);

chomp(@no_depl_lbl=`/usr/atria/bin/cleartool find -all -version "lbtype($dev_lbl) && brtype($br_name_fin) &&! lbtype($depl_lbl)" -print`);

print " No. of files which has deployment label : $ct_fil_depl\n";
print " No. of files which has development label : $ct_fil_dev\n";
print "@no_depl_lbl\n";

if (@no_depl_lbl eq "" || @no_depl_lbl eq "NULL" || !defined @no_depl_lbl)
{
print "All the files have both deployment label $depl_lbl and development label $dev_lbl\n";
merge();
}

else
{
print "Files with deployment $depl_lbl and development label $dev_lbl are mismatch\n";
print "Applying the deployment label to all versions which has developer label\n";
print "Checking the lock status of deployment label\n";
$st_chk= `/usr/atria/bin/cleartool lslock lbtype:$depl_lbl`;
if($st_chk eq "")
{
print " Label is not locked\n";
}
else
{
print "Label is locked\n Unlocking the label\n";
`/usr/atria/bin/cleartool unlock lbtype:$depl_lbl`;
if($?){print "Label unlocking failed\n Check the same and try once again\n";exit 1;}
else{print "Label unlocked successfully\n";}}
$a=0;
foreach(@no_depl_lbl)
{
`/usr/atria/bin/cleartool mklabel -replace $depl_lbl $_`;
if ($?){print"Unable to apply the label $depl_lbl to file $_.Please chk the same and try again\n";exit 1;}
else{$a++;}
}
}
if($a!=0){print "Deployment label has been applied to all files now\n";
print "Locking the deployment label\n";
`/usr/atria/bin/cleartool lock lbtype:$depl_lbl`;
if($?){print "Locking of deployment label failed\n Please check the same and try again\n";}
else{print "Label locked successfully\n";}
merge();
}
}
sub merge()
{
print "Merge operation from developer branch $br_name_fin to the release branch $rel_br\n";

@merg_prev=`/usr/atria/bin/cleartool findmerge -all -element "brtype($br_name_fin)" -fversion $depl_lbl -print -short`;
chomp($size = @merg_prev);
if ($size==0){ print "All the files on the development branch and release branch are identical.\n No need to merge anything\n";}
else
{
print "Following files will be merged \n";
print "@merg_prev\n\n";
print "Confirm [y/n]:";
chomp($conf = <STDIN>);

if (($conf eq "y") || ($conf eq "Y"))
{
@merg_act=`/usr/atria/bin/cleartool findmerge -all -element "brtype($br_name_fin)" -fversion $depl_lbl -merge -log /tmp/merge_log_$dt_fin`;
if($?){print "Merge operation failed....\n Check the same and try once again\n"; exit 1;}
else {
print "Merged all the files to the release branch\n";
print "Checking in all files and directoris\n";
`/usr/atria/bin/cleartool lsco -r -cview -s . | xargs ct ci -nc`;
if($?){ print "Check in operation failed.....\n please check the same and try again\n"; exit 1;}else{}
@lsco=`/usr/atria/bin/cleartool lsco -r -cview -s .`;
if(@lsco eq "" || !defined @lsco)
{
print "All the files checked in properly\n";
print "Merge operation completed for package $pk with update $up\n";
log();
}else{ print "Some files are still in checked out condition\n check the same and try again\n"; exit 1;}
mail();}
}
elsif(($conf eq "n") || ($conf eq "N"))
{
print "OK!!!!!\n";
exit 1;
}
else
{
print "Bad choice\n";
exit 1;
}
}
}

sub rel_label()
{
print "Checking the REL label \n";
`/usr/atria/bin/cleartool lstype lbtype:$rel_lbl_fin 2>/dev/null`;
if($?){ print "REL label does not exist\n Creating the REL label ....\n";
`/usr/atria/bin/cleartool mklbtype -nc $rel_lbl_fin`;
if($?){ print "REL label creation failed\n Please check the same and try again\n "; exit 1;}
else{ print "REL label created successfully\n";}
}
else
{
print "Checking the lock status of REL label \n";
$st=`/usr/atria/bin/cleartool lslock lbtype:$rel_lbl_fin`;
if ($st eq "")
{
print "Label is not locked\n";
}
else
{
print "Label is locked\n Unlocking the label\n";
`/usr/atria/bin/cleartool unlock lbtype:$rel_lbl_fin`;
if($?){print "Label unlocking failed\n Check the same and try once again\n";exit 1;}
else{print "Label unlocked successfully\n";}
}}
print "Applying the REL label to all files and directory\n";
`/usr/atria/bin/cleartool mklabel -rec -replace $rel_lbl_fin .`;
if($?){ print "REL label application to all files has been failed\n Please check the same and try again\n"; exit 1;}
else{print "REL label has been applied properly to all files\n";
print "Locking the REL label\n";
`/usr/atria/bin/cleartool lock lbtype:$rel_lbl_fin`;
if($?){ print "Locking of REL label failed\n Please check the same and try again\n";}
else{ print " REL label locked successfully\n";}
}
}

sub log()
{
# this function will create the detail log file for each package merged to the release branch.

open(fh1, ">/tmp/Log_Merge_$pk_$up") || die "Cant open file $!\n";
print fh1 "**************************************************************\n";
print fh1 "Merge log file for package $pk update $up\n";
print fh1 "REL baseline : $bl update : $up_bl\n";
print fh1 "Package release note : $pk update : $up\n";
print fh1 "No. of files with development label : $ct_fil_dev\n";
print fh1 "Pathname of each file is \n";
print fh1 "No. of files with deployment label : $ct_fil_depl\n";
print fh1 "Pathname of each file is \n";
print fh1 "No. of files which needs to be merged : \n";
print fh1 "Following files got merged\n";
print fh1 "@merg_prev\n\n";



}

sub mail()
{
use SendMail 2.09;

#
# Create the object without any arguments,
# i.e. localhost is the default SMTP server.
#
my $sm = new SendMail("S4INPUSYAIC.ts-ap.t-systems.com");
#
# Set SMTP AUTH login profile.
# Uncomment the following line if you like to try SMTP AUTH.
#
#$sm->setAuth($sm->AUTHLOGIN, "username", "password");
#$sm->setAuth($sm->AUTHPLAIN, "username", "password");

#
# We set the debug mode "ON".
#
$sm->setDebug($sm->ON);
#
# We set the sender.
#
$sm->From("CC VOB Admin -T-systrems pune <Irfan.Sayed\@t-systems.com>");

#
# We set the subject.
#
$sm->Subject("Test mail");

#
# We set the recipient.
#
#$sm->To("Irfan <Irfan.Sayed\@t-systems.com>");

#
# We set the content of the mail.
#

$sm->setMailBody("Hi,\n ");

#
# Attach a testing image.
#
#$sm->Attach("./welcome.gif");

#
# Check if the mail sent successfully or not.
#
if ($sm->sendMail() != 0) {
print $sm->{'error'}."\n";
exit -1;
}

#
# Mail sent successfully.
#
print "Done\n\n";
exit 0;
}

From: Richard Lee, Jenda Krynicky, John W. Krahn, Rob Dixon

while (<FILE>) {
my($file1,$file2,$file3,$file4,$file5,$file6,$file10,$file25,$file27)
= (split( /\|/, $_))[3,4,6,7,12,40,41,42,43,46,56,64]
}

while doing above, what is the easiest way to make sure all the variable
that's being given a value is true and if not
assign something default value (such as 'default' or 'X') ?

I was doing (after the while loop)

$file |= 'default'
$file2 |= 'default2'
$file3 |= 'default3'

but I stopped and thought this cannot be so repetitious

so I didn't want to but tried( I didn't want to put them in array since
I need to use individual named variable later)

while (<FILE>) {
my @array = (split( /\|/, $_))[3,4,6,7,12,40,41,42,43,46,56,64]
}
for (@array) {
$_ |= 'default';
}

but is that the best way to do this?

From: reader, Rob Dixon Can soneone show me how to convert unix time to something else using
Date:: Manip?

AFter looking at the Docs in perldoc Date::Manip I thought maybe (from
the examples) something like script below would work. The first two
(now commented) worked as expected but the one with unix date produces
a blank line only:

#!/usr/local/bin/perl

use strict;
use warnings;
use Date::Manip;

my $date;
# print $date = ParseDate("05/12/08") . "\n";
# print $date = ParseDate("today") . "\n";
print $date = ParseDate("1210628919") . "\n";

What is the right syntax?

From: John Wilson I tried this on Friday afternoon - thought I'd try again...



I keep running into a brick wall when installing the perl module
IO::Socket::SSL. During the install, I get an error message that makes
the install fail. The message happens when cpan is running external
tests, so it seems like there is some kind of problem with a setting
somewhere. I googled the error, I saw that other people have had
problems with their DNS settings, but everything is fine as far as I
know. Anyone know what kinds of issues might produce errors like this,
or anyone know what kinds of settings need to be in place when dealing
with sockets?



Error message:

Use of uninitialized value in subroutine entry at
/m1/shared/perl/5.8.5-09/lib/5.8.5/sun4-solaris/Socket.pm line 373.

Bad arg length for Socket::pack_sockaddr_in, length is 0, should be 4 at
/m1/shared/perl/5.8.5-09/lib/5.8.5/sun4-solaris/Socket.pm line 373.



I have no idea what I'm doing, but thanks,

John W.



P.S. I'm installing using cpan on solaris 9, perl 5.8.5. And
technically, this error happens while cpan is installing Net::SSLeay, a
dependency of IO::Socket::SSL.

From: Gunnar Hjalmarsson, Hildreth, Steve I am in the process of logging referring URLs that result in end users
being directed to a 4xx error page. What I have noticed is that other
items such as a missing CSS, a reference to a non-existing image, etc.
that does not necessarily result in the user seeing the 4xx page is
still makes an entry in my log file. What I am looking for is a
parameter that I can add to my PERL script that will specify the file
call that resulted in the log entry.



Thanks,


Steve
-----------------------------------
Steve Hildreth
Office: 213-241-1691
Cell: 213-215-8195
steve.hildreth@lausd.net <blocked::mailto:steve.hildreth@lausd.net>

From: Yitzchok Good, Pat Rice lHi All
ooking to done some work whit CGI forms in perl, primarily connecting
to a database and inserting, deleting and showing values in a
database, While looking not to reinvent the wheel, whats out there
that I can easily use that would do this for me ?

looking at the CGI module... but I think I can mix that up with HTML easly

Thanks in advance
Pat

From: John W. Krahn, Tatiana Lloret Iglesias, Chas. Owens Hi all!

i'm running the following dummy program which just opens a file and I get an
error (die message)

#!/usr/bin/perl


if ( @ARGV[0] eq '' )
{
print "\nUSAGE:\n\t genenames.pl genes.txt \n\n";
exit;
}

my $file = $ARGV[0];
open(FICH,"$file") or die "cannot open $file";

I've tried to pass the input parameter ARGV[0] with / with \ with relative
path ... but nothing

any idea?

Thanks a lot!
T

From: Richard Lee, Chas. Owens I just looked it up on perldoc perlvar, but I am still not sure what it
does.



$^I The current value of the inplace-edit extension. Use "undef"
to disable inplace editing. (Mnemonic: value of -i
switch.)

I was reading perl cookbook and saw this example, and was wondering what
that is....


if (@ARGV) {
$^I = ".orig";
} else {
warn "$0: Reading from stdin\n" if -t STDIN;
}

From: merlyn, J. Peng, Teo, hotkitty I've been trying to setup a connection w/ a shared server at
godaddy.com. The script won't work and when I called them they tell me
that because I don't have a dedicated server that I can't run a perl
script and so I need to upgrade my account. I can access the shared
server w/ PHP....why can't I do it w/ PERL? I've gotten bullsh*t
answers from tech support before so thought I'd check here to see if,
indeed, I need to upgrade my account or switch hosting providers. Is
tech support right?

From: Dr.Ruud, John W. Krahn, Johnson Lau, Chris Charley Dear all,

I need to compare two binary numbers and need perl to return the
number of matching bits.

For example:

$aaa = "10111100";
$bbb = "00101100";

In this case, the number of matching bits is 6.

I know I could split the strings and compare the bits one by one.
However, is there any faster functions for this? I need to compare
millions of such strings with 1000 bits for each.

Thanks a lot!!

Johnson Lau

From: Jenda Krynicky, Richard Lee, Peter Scott, Rob Dixon I dont know how to go through the array over and over again pending on
my previous search so I ended up writing it like below which works.. but
looks really really
inefficient..


sub dd_fact {
my $routename = shift;
my $routegroupid;
my $trunkgroupid;
my $carriername;
my $carrier_active;
my $carrierid;
AHI: for (@dat) {
if (exists $_->{outsideroute_group_m}{route_name}
and $_->{outsideroute_group_m}{route_name} eq "$routename") {
$routegroupid = $_->{outsideroute_group_m}{route_group_id};
last AHI;
}
}

EWF: for (@dat) {
if (exists $_->{outsideroute_trunk_m}{route_group_id}
and $_->{outsideroute_trunk_m}{route_group_id} eq
"$routegroupid") {
$trunkgroupid = $_->{outsideroute_trunk_m}{trunkgroup_id};
last EWF;
}
}

WWW: for (@dat) {
if (exists $_->{outsideotrunkgroup_m}{trunkgroup_id}
and $_->{outsideotrunkgroup_m}{trunkgroup_id} eq
"$trunkgroupid") {
$carrierid = $_->{outsideotrunkgroup_m}{carrier_id};
last WWW;
}
}

for (@dat) {
if (exists $_->{outsidecarrier_m}{carrier_id}
and $_->{outsidecarrier_m}{carrier_id} eq "$carrierid") {
$carriername = $_->{outsidecarrier_m}{carrier_name};
$carrier_active = live($_->{outsidecarrier_m}{active});
return($trunkgroupid,$carriername,$carrier_active);
}
}
}

From: Gunnar Hjalmarsson, Richard Lee, Dr.Ruud I use this before (split slice ) but it's working bit funny now..

can someone tell me why??

it looks like it's splitting on '' instead of /|/ as I have specified
below... ??

use strict;
use warnings;


my $array = q/hi|how|are|you|fine/;

my ($moe,$hae,$now) = (split(/|/,$array))[0,1,2];
print "$moe $hae $now\n";

[root@RLEE ~]# ./!$
././split_practice.pl
h i |

From: Richard Lee, Süleyman Gülsüner, Chas. Owens
does anyone use perl-support for vim here?

I installed it but having trouble bringing up the menus..

does anyone uses this? and know how to bring up the menu?

If the root menu 'Perl' is not visible call it with the item
"Load Perl Support" from the standard Tools-menu. <-- where is this
standard tools-menu?

From: John W. Krahn, Mark Wagner Given a string of text, how do I convert it to a string of hexadecimal
values? For example, given the string "Hello", I want the string "48
65 6C 6C 6F".

--
Mark

From: Ravi Malghan Hi: I have very little knowledge about MQ Series. I have built the MQ Client and MQSeries perl API on my server. My MQ admin also has provided me the name of ques, queue manager, MA CHannel, hostname and port. I am trying to build a simple script that will connect to a que and fetch messages. I have not found any useful examples on the web. Can someone share a code ?

Que Name: TRS.E0.CREATE.REMEDY1
Queue manager: SPBO021T
MQ channel: REMEDY.CLIENT
IP: spbo021t.xx.xx.xx
Port: 1424

Thanks
Ravi



____________________________________________________________________________________
Be a better friend, newshound, and
know-it-all with Yahoo! Mobile. Try it now. http://mobile.yahoo.com/;_ylt=Ahu06i62sR8HDtDypao8Wcj9tAcJ

From: John Wilson, Rob Dixon Trying to install Net::SSLeay on Solaris 9 and I get the following
message in the output:



Use of uninitialized value in subroutine entry at
/m1/shared/perl/5.8.5-09/lib/5.8.5/sun4-solaris/Socket.pm line 373.

Bad arg length for Socket::pack_sockaddr_in, length is 0, should be 4 at
/m1/shared/perl/5.8.5-09/lib/5.8.5/sun4-solaris/Socket.pm line 373.



I've googled parts of this error and get some indication it might have
to do with dns problem, but as far as I know I have no dns problem. Any
advice?



Thanks,

John W.

From: Tony Heal, Gunnar Hjalmarsson, Dr.Ruud I need to remove all messages older than X from a gigabyte size mbox. Anyone
got a script for this?



Tony Heal

Pace Systems Group, Inc.

800-624-5999 x9317

From: Lokeey, Rob Dixon I'm writing this script to remove users from a file, the sudoers file, to be
more specific.

Here is what I have so far, not sure where to go from here.

*#!/usr/bin/perl -w

# this script removes a user from sudoers file

my $sites = $ARGV[0];
my $user = $ARGV[1];

for my $site ($#ARGV[1]){
open FILE, "$_/local/etc/sudoers" or die "cannot open sudoers for $sites:
$!";

print "Enter username you wish to remove from $sites sudoers.\n";

while (<FILE>) {s/$_//}
close FILE;
}*


--
"It's not what people call you, it's what you answer to."

From: 亂世貓熊 Hi all,

I have some problem on writing remarks on module.

<code>

use SomeMod ; # exported "BuildFather"

$x = BuildFather ( %argv ) ;

$x_child = $x -> GiveSomething ( %argv ) ;

$x_grandson = $x_child -> DoSomthingElse ( %argv ) ;

print $x_child -> {Value}{Provided}{by}{Grandson}

</code>

So, which is a class?
which is a method ?
which is a class method ?
which is child method ?
How do I presence if there's any inherit happen here ?
Is there any so-called super class exists here ?

Any pointers ?

Thank you very much !





--
This message has been scanned for viruses and
dangerous content by MailScanner, and is
believed to be clean.

From: Richard Lee, Rob Dixon, Yitzchok Good #!/usr/bin/perl

use warnings;
use strict;

my @array = qw/one two three four/;

print "$_\n" for @array last if "$_" eq q/three/;


[root@server tmp]# ./!$
././././testthis2.pl
syntax error at ././././testthis2.pl line 8, near "@array last "
Execution of ././././testthis2.pl aborted due to compilation errors.

Can someone fix my last statement on this program?

I thought maybe this will work but guess not... is there no easy way
to do this?

I don't want to do

for (@array) {
if .......
}
}


just trying to see what the correct format is that for one liner that I
am trying

thanks in advance.

From: John Wilson, zentara Hi, I'm trying to install a perl module (Net::SSLeay) on a Sun unix box
running Solaris 9. In doing the make, I get a message from the shell in
the output:

"sh: gcc: cannot execute". To me this sounds like it's saying it
doesn't know what/where gcc is.



My gcc is in /usr/local/bin, but /usr/local/bin is not in PATH. So I
edited the path to include it, but I still get the same message. But I
am thinking I may not be doing the path edit correctly because when I
end the session, the path returns to the way it was before.



Anyone know if my problem is with the PATH, or the compiler? I had also
gotten a message saying to make sure to use the same compiler as with
OpenSSL and perl - don't know if that's part of the problem.



I'm a newbie to perl modules. I'd appreciate any help.

John W

From: Tony Jones Hi,

I've been trying to use the extract_quotelike and extract_delimited
functions to extract a SQL statement from a line of C++ code but I
just can't get it to work.

The script is searching all .cpp files in a folder for SQL commands;
it manages to extract some but not all of them. I'm using a basic
regex to select only the lines which contain the word "SELECT" (which
is the start of all the SQL statements I'm interested in) and then
passing the line from the file to extract_quotelike (as all the SQL is
contained in double quotes).

If the input line only contains the SQL with no prefix, it works, but
when there are other characters before the quoted string it fails. For
example, passing the the C++ line:

Open(CRecordset::snapshot, "SELECT SCOPE_IDENTITY()
Build_request_Id");

to extract_quotelike returns an empty string as the extracted result
and the whole string as the remainder, indicating it found no quoted
strings in the line.

Can anyone tell me how to get the quoted string out of that line? I've
tried specifying all manner of parameters to the function and even
tried using extract_delimited but I can't get that to work either!

Thanks for any help,
Anthony

From: John W. Krahn, sanket vaidya, Dr.Ruud HI all,



Kindly go through the code below.



use warnings;

use strict;

my $i=1;

while($i<=10)

{

$_ = "abcpqr";

$_=~ s/(?=pqr)/$i/;

print "$_\n";

$i++;

}



Output:

abc1pqr

abc2pqr

abc3pqr

abc4pqr

abc5pqr

abc6pqr

abc7pqr

abc8pqr

abc9pqr

abc10pqr



The expected output is



abc001pqr

abc002pqr

abc003pqr

abc004pqr

abc005pqr

abc006pqr

abc007pqr

abc008pqr

abc009pqr

abc010pqr



Can any one suggest me how to get that output using regex. i.e. Can this
happen by making change in regex I used in code??

From: hotkitty, Rob Dixon, Dr.Ruud, Gunnar Hjalmarsson First and foremost thanks for all the help I've received on this
board, especially Gunnar who keeps this place running!

I've come a long way in my code and am trying to format some text and
then put it into a nice pdf file. My problem is putting the formatted
text into the pdf and for it to display correctly. I am just trying to
justify the text and then set the margins. I can put the text in the
pdf and it looks like it is trying to justify it but it won't wrap to
the next line. I've looked at the documentation for both the
Text::Autoformat and PDF::API2 modules but can't seem to figure it
out.

I have 2 questions: 1. What am I doing wrong in that the text will
appear fine when I "print" it but that it won't appear correctly in
the pdf file? 2. Also, if the text is more than 1 page, how can I get
it to automatically create a new page and continue onto the newly
created page?

My code:


#!/usr/bin/perl

use warnings;

use LWP::Simple;
use HTML::TokeParser;
use PDF::API2;
use Text::Autoformat;


# Print out the subtitle

my $oldtext = "trying to test if this sentence will be formatted the
correct way when it appears in the pdf file. For some reason I just
can't seem to get this to work. Well, maybe I can find help to get
this working. If I could get it to work it would really make my kitty
purrrr";

my $newtext = autoformat $oldtext, { left=>8, right=>70, justify =>
'full' };
print $newtext;

#----create the pdf file----->
my $file = "This PDF";
my $pdf = PDF::API2->new( -file => "$file.pdf" );
my $page = $pdf->page;
$page->mediabox ('A4');
$page->bleedbox(25,25,5,10);
$page->cropbox (7.5,7.5,97.5,120.5);
my %font = (
Helvetica => {
Bold => $pdf->corefont( 'Helvetica-Bold', -encoding =>
'latin1' ),
Roman => $pdf->corefont( 'Helvetica', -encoding =>
'latin1' ),
Italic => $pdf->corefont( 'Helvetica-Oblique', -encoding =>
'latin1' ),
},
Times => {
Bold => $pdf->corefont( 'Times-Bold', -encoding =>
'latin1' ),
Roman => $pdf->corefont( 'Times', -encoding =>
'latin1' ),
Italic => $pdf->corefont( 'Times-Italic', -encoding =>
'latin1' ),
},
);

my $main_text = $page->text;
$main_text->font( $font{'Times'}{'Roman'}, 2 );
$main_text->fillcolor('black');
$main_text->translate( 5, 100 );
$main_text->text("$newtext");

$pdf->save;
$pdf->end();