From: Jarkko Hietaniemi Date: Thu, 4 Oct 2001 22:54:06 +0000 (+0000) Subject: Retract #12313 and #12249. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=84f709e736e1ecec2cb204663711a2f0ea2f0e83;p=p5sagit%2Fp5-mst-13.2.git Retract #12313 and #12249. p4raw-id: //depot/perl@12338 --- diff --git a/pod/perlboot.pod b/pod/perlboot.pod index ff6f1af..8eaac86 100644 --- a/pod/perlboot.pod +++ b/pod/perlboot.pod @@ -44,8 +44,8 @@ packages, and called using the full package name. So let's create an entire pasture: # Cow::speak, Horse::speak, Sheep::speak as before - my @pasture = qw(Cow Cow Horse Sheep Sheep); - foreach my $animal (@pasture) { + @pasture = qw(Cow Cow Horse Sheep Sheep); + foreach $animal (@pasture) { &{$animal."::speak"}; } @@ -58,10 +58,10 @@ This results in: a Sheep goes baaaah! Wow. That symbolic coderef de-referencing there is pretty nasty. -We're counting on L> mode, certainly not -recommended for larger programs. And why was that necessary? Because -the name of the package seems to be inseparable from the name of the -subroutine we want to invoke within that package. +We're counting on C mode, certainly not recommended +for larger programs. And why was that necessary? Because the name of +the package seems to be inseparable from the name of the subroutine we +want to invoke within that package. Or is it? @@ -87,13 +87,12 @@ And once again, this results in: That's not fun yet. Same number of characters, all constant, no variables. But yet, the parts are separable now. Watch: - my $a = "Cow"; + $a = "Cow"; $a->speak; # invokes Cow->speak Ahh! Now that the package name has been parted from the subroutine name, we can use a variable package name. And this time, we've got -something that works even when L> is -enabled. +something that works even when C is enabled. =head2 Invoking a barnyard @@ -110,8 +109,8 @@ example: print "a Sheep goes baaaah!\n" } - my @pasture = qw(Cow Cow Horse Sheep Sheep); - foreach my $animal (@pasture) { + @pasture = qw(Cow Cow Horse Sheep Sheep); + foreach $animal (@pasture) { $animal->speak; } @@ -169,14 +168,11 @@ the same class. Let's call out from C to a helper method called C. This method provides the constant text for the sound itself. - { - package Cow; - + { package Cow; sub sound { "moooo" } - sub speak { - my $class = shift; - print "a $class goes ", $class->sound, "!\n" + my $class = shift; + print "a $class goes ", $class->sound, "!\n" } } @@ -184,11 +180,8 @@ Now, when we call C<< Cow->speak >>, we get a C<$class> of C in C. This in turn selects the C<< Cow->sound >> method, which returns C. But how different would this be for the C? - { - package Horse; - + { package Horse; sub sound { "neigh" } - sub speak { my $class = shift; print "a $class goes ", $class->sound, "!\n" @@ -204,9 +197,7 @@ Horse? Yes, with inheritance! We'll define a common subroutine package called C, with the definition for C: - { - package Animal; - + { package Animal; sub speak { my $class = shift; print "a $class goes ", $class->sound, "!\n" @@ -216,12 +207,8 @@ definition for C: Then, for each animal, we say it "inherits" from C, along with the animal-specific sound: - { - package Cow; - - # Not safe under `use strict', see below + { package Cow; @ISA = qw(Animal); - sub sound { "moooo" } } @@ -269,34 +256,32 @@ The easiest is to just spell the package name out: Or allow it as an implicitly named package variable: package Cow; - our @ISA = qw(Animal); + use vars qw(@ISA); + @ISA = qw(Animal); If you're bringing in the class from outside, via an object-oriented module, you change: package Cow; use Animal; - our @ISA = qw(Animal); + use vars qw(@ISA); + @ISA = qw(Animal); into just: package Cow; use base qw(Animal); -And that's pretty darn compact. Read about the L pragma. +And that's pretty darn compact. =head2 Overriding the methods Let's add a mouse, which can barely be heard: - # Animal package that we wrote before, goes here - { - package Mouse; - - our @ISA = qw(Animal); - + # Animal package from before + { package Mouse; + @ISA = qw(Animal); sub sound { "squeak" } - sub speak { my $class = shift; print "a $class goes ", $class->sound, "!\n"; @@ -324,14 +309,10 @@ C does, but add in the extra comment? Sure! First, we can invoke the C method directly: - # Animal package that we wrote before, goes here - { - package Mouse; - - our @ISA = qw(Animal); - + # Animal package from before + { package Mouse; + @ISA = qw(Animal); sub sound { "squeak" } - sub speak { my $class = shift; Animal::speak($class); @@ -364,11 +345,8 @@ A better solution is to tell Perl to search from a higher place in the inheritance chain: # same Animal as before - { - package Mouse; - + { package Mouse; # same @ISA, &sound as before - sub speak { my $class = shift; $class->Animal::speak; @@ -394,11 +372,8 @@ invocation, we get a search of all of our super classes (classes listed in C<@ISA>) automatically: # same Animal as before - { - package Mouse; - + { package Mouse; # same @ISA, &sound as before - sub speak { my $class = shift; $class->SUPER::speak; @@ -417,7 +392,7 @@ So far, we've seen the method arrow syntax: or the equivalent: - my $a = "Class"; + $a = "Class"; $a->method(@args); which constructs an argument list of: @@ -444,20 +419,14 @@ haven't even begun to cover. Let's start with the code for the C class and the C class: - { - package Animal; - + { package Animal; sub speak { my $class = shift; print "a $class goes ", $class->sound, "!\n" } } - - { - package Horse; - - our @ISA = qw(Animal); - + { package Horse; + @ISA = qw(Animal); sub sound { "neigh" } } @@ -479,7 +448,7 @@ An "instance" is generally created by a class. In Perl, any reference can be an instance, so let's start with the simplest reference that can hold a horse's name: a scalar reference. - my $name = "Mr. Ed"; + my $name = "Mr. Ed"; my $talking = \$name; So now C<$talking> is a reference to what will be the instance-specific @@ -530,13 +499,9 @@ Because we get the instance as the first parameter, we can now access the instance-specific data. In this case, let's add a way to get at the name: - { - package Horse; - - our @ISA = qw(Animal); - + { package Horse; + @ISA = qw(Animal); sub sound { "neigh" } - sub name { my $self = shift; $$self; @@ -565,21 +530,16 @@ guts" of a Horse are visible. That's good if you're a veterinarian, but not if you just like to own horses. So, let's let the Horse class build a new horse: - { - package Horse; - - our @ISA = qw(Animal); - + { package Horse; + @ISA = qw(Animal); sub sound { "neigh" } - sub name { my $self = shift; $$self; } - sub named { my $class = shift; - my $name = shift; + my $name = shift; bless \$name, $class; } } @@ -610,31 +570,23 @@ But was there anything specific to C in that method? No. Therefore, it's also the same recipe for building anything else that inherited from C, so let's put it there: - { - package Animal; - + { package Animal; sub speak { my $class = shift; print "a $class goes ", $class->sound, "!\n" } - sub name { my $self = shift; $$self; } - sub named { my $class = shift; - my $name = shift; + my $name = shift; bless \$name, $class; } } - - { - package Horse; - - our @ISA = qw(Animal); - + { package Horse; + @ISA = qw(Animal); sub sound { "neigh" } } @@ -663,7 +615,7 @@ classname). Let's modify the C method first to notice the change: sub name { my $either = shift; ref $either - ? $$either # it's an instance, return name + ? $$either # it's an instance, return name : "an unnamed $either"; # it's a class, return generic } @@ -673,8 +625,7 @@ instance or a class. Note that I've changed the first parameter holder to C<$either> to show that this is intended: my $talking = Horse->named("Mr. Ed"); - - print Horse->name, "\n"; # prints "an unnamed Horse\n" + print Horse->name, "\n"; # prints "an unnamed Horse\n" print $talking->name, "\n"; # prints "Mr Ed.\n" and now we'll fix C to use this: @@ -691,46 +642,34 @@ we're done! Let's train our animals to eat: - { - package Animal; + { package Animal; sub named { my $class = shift; - my $name = shift; + my $name = shift; bless \$name, $class; } - sub name { my $either = shift; ref $either - ? $$either # it's an instance, return name + ? $$either # it's an instance, return name : "an unnamed $either"; # it's a class, return generic } - sub speak { my $either = shift; print $either->name, " goes ", $either->sound, "\n"; } - sub eat { my $either = shift; - my $food = shift; + my $food = shift; print $either->name, " eats $food.\n"; } } - - { - package Horse; - - our @ISA = qw(Animal); - + { package Horse; + @ISA = qw(Animal); sub sound { "neigh" } } - - { - package Sheep; - - our @ISA = qw(Animal); - + { package Sheep; + @ISA = qw(Animal); sub sound { "baaaah" } } @@ -738,7 +677,6 @@ And now try it out: my $talking = Horse->named("Mr. Ed"); $talking->eat("hay"); - Sheep->eat("grass"); which prints: @@ -767,8 +705,7 @@ looks at the reference is changed accordingly. Let's make a sheep that has a name and a color: - my $data = { Name => "Evil", Color => "black" }; - my $bad = bless $data, Sheep; + my $bad = bless { Name => "Evil", Color => "black" }, Sheep; so C<< $bad->{Name} >> has C, and C<< $bad->{Color} >> has C. But we want to make C<< $bad->name >> access the name, and @@ -789,9 +726,8 @@ as well: ## in Animal sub named { my $class = shift; - my $name = shift; - my $self = { Name => $name, Color => $class->default_color }; - + my $name = shift; + my $self = { Name => $name, Color => $class->default_color }; bless $self, $class; } @@ -822,7 +758,6 @@ method or two to get and set the color. sub color { $_[0]->{Color} } - sub set_color { $_[0]->{Color} = $_[1]; } diff --git a/pod/perlbot.pod b/pod/perlbot.pod index 17b3755..bc4e4da 100644 --- a/pod/perlbot.pod +++ b/pod/perlbot.pod @@ -82,13 +82,11 @@ variables. Named parameters are also demonstrated. package Foo; sub new { - my $type = shift; + my $type = shift; my %params = @_; - my $self = {}; - - $self->{High} = $params{High}; - $self->{Low} = $params{Low}; - + my $self = {}; + $self->{'High'} = $params{'High'}; + $self->{'Low'} = $params{'Low'}; bless $self, $type; } @@ -96,25 +94,23 @@ variables. Named parameters are also demonstrated. package Bar; sub new { - my $type = shift; + my $type = shift; my %params = @_; - my $self = []; - - $self->[0] = $params{Left}; - $self->[1] = $params{Right}; - + my $self = []; + $self->[0] = $params{'Left'}; + $self->[1] = $params{'Right'}; bless $self, $type; } package main; - my $a = Foo->new( High => 42, Low => 11 ); - print "High = $a->{High}\n"; - print "Low = $a->{Low}\n"; + $a = Foo->new( 'High' => 42, 'Low' => 11 ); + print "High=$a->{'High'}\n"; + print "Low=$a->{'Low'}\n"; - my $b = Bar->new( Left => 78, Right => 40 ); - print "Left = $b->[0]\n"; - print "Right = $b->[1]\n"; + $b = Bar->new( 'Left' => 78, 'Right' => 40 ); + print "Left=$b->[0]\n"; + print "Right=$b->[1]\n"; =head1 SCALAR INSTANCE VARIABLES @@ -124,15 +120,15 @@ An anonymous scalar can be used when only one instance variable is needed. sub new { my $type = shift; - my $self = shift; - + my $self; + $self = shift; bless \$self, $type; } package main; - my $a = Foo->new( 42 ); - print "a = $$a\n"; + $a = Foo->new( 42 ); + print "a=$$a\n"; =head1 INSTANCE VARIABLE INHERITANCE @@ -147,29 +143,25 @@ object. sub new { my $type = shift; my $self = {}; - - $self->{buz} = 42; - + $self->{'buz'} = 42; bless $self, $type; } package Foo; - our @ISA = qw( Bar ); + @ISA = qw( Bar ); sub new { my $type = shift; my $self = Bar->new; - - $self->{biz} = 11; - + $self->{'biz'} = 11; bless $self, $type; } package main; - my $a = Foo->new; - print "buz = $a->{buz}\n"; - print "biz = $a->{biz}\n"; + $a = Foo->new; + print "buz = ", $a->{'buz'}, "\n"; + print "biz = ", $a->{'biz'}, "\n"; @@ -183,9 +175,7 @@ relationships between objects. sub new { my $type = shift; my $self = {}; - - $self->{buz} = 42; - + $self->{'buz'} = 42; bless $self, $type; } @@ -194,18 +184,16 @@ relationships between objects. sub new { my $type = shift; my $self = {}; - - $self->{Bar} = Bar->new; - $self->{biz} = 11; - + $self->{'Bar'} = Bar->new; + $self->{'biz'} = 11; bless $self, $type; } package main; - my $a = Foo->new; - print "buz = $a->{Bar}->{buz}\n"; - print "biz = $a->{biz}\n"; + $a = Foo->new; + print "buz = ", $a->{'Bar'}->{'buz'}, "\n"; + print "biz = ", $a->{'biz'}, "\n"; @@ -219,17 +207,14 @@ where that method is defined. package Buz; sub goo { print "here's the goo\n" } - - package Bar; - our @ISA = qw( Buz ); + package Bar; @ISA = qw( Buz ); sub google { print "google here\n" } - package Baz; sub mumble { print "mumbling\n" } package Foo; - our @ISA = qw( Bar Baz ); + @ISA = qw( Bar Baz ); sub new { my $type = shift; @@ -251,7 +236,7 @@ where that method is defined. package main; - my $foo = Foo->new; + $foo = Foo->new; $foo->mumble; $foo->grr; $foo->goo; @@ -265,28 +250,24 @@ This example demonstrates an interface for the SDBM class. This creates a package Mydbm; - use SDBM_File; - use Tie::Hash; - - our @ISA = qw( Tie::Hash ); + require SDBM_File; + require Tie::Hash; + @ISA = qw( Tie::Hash ); sub TIEHASH { my $type = shift; my $ref = SDBM_File->new(@_); - bless { dbm => $ref }, $type; + bless {'dbm' => $ref}, $type; } - sub FETCH { my $self = shift; - my $ref = $self->{dbm}; + my $ref = $self->{'dbm'}; $ref->FETCH(@_); } - sub STORE { my $self = shift; - - if ( defined $_[0] ) { - my $ref = $self->{dbm}; + if (defined $_[0]){ + my $ref = $self->{'dbm'}; $ref->STORE(@_); } else { die "Cannot STORE an undefined key in Mydbm\n"; @@ -296,13 +277,13 @@ This example demonstrates an interface for the SDBM class. This creates a package main; use Fcntl qw( O_RDWR O_CREAT ); - tie my %foo, 'Mydbm', 'Sdbm', O_RDWR|O_CREAT, 0640; - $foo{bar} = 123; - print "foo-bar = $foo{bar}\n"; + tie %foo, "Mydbm", "Sdbm", O_RDWR|O_CREAT, 0640; + $foo{'bar'} = 123; + print "foo-bar = $foo{'bar'}\n"; - tie my %bar, 'Mydbm', 'Sdbm2', O_RDWR|O_CREAT, 0640; - $bar{Cathy} = 456; - print "bar-Cathy = $bar{Cathy}\n"; + tie %bar, "Mydbm", "Sdbm2", O_RDWR|O_CREAT, 0640; + $bar{'Cathy'} = 456; + print "bar-Cathy = $bar{'Cathy'}\n"; =head1 THINKING OF CODE REUSE @@ -320,7 +301,6 @@ that it is impossible to override the BAZ() method. my $type = shift; bless {}, $type; } - sub bar { my $self = shift; $self->FOO::private::BAZ; @@ -334,7 +314,7 @@ that it is impossible to override the BAZ() method. package main; - my $a = FOO->new; + $a = FOO->new; $a->bar; Now we try to override the BAZ() method. We would like FOO::bar() to call @@ -347,7 +327,6 @@ FOO::private::BAZ(). my $type = shift; bless {}, $type; } - sub bar { my $self = shift; $self->FOO::private::BAZ; @@ -360,9 +339,7 @@ FOO::private::BAZ(). } package GOOP; - - our @ISA = qw( FOO ); - + @ISA = qw( FOO ); sub new { my $type = shift; bless {}, $type; @@ -374,7 +351,7 @@ FOO::private::BAZ(). package main; - my $a = GOOP->new; + $a = GOOP->new; $a->bar; To create reusable code we must modify class FOO, flattening class @@ -387,7 +364,6 @@ method GOOP::BAZ() to be used in place of FOO::BAZ(). my $type = shift; bless {}, $type; } - sub bar { my $self = shift; $self->BAZ; @@ -398,21 +374,19 @@ method GOOP::BAZ() to be used in place of FOO::BAZ(). } package GOOP; - - our @ISA = qw( FOO ); + @ISA = qw( FOO ); sub new { my $type = shift; bless {}, $type; } - sub BAZ { print "in GOOP::BAZ\n"; } package main; - my $a = GOOP->new; + $a = GOOP->new; $a->bar; =head1 CLASS CONTEXT AND THE OBJECT @@ -435,12 +409,12 @@ method where that data is located. package Bar; - my %fizzle = ( Password => 'XYZZY' ); + %fizzle = ( 'Password' => 'XYZZY' ); sub new { my $type = shift; my $self = {}; - $self->{fizzle} = \%fizzle; + $self->{'fizzle'} = \%fizzle; bless $self, $type; } @@ -451,29 +425,27 @@ method where that data is located. # or %Foo::fizzle. The object already knows which # we should use, so just ask it. # - my $fizzle = $self->{fizzle}; + my $fizzle = $self->{'fizzle'}; - print "The word is $fizzle->{Password}\n"; + print "The word is ", $fizzle->{'Password'}, "\n"; } package Foo; + @ISA = qw( Bar ); - our @ISA = qw( Bar ); - - my %fizzle = ( Password => 'Rumple' ); + %fizzle = ( 'Password' => 'Rumple' ); sub new { my $type = shift; my $self = Bar->new; - $self->{fizzle} = \%fizzle; + $self->{'fizzle'} = \%fizzle; bless $self, $type; } package main; - my $a = Bar->new; - my $b = Foo->new; - + $a = Bar->new; + $b = Foo->new; $a->enter; $b->enter; @@ -496,8 +468,7 @@ object will be a BAR not a FOO, even though the constructor is in class FOO. } package BAR; - - our @ISA = qw(FOO); + @ISA = qw(FOO); sub baz { print "in BAR::baz()\n"; @@ -505,7 +476,7 @@ object will be a BAR not a FOO, even though the constructor is in class FOO. package main; - my $a = BAR->new; + $a = BAR->new; $a->baz; =head1 DELEGATION @@ -522,16 +493,14 @@ behavior by adding custom FETCH() and STORE() methods, if this is desired. package Mydbm; - use SDBM_File; - use Tie::Hash; - - our @ISA = qw( Tie::Hash ); - our $AUTOLOAD; + require SDBM_File; + require Tie::Hash; + @ISA = qw(Tie::Hash); sub TIEHASH { my $type = shift; - my $ref = SDBM_File->new(@_); - bless { delegate => $ref }; + my $ref = SDBM_File->new(@_); + bless {'delegate' => $ref}; } sub AUTOLOAD { @@ -547,12 +516,12 @@ behavior by adding custom FETCH() and STORE() methods, if this is desired. $AUTOLOAD =~ s/^Mydbm:://; # Pass the message to the delegate. - $self->{delegate}->$AUTOLOAD(@_); + $self->{'delegate'}->$AUTOLOAD(@_); } package main; use Fcntl qw( O_RDWR O_CREAT ); - tie my %foo, 'Mydbm', 'adbm', O_RDWR|O_CREAT, 0640; - $foo{bar} = 123; - print "foo-bar = $foo{bar}\n"; + tie %foo, "Mydbm", "adbm", O_RDWR|O_CREAT, 0640; + $foo{'bar'} = 123; + print "foo-bar = $foo{'bar'}\n"; diff --git a/pod/perlcall.pod b/pod/perlcall.pod index d072f00..40f1d65 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -259,15 +259,13 @@ occur when the code that is executing the I function has itself been called from another Perl subroutine. The code below illustrates this - sub fred { - print "@_\n"; - } + sub fred + { print "@_\n" } - sub joe { - &fred; - } + sub joe + { &fred } - &joe(1,2,3); + &joe(1,2,3) ; This will print @@ -394,9 +392,11 @@ XSUB, the program will immediately terminate. For example, say you want to call this Perl sub - sub fred { - eval { die "Fatal Error" } - print "Trapped error: $@\n" if $@; + sub fred + { + eval { die "Fatal Error" ; } + print "Trapped error: $@\n" + if $@ ; } via this XSUB @@ -450,8 +450,9 @@ I for details. This first trivial example will call a Perl subroutine, I, to print out the UID of the process. - sub PrintUID { - print "UID is $<\n"; + sub PrintUID + { + print "UID is $<\n" ; } and here is a C function to call it @@ -510,9 +511,10 @@ print the first $n characters of the string. So the Perl subroutine would look like this - sub LeftString { - my($s, $n) = @_ ; - print substr($s, 0, $n), "\n"; + sub LeftString + { + my($s, $n) = @_ ; + print substr($s, 0, $n), "\n" ; } The C function required to call I would look like this. @@ -641,9 +643,10 @@ subroutine. Here is a Perl subroutine, I, that takes 2 integer parameters and simply returns their sum. - sub Adder { - my($a, $b) = @_; - $a + $b; + sub Adder + { + my($a, $b) = @_ ; + $a + $b ; } Because we are now concerned with the return value from I, the C @@ -745,9 +748,10 @@ parameters and the difference. Here is the Perl subroutine - sub AddSubtract { - my($a, $b) = @_; - ($a+$b, $a-$b); + sub AddSubtract + { + my($a, $b) = @_ ; + ($a+$b, $a-$b) ; } and this is the C function @@ -870,9 +874,10 @@ whether it is actually desirable to do it is another matter entirely. The Perl subroutine, I, below takes 2 parameters and increments each directly. - sub Inc { - ++$_[0]; - ++$_[1]; + sub Inc + { + ++ $_[0] ; + ++ $_[1] ; } and here is a C function to call it. @@ -928,12 +933,13 @@ Now an example using G_EVAL. Below is a Perl subroutine which computes the difference of its 2 parameters. If this would result in a negative result, the subroutine calls I. - sub Subtract { - my ($a, $b) = @_; + sub Subtract + { + my ($a, $b) = @_ ; - die "death can be fatal\n" if $a < $b; + die "death can be fatal\n" if $a < $b ; - $a - $b; + $a - $b ; } and some C to call it @@ -1035,21 +1041,16 @@ Consider this rather facetious example, where we have used an XS version of the call_Subtract example above inside a destructor: package Foo; - - sub new { bless {}, shift } - + sub new { bless {}, $_[0] } sub Subtract { - my($a,$b) = @_; - die "death can be fatal" if $a < $b; - $a - $b; + my($a,$b) = @_; + die "death can be fatal" if $a < $b ; + $a - $b; } - - sub DESTROY { call_Subtract(5, 4) } - sub foo { die "foo dies" } - + sub DESTROY { call_Subtract(5, 4); } + sub foo { die "foo dies"; } package main; - eval { Foo->new->foo }; print "Saw: $@" if $@; # should be, but isn't @@ -1076,11 +1077,12 @@ within the Perl script. Consider the Perl code below - sub fred { - print "Hello there\n"; + sub fred + { + print "Hello there\n" ; } - CallSubPV("fred"); + CallSubPV("fred") ; Here is a snippet of XSUB which defines I. @@ -1109,12 +1111,11 @@ I instead of I. Because we are using an SV to call I the following can all be used - CallSubSV("fred"); - CallSubSV(\&fred); - - my $ref = \&fred; - CallSubSV($ref); - CallSubSV( sub { print "Hello there\n" } ); + CallSubSV("fred") ; + CallSubSV(\&fred) ; + $ref = \&fred ; + CallSubSV($ref) ; + CallSubSV( sub { print "Hello there\n" } ) ; As you can see, I gives you much greater flexibility in how you can specify the Perl subroutine. @@ -1143,11 +1144,11 @@ pointer C in C, it may or may not still refer to the Perl subroutine that was recorded in C. This is particularly true for these cases - SaveSub1(\&fred); - CallSavedSub1(); + SaveSub1(\&fred) ; + CallSavedSub1() ; - SaveSub1( sub { print "Hello there\n" } ); - CallSavedSub1(); + SaveSub1( sub { print "Hello there\n" } ) ; + CallSavedSub1() ; By the time each of the C statements above have been executed, the SV*s which corresponded to the parameters will no longer exist. @@ -1159,11 +1160,10 @@ for each of the C lines. Similarly, with this code - my $ref = \&fred; - SaveSub1($ref); - - $ref = 47; - CallSavedSub1(); + $ref = \&fred ; + SaveSub1($ref) ; + $ref = 47 ; + CallSavedSub1() ; you can expect one of these messages (which you actually get is dependent on the version of Perl you are using) @@ -1183,11 +1183,10 @@ loudly. A similar but more subtle problem is illustrated with this code - my $ref = \&fred; - SaveSub1($ref); - - $ref = \&joe; - CallSavedSub1(); + $ref = \&fred ; + SaveSub1($ref) ; + $ref = \&joe ; + CallSavedSub1() ; This time whenever C get called it will execute the Perl subroutine C (assuming it exists) rather than C as was @@ -1229,12 +1228,11 @@ C. Here is a Perl subroutine which prints whatever parameters are passed to it. - sub PrintList { - my @list = @_; + sub PrintList + { + my(@list) = @_ ; - foreach (@list) { - print "$_\n"; - } + foreach (@list) { print "$_\n" } } and here is an example of I which will call @@ -1258,22 +1256,25 @@ This is because I will do it for you. Consider the following Perl code { - package Mine ; - - sub new { - my $type = shift; - bless [@_], $type; - } - - sub Display { - my ($self, $index) = @_; - print "$index: $self->[$index]\n"; - } - - sub PrintID { - my $class = shift; - print "This is Class $class version 1.0\n"; - } + package Mine ; + + sub new + { + my($type) = shift ; + bless [@_] + } + + sub Display + { + my ($self, $index) = @_ ; + print "$index: $$self[$index]\n" ; + } + + sub PrintID + { + my($class) = @_ ; + print "This is Class $class version 1.0\n" ; + } } It implements just a very simple class to manage an array. Apart from @@ -1282,10 +1283,9 @@ virtual. The static method, C, prints out simply the class name and a version number. The virtual method, C, prints out a single element of the array. Here is an all Perl example of using it. - my $a = Mine->new('red', 'green', 'blue'); - $a->Display(1); - - Mine->PrintID; + $a = new Mine ('red', 'green', 'blue') ; + $a->Display(1) ; + PrintID Mine; will print @@ -1342,9 +1342,9 @@ the C and C methods from C. So the methods C and C can be invoked like this - my $a = Mine->new('red', 'green', 'blue'); - call_Method($a, 'Display', 1); - call_PrintID('Mine', 'PrintID'); + $a = new Mine ('red', 'green', 'blue') ; + call_Method($a, 'Display', 1) ; + call_PrintID('Mine', 'PrintID') ; The only thing to note is that in both the static and virtual methods, the method name is not passed via the stack--it is used as the first @@ -1369,8 +1369,8 @@ currently executing. and here is some Perl to test it PrintContext ; - my $a = PrintContext; - my @a = PrintContext; + $a = PrintContext ; + @a = PrintContext ; The output from that will be @@ -1551,8 +1551,9 @@ registers, C, might look like this # Register the sub pcb1 register_fatal(\&pcb1) ; - sub pcb1 { - die "I'm dying...\n"; + sub pcb1 + { + die "I'm dying...\n" ; } The mapping between the C callback and the Perl equivalent is stored in @@ -1651,14 +1652,15 @@ the entry from the hash C. So the Perl interface would look like this - sub callback1 { - my($handle, $buffer) = @_; + sub callback1 + { + my($handle, $buffer) = @_ ; } # Register the Perl callback - asynch_read($fh, \&callback1); + asynch_read($fh, \&callback1) ; - asynch_close($fh); + asynch_close($fh) ; The mapping between the C callback and Perl is stored in the global hash C this time. Using a hash has the distinct advantage that diff --git a/pod/perldata.pod b/pod/perldata.pod index 9155abc..968588d 100644 --- a/pod/perldata.pod +++ b/pod/perldata.pod @@ -224,7 +224,7 @@ by assigning to an element that is off the end of the array. You can truncate an array down to nothing by assigning the null list () to it. The following are equivalent: - my @whatever = (); + @whatever = (); $#whatever = -1; If you evaluate an array in scalar context, it returns the length @@ -233,6 +233,13 @@ the last value, like the C comma operator, nor of built-in functions, which return whatever they feel like returning.) The following is always true: + scalar(@whatever) == $#whatever - $[ + 1; + +Version 5 of Perl changed the semantics of C<$[>: files that don't set +the value of C<$[> no longer need to worry about whether another +file changed its value. (In other words, use of C<$[> is deprecated.) +So in general you can assume that + scalar(@whatever) == $#whatever + 1; Some programmers choose to use an explicit conversion so as to @@ -254,7 +261,6 @@ of sixteen buckets has been touched, and presumably contains all You can preallocate space for a hash by assigning to the keys() function. This rounds up the allocated buckets to the next power of two: - my %users = (); keys(%users) = 1000; # allocate 1024 buckets =head2 Scalar value constructors @@ -300,8 +306,8 @@ names beginning with $ or @, followed by an optional bracketed expression as a subscript.) The following code segment prints out "The price is $Z<>100." - my $Price = '$100'; # not interpolated - print "The price is $Price.\n"; # interpolated + $Price = '$100'; # not interpreted + print "The price is $Price.\n"; # interpreted As in some shells, you can enclose the variable name in braces to disambiguate it from following alphanumerics (and underscores). @@ -310,7 +316,7 @@ this when interpolating a variable into a string to separate the variable name from a following double-colon or an apostrophe, since these would be otherwise treated as a package separator: - my $who = "Larry"; + $who = "Larry"; print PASSWD "${who}::0:0:Superuser:/:/bin/perl\n"; print "We use ${who}speak when ${who}'s here.\n"; @@ -393,7 +399,7 @@ by joining the elements with the delimiter specified in the C<$"> variable (C<$LIST_SEPARATOR> in English), space by default. The following are equivalent: - my $temp = join($", @ARGV); + $temp = join($", @ARGV); system "echo $temp"; system "echo @ARGV"; @@ -460,7 +466,7 @@ If you want your here-docs to be indented with the rest of the code, you'll need to remove leading whitespace from each line manually: - (my $quote = <<'FINIS') =~ s/^\s+//gm; + ($quote = <<'FINIS') =~ s/^\s+//gm; The Road goes ever on and on, down from the door where it began. FINIS @@ -509,23 +515,23 @@ In a context not requiring a list value, the value of what appears to be a list literal is simply the value of the final element, as with the C comma operator. For example, - my @foo = ('cc', '-E', $bar); + @foo = ('cc', '-E', $bar); assigns the entire list value to array @foo, but - my $foo = ('cc', '-E', $bar); + $foo = ('cc', '-E', $bar); assigns the value of variable $bar to the scalar variable $foo. Note that the value of an actual array in scalar context is the length of the array; the following assigns the value 3 to $foo: - my @foo = ('cc', '-E', $bar); - my $foo = @foo; # $foo gets 3 + @foo = ('cc', '-E', $bar); + $foo = @foo; # $foo gets 3 You may have an optional comma before the closing parenthesis of a list literal, so that you can say: - my @foo = ( + @foo = ( 1, 2, 3, @@ -534,7 +540,7 @@ list literal, so that you can say: To use a here-document to assign an array, one line per element, you might use an approach like this: - my @sauces = < in a list. This is useful for throwing away some of the return values of a function: - my($dev, $ino, undef, undef, $uid, $gid) = stat($file); + ($dev, $ino, undef, undef, $uid, $gid) = stat($file); List assignment in scalar context returns the number of elements produced by the expression on the right side of the assignment: - my $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2 - my $x = (($foo,$bar) = f()); # set $x to f()'s return count + $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2 + $x = (($foo,$bar) = f()); # set $x to f()'s return count This is handy when you want to do a list assignment in a Boolean context, because most list functions return a null list when finished, @@ -612,7 +618,7 @@ performing an operation in list context and then counting the number of return values, by assigning to an empty list and then using that assignment in scalar context. For example, this code: - my $count = () = $string =~ /\d+/g; + $count = () = $string =~ /\d+/g; will place into $count the number of digit groups found in $string. This happens because the pattern match is in list context (since it @@ -622,15 +628,14 @@ context will translate that into the number of elements (here, the number of times the pattern matched) and assign that to $count. Note that simply using - my $count = $string =~ /\d+/g; + $count = $string =~ /\d+/g; would not have worked, since a pattern match in scalar context will only return true or false, rather than a count of matches. The final element of a list assignment may be an array or a hash: - my($a, $b, @rest) = split; - # or + ($a, $b, @rest) = split; my($a, $b, %rest) = @_; You can actually put an array or hash anywhere in the list, but the first one @@ -641,7 +646,7 @@ A hash can be initialized using a literal list holding pairs of items to be interpreted as a key and a value: # same as map assignment above - my %map = ('red',0x00f,'blue',0x0f0,'green',0xf00); + %map = ('red',0x00f,'blue',0x0f0,'green',0xf00); While literal lists and named arrays are often interchangeable, that's not the case for hashes. Just because you can subscript a list value like @@ -656,7 +661,7 @@ synonym for a comma, but it also arranges for its left-hand operand to be interpreted as a string--if it's a bareword that would be a legal identifier. This makes it nice for initializing hashes: - my %map = ( + %map = ( red => 0x00f, blue => 0x0f0, green => 0xf00, @@ -664,7 +669,7 @@ This makes it nice for initializing hashes: or for initializing hash references to be used as records: - my $rec = { + $rec = { witch => 'Mable the Merciless', cat => 'Fluffy the Ferocious', date => '10/31/1776', @@ -672,14 +677,12 @@ or for initializing hash references to be used as records: or for using call-by-named-parameter to complicated functions: - use CGI; - my $query = CGI->new; - my $field = $query->radio_group( + $field = $query->radio_group( name => 'group_name', values => ['eenie','meenie','minie'], default => 'meenie', linebreak => 'true', - labels => \%labels, + labels => \%labels ); Note that just because a hash is initialized in that order doesn't @@ -691,36 +694,34 @@ of how to arrange for an output ordering. A common way to access an array or a hash is one scalar element at a time. You can also subscript a list to get a single element from it. - my $whoami = $ENV{"USER"}; # one element from the hash - my $parent = $ISA[0]; # one element from the array - my $dir = (getpwnam("daemon"))[7]; # likewise, but with list + $whoami = $ENV{"USER"}; # one element from the hash + $parent = $ISA[0]; # one element from the array + $dir = (getpwnam("daemon"))[7]; # likewise, but with list A slice accesses several elements of a list, an array, or a hash simultaneously using a list of subscripts. It's more convenient than writing out the individual elements as a list of separate scalar values. - my($him, $her) = @folks[0,-1]; # array slice - my @them = @folks[0 .. 3]; # array slice - my($who, $home) = @ENV{"USER", "HOME"}; # hash slice - my($uid, $dir) = (getpwnam("daemon"))[2,7]; # list slice + ($him, $her) = @folks[0,-1]; # array slice + @them = @folks[0 .. 3]; # array slice + ($who, $home) = @ENV{"USER", "HOME"}; # hash slice + ($uid, $dir) = (getpwnam("daemon"))[2,7]; # list slice Since you can assign to a list of variables, you can also assign to an array or hash slice. - my( @days, %colors, @folks ); - @days[3..5] = qw(Wed Thu Fri); + @days[3..5] = qw/Wed Thu Fri/; @colors{'red','blue','green'} = (0xff0000, 0x0000ff, 0x00ff00); @folks[0, -1] = @folks[-1, 0]; The previous assignments are exactly equivalent to - my( @days, %colors, @folks ); - ($days[3], $days[4], $days[5]) = qw(Wed Thu Fri); - ($colors{red}, $colors{blue}, $colors{green}) + ($days[3], $days[4], $days[5]) = qw/Wed Thu Fri/; + ($colors{'red'}, $colors{'blue'}, $colors{'green'}) = (0xff0000, 0x0000ff, 0x00ff00); - ($folks[0], $folks[-1]) = ($folks[-1], $folks[0]); + ($folks[0], $folks[-1]) = ($folks[0], $folks[-1]); Since changing a slice changes the original array or hash that it's slicing, a C construct will alter some--or even all--of the @@ -736,19 +737,19 @@ values of the array or hash. A slice of an empty list is still an empty list. Thus: - my @a = ()[1,0]; # @a has no elements - my @b = (@a)[0,1]; # @b has no elements - my @c = (0,1)[2,3]; # @c has no elements + @a = ()[1,0]; # @a has no elements + @b = (@a)[0,1]; # @b has no elements + @c = (0,1)[2,3]; # @c has no elements But: - my @a = (1)[1,0]; # @a has two elements - my @b = (1,undef)[1,0,2]; # @b has three elements + @a = (1)[1,0]; # @a has two elements + @b = (1,undef)[1,0,2]; # @b has three elements This makes it easy to write loops that terminate when a null list is returned: - while ( my($home, $user) = (getpwent)[7,0] ) { + while ( ($home, $user) = (getpwent)[7,0]) { printf "%-8s %s\n", $user, $home; } @@ -775,8 +776,6 @@ we have real references, this is seldom needed. The main use of typeglobs in modern Perl is create symbol table aliases. This assignment: - { - *this = *that; makes $this an alias for $that, @this an alias for @that, %this an alias @@ -789,18 +788,17 @@ temporarily makes $Here::blue an alias for $There::green, but doesn't make @Here::blue an alias for @There::green, or %Here::blue an alias for %There::green, etc. See L for more examples of this. Strange though this may seem, this is the basis for the whole -module import/export system. And none of it works under -C. +module import/export system. Another use for typeglobs is to pass filehandles into a function or to create new filehandles. If you need to use a typeglob to save away a filehandle, do it this way: - my $fh = *STDOUT; + $fh = *STDOUT; or perhaps as a real reference, like this: - my $fh = \*STDOUT; + $fh = \*STDOUT; See L for examples of using these as indirect filehandles in functions. @@ -815,7 +813,7 @@ For example: open (FH, $path) or return undef; return *FH; } - my $fh = newopen('/etc/passwd'); + $fh = newopen('/etc/passwd'); Now that we have the C<*foo{THING}> notation, typeglobs aren't used as much for filehandle manipulations, although they're still needed to pass brand @@ -835,9 +833,8 @@ largely eliminates the need for typeglobs when opening filehandles that must be passed around, as in the following example: sub myopen { - my $filename = shift; - open my $fh, $filename - or die "Can't open '$filename': $!"; + open my $fh, "@_" + or die "Can't open '@_': $!"; return $fh; } diff --git a/pod/perldbmfilter.pod b/pod/perldbmfilter.pod index f10bdd0..8384999 100644 --- a/pod/perldbmfilter.pod +++ b/pod/perldbmfilter.pod @@ -4,13 +4,12 @@ perldbmfilter - Perl DBM Filters =head1 SYNOPSIS - my $db = tie my %hash, 'DBM', ...; + $db = tie %hash, 'DBM', ... - my $old_filter; - $old_filter = $db->filter_store_key ( sub { ... } ); - $old_filter = $db->filter_store_value( sub { ... } ); - $old_filter = $db->filter_fetch_key ( sub { ... } ); - $old_filter = $db->filter_fetch_value( sub { ... } ); + $old_filter = $db->filter_store_key ( sub { ... } ) ; + $old_filter = $db->filter_store_value( sub { ... } ) ; + $old_filter = $db->filter_fetch_key ( sub { ... } ) ; + $old_filter = $db->filter_fetch_value( sub { ... } ) ; =head1 DESCRIPTION @@ -86,30 +85,30 @@ the database and have them removed when you read from the database. As I'm sure you have already guessed, this is a problem that DBM Filters can fix very easily. - use strict; - use warnings; - use SDBM_File; - use Fcntl; + use strict ; + use warnings ; + use SDBM_File ; + use Fcntl ; - my %hash; - my $filename = '/tmp/filt'; - unlink $filename; + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; my $db = tie(%hash, 'SDBM_File', $filename, O_RDWR|O_CREAT, 0640) - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n" ; # Install DBM Filters - $db->filter_fetch_key ( sub { s/\0$// } ); - $db->filter_store_key ( sub { $_ .= "\0" } ); + $db->filter_fetch_key ( sub { s/\0$// } ) ; + $db->filter_store_key ( sub { $_ .= "\0" } ) ; $db->filter_fetch_value( - sub { no warnings 'uninitialized'; s/\0$// } ); - $db->filter_store_value( sub { $_ .= "\0" } ); + sub { no warnings 'uninitialized' ;s/\0$// } ) ; + $db->filter_store_value( sub { $_ .= "\0" } ) ; - $hash{abc} = 'def'; - my $a = $hash{ABC}; + $hash{"abc"} = "def" ; + my $a = $hash{"ABC"} ; # ... - undef $db; - untie %hash; + undef $db ; + untie %hash ; The code above uses SDBM_File, but it will work with any of the DBM modules. @@ -125,7 +124,7 @@ Here is another real-life example. By default, whenever Perl writes to a DBM database it always writes the key and value as strings. So when you use this: - $hash{12345} = 'something'; + $hash{12345} = "something" ; the key 12345 will get stored in the DBM database as the 5 byte string "12345". If you actually want the key to be stored in the DBM database @@ -134,23 +133,23 @@ when reading. Here is a DBM Filter that does it: - use strict; - use warnings; - use DB_File; - my %hash; - my $filename = '/tmp/filt'; - unlink $filename; + use strict ; + use warnings ; + use DB_File ; + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n" ; - $db->filter_fetch_key ( sub { $_ = unpack('i', $_) } ); - $db->filter_store_key ( sub { $_ = pack ('i', $_) } ); - $hash{123} = 'def'; + $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; + $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; + $hash{123} = "def" ; # ... - undef $db; - untie %hash; + undef $db ; + untie %hash ; The code above uses DB_File, but again it will work with any of the DBM modules. diff --git a/pod/perldsc.pod b/pod/perldsc.pod index c7c1be2..5ab97e1 100644 --- a/pod/perldsc.pod +++ b/pod/perldsc.pod @@ -18,11 +18,11 @@ The 5.0 release of Perl let us have complex data structures. You may now write something like this and all of a sudden, you'd have a array with three dimensions! - my @AoA; - for my $x (1 .. 10) { - for my $y (1 .. 10) { - for my $z (1 .. 10) { - $AoA[$x][$y][$z] = $x ** $y + $z; + for $x (1 .. 10) { + for $y (1 .. 10) { + for $z (1 .. 10) { + $AoA[$x][$y][$z] = + $x ** $y + $z; } } } @@ -102,11 +102,7 @@ Now, because the top level contains only references, if you try to print out your array in with a simple print() function, you'll get something that doesn't look very nice, like this: - my @AoA = ( - [2, 3, ], - [4, 5, 7], - [0, ], - ); + @AoA = ( [2, 3], [4, 5, 7], [0] ); print $AoA[1][2]; 7 print @AoA; @@ -127,46 +123,79 @@ elements or else taking a reference to the same memory location repeatedly. Here's the case where you just get the count instead of a nested array: - my @AoA; - for my $i (1..10) { - my @array = somefunc($i); - $AoA[$i] = @array; # WRONG! + for $i (1..10) { + @array = somefunc($i); + $AoA[$i] = @array; # WRONG! } That's just the simple case of assigning an array to a scalar and getting its element count. If that's what you really and truly want, then you might do well to consider being a tad more explicit about it, like this: - my @counts; - for my $i (1..10) { - my @array = somefunc($i); - $counts[$i] = scalar @array; + for $i (1..10) { + @array = somefunc($i); + $counts[$i] = scalar @array; } -Here's the right way to do the reference C<@array>: +Here's the case of taking a reference to the same memory location +again and again: - my @AoA - for my $i (1..10) { - my @array = somefunc($i); - $AoA[$i] = [ @array ]; + for $i (1..10) { + @array = somefunc($i); + $AoA[$i] = \@array; # WRONG! + } + +So, what's the big problem with that? It looks right, doesn't it? +After all, I just told you that you need an array of references, so by +golly, you've made me one! + +Unfortunately, while this is true, it's still broken. All the references +in @AoA refer to the I, and they will therefore all hold +whatever was last in @array! It's similar to the problem demonstrated in +the following C program: + + #include + main() { + struct passwd *getpwnam(), *rp, *dp; + rp = getpwnam("root"); + dp = getpwnam("daemon"); + + printf("daemon name is %s\nroot name is %s\n", + dp->pw_name, rp->pw_name); + } + +Which will print + + daemon name is daemon + root name is daemon + +The problem is that both C and C are pointers to the same location +in memory! In C, you'd have to remember to malloc() yourself some new +memory. In Perl, you'll want to use the array constructor C<[]> or the +hash constructor C<{}> instead. Here's the right way to do the preceding +broken code fragments: + + for $i (1..10) { + @array = somefunc($i); + $AoA[$i] = [ @array ]; } The square brackets make a reference to a new array with a I -of what's in C<@array>. +of what's in @array at the time of the assignment. This is what +you want. Note that this will produce something similar, but it's much harder to read: - my @AoA; - for my $i (1..10) { - my @array = somefunc($i); - @{ $AoA[$i] } = @array; + for $i (1..10) { + @array = 0 .. $i; + @{$AoA[$i]} = @array; } Is it the same? Well, maybe so--and maybe not. The subtle difference is that when you assign something in square brackets, you know for sure it's always a brand new reference with a new I of the data. -Something else could be going on in this new case with the C<@{ $AoA[$i]} }> +Something else could be going on in this new case with the C<@{$AoA[$i]}}> dereference on the left-hand-side of the assignment. It all depends on whether C<$AoA[$i]> had been undefined to start with, or whether it already contained a reference. If you had already populated @AoA with @@ -177,7 +206,7 @@ references, as in Then the assignment with the indirection on the left-hand-side would use the existing reference that was already there: - @{ $AoA[3] } = @array; + @{$AoA[3]} = @array; Of course, this I have the "interesting" effect of clobbering @another_array. (Have you ever noticed how when a programmer says @@ -192,10 +221,9 @@ efficient. Surprisingly, the following dangerous-looking construct will actually work out fine: - my @AoA; - for my $i (1..10) { - my @array = somefunc($i); - $AoA[$i] = \@array; + for $i (1..10) { + my @array = somefunc($i); + $AoA[$i] = \@array; } That's because my() is more of a run-time statement than it is a @@ -214,14 +242,14 @@ do the right thing behind the scenes. In summary: - $AoA[$i] = [ @array ]; # usually best - $AoA[$i] = \@array; # perilous; just how my() is that array? - @{ $AoA[$i] } = @array; # way too tricky for most programmers + $AoA[$i] = [ @array ]; # usually best + $AoA[$i] = \@array; # perilous; just how my() was that array? + @{ $AoA[$i] } = @array; # way too tricky for most programmers =head1 CAVEAT ON PRECEDENCE -Speaking of things like C<@{ $AoA[$i] }>, the following are actually the +Speaking of things like C<@{$AoA[$i]}>, the following are actually the same thing: $aref->[2][2] # clear @@ -256,9 +284,9 @@ also disallow accidental "symbolic dereferencing". Therefore if you'd done this: my $aref = [ - [ 'fred', 'barney', 'pebbles', 'bambam', 'dino', ], - [ 'homer', 'bart', 'marge', 'maggie', ], - [ 'george', 'jane', 'elroy', 'judy', ], + [ "fred", "barney", "pebbles", "bambam", "dino", ], + [ "homer", "bart", "marge", "maggie", ], + [ "george", "jane", "elroy", "judy", ], ]; print $aref[2][2]; @@ -306,60 +334,55 @@ types of data structures. =head2 Declaration of a ARRAY OF ARRAYS - my @AoA = ( - [ 'fred', 'barney' ], - [ 'george', 'jane', 'elroy' ], - [ 'homer', 'marge', 'bart' ], + @AoA = ( + [ "fred", "barney" ], + [ "george", "jane", "elroy" ], + [ "homer", "marge", "bart" ], ); =head2 Generation of a ARRAY OF ARRAYS # reading from file - my @AoA; while ( <> ) { push @AoA, [ split ]; } # calling a function - my @AoA; - foreach my $i ( 1 .. 10 ) { + for $i ( 1 .. 10 ) { $AoA[$i] = [ somefunc($i) ]; } # using temp vars - my @AoA; - foreach my $i ( 1 .. 10 ) { - my @tmp = somefunc($i); - $AoA[$i] = [ @tmp ]; + for $i ( 1 .. 10 ) { + @tmp = somefunc($i); + $AoA[$i] = [ @tmp ]; } # add to an existing row - push @{ $AoA[0] }, 'wilma', 'betty'; + push @{ $AoA[0] }, "wilma", "betty"; =head2 Access and Printing of a ARRAY OF ARRAYS - my @AoA; - # one element - $AoA[0][0] = 'Fred'; + $AoA[0][0] = "Fred"; # another element $AoA[1][1] =~ s/(\w)/\u$1/; # print the whole thing with refs - foreach my $aref ( @AoA ) { + for $aref ( @AoA ) { print "\t [ @$aref ],\n"; } # print the whole thing with indices - foreach my $i ( 0 .. $#AoA ) { - print "\t [ @{ $AoA[$i] } ],\n"; + for $i ( 0 .. $#AoA ) { + print "\t [ @{$AoA[$i]} ],\n"; } # print the whole thing one at a time - foreach my $i ( 0 .. $#AoA ) { - foreach my $j ( 0 .. $#{ $AoA[$i] } ) { - print "element $i $j is $AoA[$i][$j]\n"; + for $i ( 0 .. $#AoA ) { + for $j ( 0 .. $#{ $AoA[$i] } ) { + print "elt $i $j is $AoA[$i][$j]\n"; } } @@ -367,86 +390,77 @@ types of data structures. =head2 Declaration of a HASH OF ARRAYS - my %HoA = ( - flintstones => [ 'fred', 'barney' ], - jetsons => [ 'george', 'jane', 'elroy' ], - simpsons => [ 'homer', 'marge', 'bart' ], + %HoA = ( + flintstones => [ "fred", "barney" ], + jetsons => [ "george", "jane", "elroy" ], + simpsons => [ "homer", "marge", "bart" ], ); =head2 Generation of a HASH OF ARRAYS # reading from file # flintstones: fred barney wilma dino - my %HoA; while ( <> ) { - next unless s/^([^:]*):\s*//; + next unless s/^(.*?):\s*//; $HoA{$1} = [ split ]; } # reading from file; more temps # flintstones: fred barney wilma dino - my %HoA; - while ( my $line = <> ) { - my ($who, $rest) = split /:\s*/, $line, 2; - my @fields = split ' ', $rest; - $HoA{$who} = [ @fields ]; + while ( $line = <> ) { + ($who, $rest) = split /:\s*/, $line, 2; + @fields = split ' ', $rest; + $HoA{$who} = [ @fields ]; } # calling a function that returns a list - my %HoA; - foreach my $group ( 'simpsons', 'jetsons', 'flintstones' ) { + for $group ( "simpsons", "jetsons", "flintstones" ) { $HoA{$group} = [ get_family($group) ]; } # likewise, but using temps - my %HoA; - foreach my $group ( 'simpsons', 'jetsons', 'flintstones' ) { - my @members = get_family($group); - $HoA{$group} = [ @members ]; + for $group ( "simpsons", "jetsons", "flintstones" ) { + @members = get_family($group); + $HoA{$group} = [ @members ]; } # append new members to an existing family - push @{ $HoA{flintstones} }, 'wilma', 'betty'; + push @{ $HoA{"flintstones"} }, "wilma", "betty"; =head2 Access and Printing of a HASH OF ARRAYS - my %HoA; - # one element - $HoA{flintstones}[0] = 'Fred'; + $HoA{flintstones}[0] = "Fred"; # another element $HoA{simpsons}[1] =~ s/(\w)/\u$1/; # print the whole thing - foreach my $family ( keys %HoA ) { - print "$family: @{ $HoA{$family} }\n"; + foreach $family ( keys %HoA ) { + print "$family: @{ $HoA{$family} }\n" } # print the whole thing with indices - foreach my $family ( keys %HoA ) { - print 'family: '; - foreach my $i ( 0 .. $#{ $HoA{$family} } ) { + foreach $family ( keys %HoA ) { + print "family: "; + foreach $i ( 0 .. $#{ $HoA{$family} } ) { print " $i = $HoA{$family}[$i]"; } print "\n"; } # print the whole thing sorted by number of members - sub num_members { - @{ $HoA{$b} } <=> @{ $HoA{$a} } - } - foreach my $family ( sort num_members keys %HoA ) { + foreach $family ( sort { @{$HoA{$b}} <=> @{$HoA{$a}} } keys %HoA ) { print "$family: @{ $HoA{$family} }\n" } # print the whole thing sorted by number of members and name - sub members_and_name { - @{ $HoA{$b} } <=> @{ $HoA{$a} } - || - $a cmp $b - } - foreach my $family ( sort members_and_name keys %HoA ) { + foreach $family ( sort { + @{$HoA{$b}} <=> @{$HoA{$a}} + || + $a cmp $b + } keys %HoA ) + { print "$family: ", join(", ", sort @{ $HoA{$family} }), "\n"; } @@ -454,20 +468,20 @@ types of data structures. =head2 Declaration of a ARRAY OF HASHES - my @AoH = ( + @AoH = ( { - Lead => 'fred', - Friend => 'barney', + Lead => "fred", + Friend => "barney", }, { - Lead => 'george', - Wife => 'jane', - Son => 'elroy', + Lead => "george", + Wife => "jane", + Son => "elroy", }, { - Lead => 'homer', - Wife => 'marge', - Son => 'bart', + Lead => "homer", + Wife => "marge", + Son => "bart", } ); @@ -475,12 +489,11 @@ types of data structures. # reading from file # format: LEAD=fred FRIEND=barney - my @AoH; while ( <> ) { - my $rec = {}; - foreach my $field ( split ) { - my($key, $value) = split /=/, $field; - $rec->{$key} = $value; + $rec = {}; + for $field ( split ) { + ($key, $value) = split /=/, $field; + $rec->{$key} = $value; } push @AoH, $rec; } @@ -489,60 +502,55 @@ types of data structures. # reading from file # format: LEAD=fred FRIEND=barney # no temp - my @AoH; while ( <> ) { push @AoH, { split /[\s+=]/ }; } # calling a function that returns a key/value pair list, like - # lead => 'fred', daughter => 'pebbles' - my @AoH; - while ( my %fields = getnextpairset() ) { + # "lead","fred","daughter","pebbles" + while ( %fields = getnextpairset() ) { push @AoH, { %fields }; } # likewise, but using no temp vars - my @AoH; while (<>) { push @AoH, { parsepairs($_) }; } # add key/value to an element - $AoH[0]{pet} = 'dino'; + $AoH[0]{pet} = "dino"; $AoH[2]{pet} = "santa's little helper"; =head2 Access and Printing of a ARRAY OF HASHES - my @AoH; - # one element - $AoH[0]{lead} = 'fred'; + $AoH[0]{lead} = "fred"; # another element $AoH[1]{lead} =~ s/(\w)/\u$1/; # print the whole thing with refs - foreach my $href ( @AoH ) { - print '{ '; - foreach my $role ( keys %$href ) { - print "$role = $href->{$role} "; + for $href ( @AoH ) { + print "{ "; + for $role ( keys %$href ) { + print "$role=$href->{$role} "; } print "}\n"; } # print the whole thing with indices - foreach my $i ( 0 .. $#AoH ) { + for $i ( 0 .. $#AoH ) { print "$i is { "; - foreach my $role ( keys %{ $AoH[$i] } ) { - print "$role = $AoH[$i]{$role} "; + for $role ( keys %{ $AoH[$i] } ) { + print "$role=$AoH[$i]{$role} "; } print "}\n"; } # print the whole thing one at a time - foreach my $i ( 0 .. $#AoH ) { - foreach my $role ( keys %{ $AoH[$i] } ) { - print "element $i $role is $AoH[$i]{$role}\n"; + for $i ( 0 .. $#AoH ) { + for $role ( keys %{ $AoH[$i] } ) { + print "elt $i $role is $AoH[$i]{$role}\n"; } } @@ -550,20 +558,20 @@ types of data structures. =head2 Declaration of a HASH OF HASHES - my %HoH = ( + %HoH = ( flintstones => { - lead => 'fred', - pal => 'barney', + lead => "fred", + pal => "barney", }, jetsons => { - lead => 'george', - wife => 'jane', - 'his boy' => 'elroy', + lead => "george", + wife => "jane", + "his boy" => "elroy", }, simpsons => { - lead => 'homer', - wife => 'marge', - kid => 'bart', + lead => "homer", + wife => "marge", + kid => "bart", }, ); @@ -571,113 +579,94 @@ types of data structures. # reading from file # flintstones: lead=fred pal=barney wife=wilma pet=dino - my %HoH; while ( <> ) { - next unless s/^([^:]*):\s*//; - my $who = $1; - for my $field ( split ) { - my($key, $value) = split /=/, $field; + next unless s/^(.*?):\s*//; + $who = $1; + for $field ( split ) { + ($key, $value) = split /=/, $field; $HoH{$who}{$key} = $value; } # reading from file; more temps - my %HoH; while ( <> ) { - next unless s/^([^:]*):\s*//; - my $who = $1; - my $rec = {}; + next unless s/^(.*?):\s*//; + $who = $1; + $rec = {}; $HoH{$who} = $rec; - foreach my $field ( split ) { - my($key, $value) = split /=/, $field; - $rec->{$key} = $value; + for $field ( split ) { + ($key, $value) = split /=/, $field; + $rec->{$key} = $value; } } # calling a function that returns a key,value hash - my %HoH; - foreach my $group ( 'simpsons', 'jetsons', 'flintstones' ) { + for $group ( "simpsons", "jetsons", "flintstones" ) { $HoH{$group} = { get_family($group) }; } # likewise, but using temps - my %HoH; - foreach my $group ( 'simpsons', 'jetsons', 'flintstones' ) { - my %members = get_family($group); + for $group ( "simpsons", "jetsons", "flintstones" ) { + %members = get_family($group); $HoH{$group} = { %members }; } # append new members to an existing family - my %HoH; - my %new_folks = ( - wife => 'wilma', - pet => 'dino', + %new_folks = ( + wife => "wilma", + pet => "dino", ); - foreach my $what (keys %new_folks) { + for $what (keys %new_folks) { $HoH{flintstones}{$what} = $new_folks{$what}; } =head2 Access and Printing of a HASH OF HASHES - %HoH; - # one element - $HoH{flintstones}{wife} = 'wilma'; + $HoH{flintstones}{wife} = "wilma"; # another element $HoH{simpsons}{lead} =~ s/(\w)/\u$1/; # print the whole thing - foreach my $family ( keys %HoH ) { + foreach $family ( keys %HoH ) { print "$family: { "; - foreach my $role ( keys %{ $HoH{$family} } ) { - print "$role = $HoH{$family}{$role} "; + for $role ( keys %{ $HoH{$family} } ) { + print "$role=$HoH{$family}{$role} "; } print "}\n"; } # print the whole thing somewhat sorted - foreach my $family ( sort keys %HoH ) { + foreach $family ( sort keys %HoH ) { print "$family: { "; - foreach my $role ( sort keys %{ $HoH{$family} } ) { - print "$role = $HoH{$family}{$role} "; + for $role ( sort keys %{ $HoH{$family} } ) { + print "$role=$HoH{$family}{$role} "; } print "}\n"; } + # print the whole thing sorted by number of members - sub num_members { - keys %{ $HoH{$b} } <=> keys %{ $HoH{$a} } - } - foreach my $family ( sort num_members keys %HoH ) { + foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$a}} } keys %HoH ) { print "$family: { "; - foreach my $role ( sort keys %{ $HoH{$family} } ) { - print "$role = $HoH{$family}{$role} "; + for $role ( sort keys %{ $HoH{$family} } ) { + print "$role=$HoH{$family}{$role} "; } print "}\n"; } # establish a sort order (rank) for each role - my %rank; - my $i = 0; - foreach ( qw(lead wife son daughter pal pet) ) { - $rank{$_} = ++$i; - } + $i = 0; + for ( qw(lead wife son daughter pal pet) ) { $rank{$_} = ++$i } # now print the whole thing sorted by number of members - sub num_members { - keys %{ $HoH{$b} } <=> keys %{ $HoH{$a} } - } - sub rank { - $rank{$a} <=> $rank{$b} - } - - foreach my $family ( sort num_members keys %HoH ) { + foreach $family ( sort { keys %{ $HoH{$b} } <=> keys %{ $HoH{$a} } } keys %HoH ) { print "$family: { "; # and print these according to rank order - foreach my $role ( sort rank keys %{ $HoH{$family} } ) { - print "$role = $HoH{$family}{$role} "; + for $role ( sort { $rank{$a} <=> $rank{$b} } keys %{ $HoH{$family} } ) { + print "$role=$HoH{$family}{$role} "; } print "}\n"; } @@ -690,7 +679,7 @@ types of data structures. Here's a sample showing how to create and use a record whose fields are of many different sorts: - my $rec = { + $rec = { TEXT => $string, SEQUENCE => [ @old_values ], LOOKUP => { %some_table }, @@ -701,14 +690,14 @@ many different sorts: print $rec->{TEXT}; - print $rec->{SEQUENCE}->[0]; - my $last = pop @{ $rec->{SEQUENCE} }; + print $rec->{SEQUENCE}[0]; + $last = pop @ { $rec->{SEQUENCE} }; - print $rec->{LOOKUP}->{key}; - my($first_k, $first_v) = each %{ $rec->{LOOKUP} }; + print $rec->{LOOKUP}{"key"}; + ($first_k, $first_v) = each %{ $rec->{LOOKUP} }; - my $answer = $rec->{THATCODE}->($arg); - my $result = $rec->{THISCODE}->($arg1, $arg2); + $answer = $rec->{THATCODE}->($arg); + $answer = $rec->{THISCODE}->($arg1, $arg2); # careful of extra block braces on fh ref print { $rec->{HANDLE} } "a string\n"; @@ -719,52 +708,55 @@ many different sorts: =head2 Declaration of a HASH OF COMPLEX RECORDS - my %TV = ( + %TV = ( flintstones => { - series => 'flintstones', + series => "flintstones", nights => [ qw(monday thursday friday) ], members => [ - { name => 'fred', role => 'lead', age => 36, }, - { name => 'wilma', role => 'wife', age => 31, }, - { name => 'pebbles', role => 'kid', age => 4, }, + { name => "fred", role => "lead", age => 36, }, + { name => "wilma", role => "wife", age => 31, }, + { name => "pebbles", role => "kid", age => 4, }, ], }, jetsons => { - series => 'jetsons', + series => "jetsons", nights => [ qw(wednesday saturday) ], members => [ - { name => 'george", role => 'lead', age => 41, }, - { name => 'jane", role => 'wife', age => 39, }, - { name => 'elroy", role => 'kid', age => 9, }, + { name => "george", role => "lead", age => 41, }, + { name => "jane", role => "wife", age => 39, }, + { name => "elroy", role => "kid", age => 9, }, ], }, simpsons => { - series => 'simpsons', + series => "simpsons", nights => [ qw(monday) ], members => [ - { name => 'homer', role => 'lead', age => 34, }, - { name => 'marge', role => 'wife', age => 37, }, - { name => 'bart', role => 'kid', age => 11, }, + { name => "homer", role => "lead", age => 34, }, + { name => "marge", role => "wife", age => 37, }, + { name => "bart", role => "kid", age => 11, }, ], }, ); =head2 Generation of a HASH OF COMPLEX RECORDS -Here's a piece by piece build up of a hash of complex records. We'll -read in a file that has our data in it. + # reading from file + # this is most easily done by having the file itself be + # in the raw data format as shown above. perl is happy + # to parse complex data structures if declared as data, so + # sometimes it's easiest to do that - my %TV = (); - my $rec = {}; - $rec->{series} = 'flintstones'; + # here's a piece by piece build up + $rec = {}; + $rec->{series} = "flintstones"; $rec->{nights} = [ find_days() ]; - my @members = (); + @members = (); # assume this file in field=value syntax - while ( <> ) { - my %fields = split /[\s=]+/, $_; + while (<>) { + %fields = split /[\s=]+/; push @members, { %fields }; } $rec->{members} = [ @members ]; @@ -772,18 +764,19 @@ read in a file that has our data in it. # now remember the whole thing $TV{ $rec->{series} } = $rec; -Now, you might want to make interesting extra fields that -include pointers back into the same data structure so if -change one piece, it changes everywhere, like for example -if you wanted a 'kids' field that was a reference -to an array of the kids' records without having duplicate -records and thus update problems. - - foreach my $family ( keys %TV ) { - my $rec = $TV{$family}; # $rec points to $TV{$family} - my @kids = (); - foreach my $person ( @{ $rec->{members} } ) { - if ( $person->{role} =~ /kid|son|daughter/ ) { + ########################################################### + # now, you might want to make interesting extra fields that + # include pointers back into the same data structure so if + # change one piece, it changes everywhere, like for example + # if you wanted a {kids} field that was a reference + # to an array of the kids' records without having duplicate + # records and thus update problems. + ########################################################### + foreach $family (keys %TV) { + $rec = $TV{$family}; # temp pointer + @kids = (); + for $person ( @{ $rec->{members} } ) { + if ($person->{role} =~ /kid|son|daughter/) { push @kids, $person; } } @@ -791,33 +784,30 @@ records and thus update problems. $rec->{kids} = [ @kids ]; } -You copied the array, but the array itself contains pointers -to uncopied objects. This means that if you make bart get -older via + # you copied the array, but the array itself contains pointers + # to uncopied objects. this means that if you make bart get + # older via $TV{simpsons}{kids}[0]{age}++; -Then this would also change in C<$TV{simpsons}{members}[2]{age}> -because C<$TV{simpsons}{kids}[0]> and C<$TV{simpsons}{members}[2]> -both point to the same underlying anonymous hash table. + # then this would also change in + print $TV{simpsons}{members}[2]{age}; - # print the whole thing - foreach my $family ( keys %TV ) { - print "the $family is on during @{ $TV{$family}{nights} }\n", - "its members are:\n"; + # because $TV{simpsons}{kids}[0] and $TV{simpsons}{members}[2] + # both point to the same underlying anonymous hash table - foraech my $who ( @{ $TV{$family}{members} } ) { + # print the whole thing + foreach $family ( keys %TV ) { + print "the $family"; + print " is on during @{ $TV{$family}{nights} }\n"; + print "its members are:\n"; + for $who ( @{ $TV{$family}{members} } ) { print " $who->{name} ($who->{role}), age $who->{age}\n"; } - - print "it turns out that $TV{$family}{lead} has ", - scalar ( @{ $TV{$family}{kids} } ), - ' kids named ', - join( - ', ', - map { $_->{name} } @{ $TV{$family}{kids} } - ), - "\n"; + print "it turns out that $TV{$family}{lead} has "; + print scalar ( @{ $TV{$family}{kids} } ), " kids named "; + print join (", ", map { $_->{name} } @{ $TV{$family}{kids} } ); + print "\n"; } =head1 Database Ties @@ -838,8 +828,5 @@ perlref(1), perllol(1), perldata(1), perlobj(1) Tom Christiansen > -Last update (by Tom): +Last update: Wed Oct 23 04:57:50 MET DST 1996 - -Last update (by Casey West, > -Mon Sep 17 13:33:41 EDT 2001 diff --git a/pod/perlebcdic.pod b/pod/perlebcdic.pod index be2a2e3..c98b46c 100644 --- a/pod/perlebcdic.pod +++ b/pod/perlebcdic.pod @@ -130,29 +130,8 @@ work with a pod2_other_format translation) through: =back - perldoc -m perlebcdic | \ - perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \ - -e '{printf("%s%-9o%-9o%-9o%o\n",$1,$2,$3,$4,$5)}' - -Or, as a script, called like C: - - my $regex = qr/ - (.{33}) # any 33 characters - - (\d+)\s+ # capture some digits, discard spaces - (\d+)\s+ # ".." - (\d+)\s+ # ".." - (\d+) # capture some digits - /x; - - while ( <> ) { - if ( $_ =~ $regex ) { - printf( - "%s%-9o%-9o%-9o%o\n", - $1, $2, $3, $4, $5, - ); - } - } + perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \ + -e '{printf("%s%-9o%-9o%-9o%o\n",$1,$2,$3,$4,$5)}' perlebcdic.pod If you want to retain the UTF-x code points then in script form you might want to write: @@ -163,47 +142,20 @@ might want to write: =back - my $regex = qr/ - (.{33}) # $1: any 33 characters - - (\d+)\s+ # $2, $3, $4, $5: - (\d+)\s+ # capture some digits, discard spaces - (\d+)\s+ # 4 times - (\d+)\s+ - - (\d+) # $6: capture some digits, - \.? # there may be a period, - (\d*) # $7: capture some digits if they're there, - \s+ # discard spaces - - (\d+) # $8: capture some digits - \.? # there may be a period, - (\d*) # $9: capture some digits if they're there, - /x; - - open( FH, 'perldoc -m perlebcdic |' ) || - die "Could not open perlebcdic.pod: $!"; - while ( ) { - if ( $_ =~ $regex ) { - if ( $7 ne '' && $9 ne '' ) { - printf( - "%s%-9o%-9o%-9o%-9o%-3o.%-5o%-3o.%o\n", - $1, $2, $3, $4, $5, $6, $7, $8, $9 - ); - } elsif ( $7 ne '' ) { - printf( - "%s%-9o%-9o%-9o%-9o%-3o.%-5o%o\n", - $1, $2, $3, $4, $5, $6, $7, $8 - ); - } else { - printf( - "%s%-9o%-9o%-9o%-9o%-9o%o\n", - $1, $2, $3, $4, $5, $6, $8 - ); + open(FH,") { + if (/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\.?(\d*)\s+(\d+)\.?(\d*)/) { + if ($7 ne '' && $9 ne '') { + printf("%s%-9o%-9o%-9o%-9o%-3o.%-5o%-3o.%o\n",$1,$2,$3,$4,$5,$6,$7,$8,$9); + } + elsif ($7 ne '') { + printf("%s%-9o%-9o%-9o%-9o%-3o.%-5o%o\n",$1,$2,$3,$4,$5,$6,$7,$8); + } + else { + printf("%s%-9o%-9o%-9o%-9o%-9o%o\n",$1,$2,$3,$4,$5,$6,$8); } } } - close FH; If you would rather see this table listing hexadecimal values then run the table through: @@ -214,9 +166,8 @@ run the table through: =back - perldoc -m perlebcdic | \ - perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \ - -e '{printf("%s%-9X%-9X%-9X%X\n",$1,$2,$3,$4,$5)}' + perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \ + -e '{printf("%s%-9X%-9X%-9X%X\n",$1,$2,$3,$4,$5)}' perlebcdic.pod Or, in order to retain the UTF-x code points in hexadecimal: @@ -226,50 +177,21 @@ Or, in order to retain the UTF-x code points in hexadecimal: =back - my $regex = qr/ - (.{33}) # $1: any 33 characters - - (\d+)\s+ # $2, $3, $4, $5: - (\d+)\s+ # capture some digits, discard spaces - (\d+)\s+ # 4 times - (\d+)\s+ - - (\d+) # $6: capture some digits, - \.? # there may be a period, - (\d*) # $7: capture some digits if they're there, - \s+ # discard spaces - - (\d+) # $8: capture some digits - \.? # there may be a period, - (\d*) # $9: capture some digits if they're there, - /x; - - open( FH, 'perldoc -m perlebcdic |' ) || - die "Could not open perlebcdic.pod: $!"; + open(FH,") { - if ( $_ =~ $regex ) { - if ( $7 ne '' && $9 ne '' ) { - printf( - "%s%-9X%-9X%-9X%-9X%-2X.%-6X%-2X.%X\n", - $1, $2, $3, $4, $5, $6, $7, $8, $9 - ); + if (/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\.?(\d*)\s+(\d+)\.?(\d*)/) { + if ($7 ne '' && $9 ne '') { + printf("%s%-9X%-9X%-9X%-9X%-2X.%-6X%-2X.%X\n",$1,$2,$3,$4,$5,$6,$7,$8,$9); } - elsif ( $7 ne '' ) { - printf( - "%s%-9X%-9X%-9X%-9X%-2X.%-6X%X\n", - $1, $2, $3, $4, $5, $6, $7, $8 - ); + elsif ($7 ne '') { + printf("%s%-9X%-9X%-9X%-9X%-2X.%-6X%X\n",$1,$2,$3,$4,$5,$6,$7,$8); } else { - printf( - "%s%-9X%-9X%-9X%-9X%-9X%X\n", - $1, $2, $3, $4, $5, $6, $8 - ); + printf("%s%-9X%-9X%-9X%-9X%-9X%X\n",$1,$2,$3,$4,$5,$6,$8); } } } -=head2 THE SINGLE OCTET TABLE incomp- incomp- 8859-1 lete lete @@ -532,7 +454,6 @@ Or, in order to retain the UTF-x code points in hexadecimal: 254 142 142 142 195.190 139.114 255 223 223 223 195.191 139.115 - If you would rather see the above table in CCSID 0037 order rather than ASCII + Latin-1 order then run the table through: @@ -542,12 +463,11 @@ ASCII + Latin-1 order then run the table through: =back - perldoc -m perlebcdic | \ - perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)' \ - -e '{push(@l,$_)}' \ - -e 'END{print map{$_->[0]}' \ - -e 'sort{$a->[1] <=> $b->[1]}' \ - -e 'map{[$_,substr($_,42,3)]}@l;}' + perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\ + -e '{push(@l,$_)}' \ + -e 'END{print map{$_->[0]}' \ + -e ' sort{$a->[1] <=> $b->[1]}' \ + -e ' map{[$_,substr($_,42,3)]}@l;}' perlebcdic.pod If you would rather see it in CCSID 1047 order then change the digit 42 in the last line to 51, like this: @@ -558,12 +478,11 @@ If you would rather see it in CCSID 1047 order then change the digit =back - perldoc -m perlebcdic | \ - perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)' \ - -e '{push(@l,$_)}' \ - -e 'END{print map{$_->[0]}' \ - -e 'sort{$a->[1] <=> $b->[1]}' \ - -e 'map{[$_,substr($_,51,3)]}@l;}' + perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\ + -e '{push(@l,$_)}' \ + -e 'END{print map{$_->[0]}' \ + -e ' sort{$a->[1] <=> $b->[1]}' \ + -e ' map{[$_,substr($_,51,3)]}@l;}' perlebcdic.pod If you would rather see it in POSIX-BC order then change the digit 51 in the last line to 60, like this: @@ -574,12 +493,11 @@ If you would rather see it in POSIX-BC order then change the digit =back - perldoc -m perlebcdic | \ - perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)' \ - -e '{push(@l,$_)}' \ - -e 'END{print map{$_->[0]}' \ - -e 'sort{$a->[1] <=> $b->[1]}' \ - -e 'map{[$_,substr($_,60,3)]}@l;}' + perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\ + -e '{push(@l,$_)}' \ + -e 'END{print map{$_->[0]}' \ + -e ' sort{$a->[1] <=> $b->[1]}' \ + -e ' map{[$_,substr($_,60,3)]}@l;}' perlebcdic.pod =head1 IDENTIFYING CHARACTER CODE SETS @@ -588,44 +506,44 @@ To determine the character set you are running under from perl one could use the return value of ord() or chr() to test one or more character values. For example: - my $is_ascii = "A" eq chr(65); - my $is_ebcdic = "A" eq chr(193); + $is_ascii = "A" eq chr(65); + $is_ebcdic = "A" eq chr(193); Also, "\t" is a C character so that: - my $is_ascii = ord("\t") == 9; - my $is_ebcdic = ord("\t") == 5; + $is_ascii = ord("\t") == 9; + $is_ebcdic = ord("\t") == 5; To distinguish EBCDIC code pages try looking at one or more of the characters that differ between them. For example: - my $is_ebcdic_37 = "\n" eq chr(37); - my $is_ebcdic_1047 = "\n" eq chr(21); + $is_ebcdic_37 = "\n" eq chr(37); + $is_ebcdic_1047 = "\n" eq chr(21); Or better still choose a character that is uniquely encoded in any of the code sets, e.g.: - my $is_ascii = ord('[') == 91; - my $is_ebcdic_37 = ord('[') == 186; - my $is_ebcdic_1047 = ord('[') == 173; - my $is_ebcdic_POSIX_BC = ord('[') == 187; + $is_ascii = ord('[') == 91; + $is_ebcdic_37 = ord('[') == 186; + $is_ebcdic_1047 = ord('[') == 173; + $is_ebcdic_POSIX_BC = ord('[') == 187; However, it would be unwise to write tests such as: - my $is_ascii = "\r" ne chr(13); # WRONG - my $is_ascii = "\n" ne chr(10); # ILL ADVISED + $is_ascii = "\r" ne chr(13); # WRONG + $is_ascii = "\n" ne chr(10); # ILL ADVISED Obviously the first of these will fail to distinguish most ASCII machines -from either a CCSID 0037, a 1047, or a POSIX-BC EBCDIC machine since "\r" eq -chr(13) under all of those coded character sets. But note too that -because "\n" is chr(13) and "\r" is chr(10) on the MacIntosh (which is an +from either a CCSID 0037, a 1047, or a POSIX-BC EBCDIC machine since "\r" eq +chr(13) under all of those coded character sets. But note too that +because "\n" is chr(13) and "\r" is chr(10) on the MacIntosh (which is an ASCII machine) the second C<$is_ascii> test will lead to trouble there. -To determine whether or not perl was built under an EBCDIC +To determine whether or not perl was built under an EBCDIC code page you can use the Config module like so: use Config; - my $is_ebcdic = $Config{'ebcdic'} eq 'define'; + $is_ebcdic = $Config{'ebcdic'} eq 'define'; =head1 CONVERSIONS @@ -638,30 +556,29 @@ The data in the table are in ASCII order hence the EBCDIC columns provide easy to use ASCII to EBCDIC operations that are also easily reversed. -For example, to convert ASCII to code page 037 take the output of the second -column from the output of recipe 0 (modified to add \\ characters) and use +For example, to convert ASCII to code page 037 take the output of the second +column from the output of recipe 0 (modified to add \\ characters) and use it in tr/// like so: - my $cp_037 = join '', - qq[\000\001\002\003\234\011\206\177\227\215\216\013\014\015\016\017], - qq[\020\021\022\023\235\205\010\207\030\031\222\217\034\035\036\037], - qq[\200\201\202\203\204\012\027\033\210\211\212\213\214\005\006\007], - qq[\220\221\026\223\224\225\226\004\230\231\232\233\024\025\236\032], - qq[\040\240\342\344\340\341\343\345\347\361\242\056\074\050\053\174], - qq[\046\351\352\353\350\355\356\357\354\337\041\044\052\051\073\254], - qq[\055\057\302\304\300\301\303\305\307\321\246\054\045\137\076\077], - qq[\370\311\312\313\310\315\316\317\314\140\072\043\100\047\075\042], - qq[\330\141\142\143\144\145\146\147\150\151\253\273\360\375\376\261], - qq[\260\152\153\154\155\156\157\160\161\162\252\272\346\270\306\244], - qq[\265\176\163\164\165\166\167\170\171\172\241\277\320\335\336\256], - qq[\136\243\245\267\251\247\266\274\275\276\133\135\257\250\264\327], - qq[\173\101\102\103\104\105\106\107\110\111\255\364\366\362\363\365], - qq[\175\112\113\114\115\116\117\120\121\122\271\373\374\371\372\377], - qq[\134\367\123\124\125\126\127\130\131\132\262\324\326\322\323\325], - qq[\060\061\062\063\064\065\066\067\070\071\263\333\334\331\332\237]; + $cp_037 = + '\000\001\002\003\234\011\206\177\227\215\216\013\014\015\016\017' . + '\020\021\022\023\235\205\010\207\030\031\222\217\034\035\036\037' . + '\200\201\202\203\204\012\027\033\210\211\212\213\214\005\006\007' . + '\220\221\026\223\224\225\226\004\230\231\232\233\024\025\236\032' . + '\040\240\342\344\340\341\343\345\347\361\242\056\074\050\053\174' . + '\046\351\352\353\350\355\356\357\354\337\041\044\052\051\073\254' . + '\055\057\302\304\300\301\303\305\307\321\246\054\045\137\076\077' . + '\370\311\312\313\310\315\316\317\314\140\072\043\100\047\075\042' . + '\330\141\142\143\144\145\146\147\150\151\253\273\360\375\376\261' . + '\260\152\153\154\155\156\157\160\161\162\252\272\346\270\306\244' . + '\265\176\163\164\165\166\167\170\171\172\241\277\320\335\336\256' . + '\136\243\245\267\251\247\266\274\275\276\133\135\257\250\264\327' . + '\173\101\102\103\104\105\106\107\110\111\255\364\366\362\363\365' . + '\175\112\113\114\115\116\117\120\121\122\271\373\374\371\372\377' . + '\134\367\123\124\125\126\127\130\131\132\262\324\326\322\323\325' . + '\060\061\062\063\064\065\066\067\070\071\263\333\334\331\332\237' ; my $ebcdic_string = $ascii_string; - eval '$ebcdic_string =~ tr/\000-\377/' . $cp_037 . '/'; To convert from EBCDIC 037 to ASCII just reverse the order of the tr/// @@ -684,12 +601,12 @@ On OS/390 or z/OS see the iconv(1) manpage. One way to invoke the iconv shell utility from within perl would be to: # OS/390 or z/OS example - my $ascii_data = `echo '$ebcdic_data'| iconv -f IBM-1047 -t ISO8859-1` + $ascii_data = `echo '$ebcdic_data'| iconv -f IBM-1047 -t ISO8859-1` or the inverse map: # OS/390 or z/OS example - my $ebcdic_data = `echo '$ascii_data'| iconv -f ISO8859-1 -t IBM-1047` + $ebcdic_data = `echo '$ascii_data'| iconv -f ISO8859-1 -t IBM-1047` For other perl based conversion options see the Convert::* modules on CPAN. @@ -704,7 +621,7 @@ care on EBCDIC machines. For example the following array will have twenty six elements on either an EBCDIC machine or an ASCII machine: - my @alphabet = ( 'A'..'Z' ); # $#alphabet == 25 + @alphabet = ('A'..'Z'); # $#alphabet == 25 The bitwise operators such as & ^ | may return different results when operating on string or character data in a perl program running @@ -712,10 +629,10 @@ on an EBCDIC machine than when run on an ASCII machine. Here is an example adapted from the one in L: # EBCDIC-based examples - print "j p \n" ^ " a h"; # prints "JAPH\n" - print "JA" | " ph\n"; # prints "japh\n" - print "JAPH\nJunk" & "\277\277\277\277\277"; # prints "japh\n" - print 'p N$' ^ " E C character that will remain at @@ -1072,7 +989,7 @@ may also be expressed as either of: where 7E is the hexadecimal ASCII code point for '~'. Here is an example of decoding such a URL under CCSID 1047: - my $url = 'http://www.pvhp.com/%7Epvhp/'; + $url = 'http://www.pvhp.com/%7Epvhp/'; # this array assumes code page 1047 my @a2e_1047 = ( 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, @@ -1097,7 +1014,7 @@ of decoding such a URL under CCSID 1047: Conversely, here is a partial solution for the task of encoding such a URL under the 1047 code page: - my $url = 'http://www.pvhp.com/~pvhp/'; + $url = 'http://www.pvhp.com/~pvhp/'; # this array assumes code page 1047 my @e2a_1047 = ( 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15, @@ -1117,7 +1034,7 @@ a URL under the 1047 code page: 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159 ); - # The following regular expression does not address the + # The following regular expression does not address the # mappings for: ('.' => '%2E', '/' => '%2F', ':' => '%3A') $url =~ s/([\t "#%&\(\),;<=>\?\@\[\\\]^`{|}~])/sprintf("%%%02X",$e2a_1047[ord($1)])/ge; @@ -1134,13 +1051,10 @@ The C template to pack() or unpack() will render EBCDIC data in EBCDIC characters equivalent to their ASCII counterparts. For example, the following will print "Yes indeed\n" on either an ASCII or EBCDIC computer: - my $all_byte_chrs = ''; - - $all_byte_chrs .= chr($_) foreach 0 .. 255; - - my $uuencode_byte_chrs = pack('u', $all_byte_chrs); - - (my $uu = <<' ENDOFHEREDOC') =~ s/^\s*//gm; + $all_byte_chrs = ''; + for (0..255) { $all_byte_chrs .= chr($_); } + $uuencode_byte_chrs = pack('u', $all_byte_chrs); + ($uu = <<' ENDOFHEREDOC') =~ s/^\s*//gm; M``$"`P0%!@<("0H+#`T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL M+2XO,#$R,S0U-C'EZ>WQ]?G^`@8*#A(6& @@ -1148,22 +1062,21 @@ following will print "Yes indeed\n" on either an ASCII or EBCDIC computer: MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P`` ENDOFHEREDOC - if ( $uuencode_byte_chrs eq $uu ) { + if ($uuencode_byte_chrs eq $uu) { print "Yes "; } $uudecode_byte_chrs = unpack('u', $uuencode_byte_chrs); - if ( $uudecode_byte_chrs eq $all_byte_chrs ) { + if ($uudecode_byte_chrs eq $all_byte_chrs) { print "indeed\n"; } Here is a very spartan uudecoder that will work on EBCDIC provided that the @e2a array is filled in appropriately: - #!/usr/bin/perl - my @e2a = ( - # this must be filled in - ); - $_ = <> until my($mode,$file) = /^begin\s*(\d*)\s*(\S*)/; + #!/usr/local/bin/perl + @e2a = ( # this must be filled in + ); + $_ = <> until ($mode,$file) = /^begin\s*(\d*)\s*(\S*)/; open(OUT, "> $file") if $file ne ""; while(<>) { last if /^end/; @@ -1182,7 +1095,7 @@ On ASCII encoded machines it is possible to strip characters outside of the printable set using: # This QP encoder works on ASCII only - my $qp_string =~ s/([=\x00-\x1F\x80-\xFF])/sprintf("=%02X",ord($1))/ge; + $qp_string =~ s/([=\x00-\x1F\x80-\xFF])/sprintf("=%02X",ord($1))/ge; Whereas a QP encoder that works on both ASCII and EBCDIC machines would look somewhat like the following (where the EBCDIC branch @e2a @@ -1191,14 +1104,12 @@ array is omitted for brevity): if (ord('A') == 65) { # ASCII $delete = "\x7F"; # ASCII @e2a = (0 .. 255) # ASCII to ASCII identity map - - } else { # EBCDIC + } + else { # EBCDIC $delete = "\x07"; # EBCDIC - @e2a = ( - # EBCDIC to ASCII map (as shown above) - ); + @e2a = # EBCDIC to ASCII map (as shown above) } - my $qp_string =~ + $qp_string =~ s/([^ !"\#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~$delete])/sprintf("=%02X",$e2a[ord($1)])/ge; (although in production code the substitutions might be done @@ -1233,14 +1144,14 @@ work on ASCII and EBCDIC machines: #!/usr/local/bin/perl - while ( <> ) { + while(<>){ tr/n-za-mN-ZA-M/a-zA-Z/; print; } In one-liner form: - perl -pe 'tr/n-za-mN-ZA-M/a-zA-Z/' + perl -ne 'tr/n-za-mN-ZA-M/a-zA-Z/;print' =head1 Hashing order and checksums @@ -1386,3 +1297,5 @@ Thanks also to Vickie Cooper, Philip Newton, William Raffloer, and Joe Smith. Trademarks, registered trademarks, service marks and registered service marks used in this document are the property of their respective owners. + +