From: Casey West Date: Tue, 2 Oct 2001 19:24:43 +0000 (-0400) Subject: (retracted by #12338) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=769c28980682c9f2c20f6c60950b1b28469d23fa;p=p5sagit%2Fp5-mst-13.2.git (retracted by #12338) Subject: [PATCH] Code clean up for perlboot.pod Date: Tue, 2 Oct 2001 19:24:43 -0400 Message-ID: <20011002192443.B2163@stupid.geeknest.com> Subject: [PATCH] Code clean up for perlbot.diff From: Casey West Date: Tue, 2 Oct 2001 19:25:22 -0400 Message-ID: <20011002192522.C2163@stupid.geeknest.com> Subject: [PATCH] Code clean up for perlcall.pod From: Casey West Date: Tue, 2 Oct 2001 19:25:57 -0400 Message-ID: <20011002192557.D2163@stupid.geeknest.com> Subject: [PATCH] Code clean up for perldata.pod From: Casey West Date: Tue, 2 Oct 2001 19:26:29 -0400 Message-ID: <20011002192629.E2163@stupid.geeknest.com> Subject: [PATCH] Code clean up for perldbmfilter.pod From: Casey West Date: Tue, 2 Oct 2001 19:26:59 -0400 Message-ID: <20011002192659.F2163@stupid.geeknest.com> Subject: [PATCH] Code clean up for perlebcdic.pod From: Casey West Date: Tue, 2 Oct 2001 19:27:37 -0400 Message-ID: <20011002192737.G2163@stupid.geeknest.com> p4raw-id: //depot/perl@12313 --- diff --git a/pod/perlboot.pod b/pod/perlboot.pod index 8eaac86..ff6f1af 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 - @pasture = qw(Cow Cow Horse Sheep Sheep); - foreach $animal (@pasture) { + my @pasture = qw(Cow Cow Horse Sheep Sheep); + foreach my $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 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. +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. Or is it? @@ -87,12 +87,13 @@ 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: - $a = "Cow"; + my $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 C is enabled. +something that works even when L> is +enabled. =head2 Invoking a barnyard @@ -109,8 +110,8 @@ example: print "a Sheep goes baaaah!\n" } - @pasture = qw(Cow Cow Horse Sheep Sheep); - foreach $animal (@pasture) { + my @pasture = qw(Cow Cow Horse Sheep Sheep); + foreach my $animal (@pasture) { $animal->speak; } @@ -168,11 +169,14 @@ 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" } } @@ -180,8 +184,11 @@ 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" @@ -197,7 +204,9 @@ 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" @@ -207,8 +216,12 @@ definition for C: Then, for each animal, we say it "inherits" from C, along with the animal-specific sound: - { package Cow; + { + package Cow; + + # Not safe under `use strict', see below @ISA = qw(Animal); + sub sound { "moooo" } } @@ -256,32 +269,34 @@ The easiest is to just spell the package name out: Or allow it as an implicitly named package variable: package Cow; - use vars qw(@ISA); - @ISA = qw(Animal); + our @ISA = qw(Animal); If you're bringing in the class from outside, via an object-oriented module, you change: package Cow; use Animal; - use vars qw(@ISA); - @ISA = qw(Animal); + our @ISA = qw(Animal); into just: package Cow; use base qw(Animal); -And that's pretty darn compact. +And that's pretty darn compact. Read about the L pragma. =head2 Overriding the methods Let's add a mouse, which can barely be heard: - # Animal package from before - { package Mouse; - @ISA = qw(Animal); + # Animal package that we wrote before, goes here + { + package Mouse; + + our @ISA = qw(Animal); + sub sound { "squeak" } + sub speak { my $class = shift; print "a $class goes ", $class->sound, "!\n"; @@ -309,10 +324,14 @@ C does, but add in the extra comment? Sure! First, we can invoke the C method directly: - # Animal package from before - { package Mouse; - @ISA = qw(Animal); + # Animal package that we wrote before, goes here + { + package Mouse; + + our @ISA = qw(Animal); + sub sound { "squeak" } + sub speak { my $class = shift; Animal::speak($class); @@ -345,8 +364,11 @@ 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; @@ -372,8 +394,11 @@ 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; @@ -392,7 +417,7 @@ So far, we've seen the method arrow syntax: or the equivalent: - $a = "Class"; + my $a = "Class"; $a->method(@args); which constructs an argument list of: @@ -419,14 +444,20 @@ 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; - @ISA = qw(Animal); + + { + package Horse; + + our @ISA = qw(Animal); + sub sound { "neigh" } } @@ -448,7 +479,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 @@ -499,9 +530,13 @@ 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; - @ISA = qw(Animal); + { + package Horse; + + our @ISA = qw(Animal); + sub sound { "neigh" } + sub name { my $self = shift; $$self; @@ -530,16 +565,21 @@ 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; - @ISA = qw(Animal); + { + package Horse; + + our @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; } } @@ -570,23 +610,31 @@ 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; - @ISA = qw(Animal); + + { + package Horse; + + our @ISA = qw(Animal); + sub sound { "neigh" } } @@ -615,7 +663,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 } @@ -625,7 +673,8 @@ 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: @@ -642,34 +691,46 @@ 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; - @ISA = qw(Animal); + + { + package Horse; + + our @ISA = qw(Animal); + sub sound { "neigh" } } - { package Sheep; - @ISA = qw(Animal); + + { + package Sheep; + + our @ISA = qw(Animal); + sub sound { "baaaah" } } @@ -677,6 +738,7 @@ And now try it out: my $talking = Horse->named("Mr. Ed"); $talking->eat("hay"); + Sheep->eat("grass"); which prints: @@ -705,7 +767,8 @@ looks at the reference is changed accordingly. Let's make a sheep that has a name and a color: - my $bad = bless { Name => "Evil", Color => "black" }, Sheep; + my $data = { Name => "Evil", Color => "black" }; + my $bad = bless $data, 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 @@ -726,8 +789,9 @@ 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; } @@ -758,6 +822,7 @@ 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 bc4e4da..17b3755 100644 --- a/pod/perlbot.pod +++ b/pod/perlbot.pod @@ -82,11 +82,13 @@ 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; } @@ -94,23 +96,25 @@ 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; - $a = Foo->new( 'High' => 42, 'Low' => 11 ); - print "High=$a->{'High'}\n"; - print "Low=$a->{'Low'}\n"; + my $a = Foo->new( High => 42, Low => 11 ); + print "High = $a->{High}\n"; + print "Low = $a->{Low}\n"; - $b = Bar->new( 'Left' => 78, 'Right' => 40 ); - print "Left=$b->[0]\n"; - print "Right=$b->[1]\n"; + my $b = Bar->new( Left => 78, Right => 40 ); + print "Left = $b->[0]\n"; + print "Right = $b->[1]\n"; =head1 SCALAR INSTANCE VARIABLES @@ -120,15 +124,15 @@ An anonymous scalar can be used when only one instance variable is needed. sub new { my $type = shift; - my $self; - $self = shift; + my $self = shift; + bless \$self, $type; } package main; - $a = Foo->new( 42 ); - print "a=$$a\n"; + my $a = Foo->new( 42 ); + print "a = $$a\n"; =head1 INSTANCE VARIABLE INHERITANCE @@ -143,25 +147,29 @@ object. sub new { my $type = shift; my $self = {}; - $self->{'buz'} = 42; + + $self->{buz} = 42; + bless $self, $type; } package Foo; - @ISA = qw( Bar ); + our @ISA = qw( Bar ); sub new { my $type = shift; my $self = Bar->new; - $self->{'biz'} = 11; + + $self->{biz} = 11; + bless $self, $type; } package main; - $a = Foo->new; - print "buz = ", $a->{'buz'}, "\n"; - print "biz = ", $a->{'biz'}, "\n"; + my $a = Foo->new; + print "buz = $a->{buz}\n"; + print "biz = $a->{biz}\n"; @@ -175,7 +183,9 @@ relationships between objects. sub new { my $type = shift; my $self = {}; - $self->{'buz'} = 42; + + $self->{buz} = 42; + bless $self, $type; } @@ -184,16 +194,18 @@ 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; - $a = Foo->new; - print "buz = ", $a->{'Bar'}->{'buz'}, "\n"; - print "biz = ", $a->{'biz'}, "\n"; + my $a = Foo->new; + print "buz = $a->{Bar}->{buz}\n"; + print "biz = $a->{biz}\n"; @@ -207,14 +219,17 @@ where that method is defined. package Buz; sub goo { print "here's the goo\n" } - package Bar; @ISA = qw( Buz ); + + package Bar; + our @ISA = qw( Buz ); sub google { print "google here\n" } + package Baz; sub mumble { print "mumbling\n" } package Foo; - @ISA = qw( Bar Baz ); + our @ISA = qw( Bar Baz ); sub new { my $type = shift; @@ -236,7 +251,7 @@ where that method is defined. package main; - $foo = Foo->new; + my $foo = Foo->new; $foo->mumble; $foo->grr; $foo->goo; @@ -250,24 +265,28 @@ This example demonstrates an interface for the SDBM class. This creates a package Mydbm; - require SDBM_File; - require Tie::Hash; - @ISA = qw( Tie::Hash ); + use SDBM_File; + use Tie::Hash; + + our @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"; @@ -277,13 +296,13 @@ This example demonstrates an interface for the SDBM class. This creates a package main; use Fcntl qw( O_RDWR O_CREAT ); - tie %foo, "Mydbm", "Sdbm", O_RDWR|O_CREAT, 0640; - $foo{'bar'} = 123; - print "foo-bar = $foo{'bar'}\n"; + tie my %foo, 'Mydbm', 'Sdbm', O_RDWR|O_CREAT, 0640; + $foo{bar} = 123; + print "foo-bar = $foo{bar}\n"; - tie %bar, "Mydbm", "Sdbm2", O_RDWR|O_CREAT, 0640; - $bar{'Cathy'} = 456; - print "bar-Cathy = $bar{'Cathy'}\n"; + tie my %bar, 'Mydbm', 'Sdbm2', O_RDWR|O_CREAT, 0640; + $bar{Cathy} = 456; + print "bar-Cathy = $bar{Cathy}\n"; =head1 THINKING OF CODE REUSE @@ -301,6 +320,7 @@ that it is impossible to override the BAZ() method. my $type = shift; bless {}, $type; } + sub bar { my $self = shift; $self->FOO::private::BAZ; @@ -314,7 +334,7 @@ that it is impossible to override the BAZ() method. package main; - $a = FOO->new; + my $a = FOO->new; $a->bar; Now we try to override the BAZ() method. We would like FOO::bar() to call @@ -327,6 +347,7 @@ FOO::private::BAZ(). my $type = shift; bless {}, $type; } + sub bar { my $self = shift; $self->FOO::private::BAZ; @@ -339,7 +360,9 @@ FOO::private::BAZ(). } package GOOP; - @ISA = qw( FOO ); + + our @ISA = qw( FOO ); + sub new { my $type = shift; bless {}, $type; @@ -351,7 +374,7 @@ FOO::private::BAZ(). package main; - $a = GOOP->new; + my $a = GOOP->new; $a->bar; To create reusable code we must modify class FOO, flattening class @@ -364,6 +387,7 @@ method GOOP::BAZ() to be used in place of FOO::BAZ(). my $type = shift; bless {}, $type; } + sub bar { my $self = shift; $self->BAZ; @@ -374,19 +398,21 @@ method GOOP::BAZ() to be used in place of FOO::BAZ(). } package GOOP; - @ISA = qw( FOO ); + + our @ISA = qw( FOO ); sub new { my $type = shift; bless {}, $type; } + sub BAZ { print "in GOOP::BAZ\n"; } package main; - $a = GOOP->new; + my $a = GOOP->new; $a->bar; =head1 CLASS CONTEXT AND THE OBJECT @@ -409,12 +435,12 @@ method where that data is located. package Bar; - %fizzle = ( 'Password' => 'XYZZY' ); + my %fizzle = ( Password => 'XYZZY' ); sub new { my $type = shift; my $self = {}; - $self->{'fizzle'} = \%fizzle; + $self->{fizzle} = \%fizzle; bless $self, $type; } @@ -425,27 +451,29 @@ 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 ); - %fizzle = ( 'Password' => 'Rumple' ); + our @ISA = qw( Bar ); + + my %fizzle = ( Password => 'Rumple' ); sub new { my $type = shift; my $self = Bar->new; - $self->{'fizzle'} = \%fizzle; + $self->{fizzle} = \%fizzle; bless $self, $type; } package main; - $a = Bar->new; - $b = Foo->new; + my $a = Bar->new; + my $b = Foo->new; + $a->enter; $b->enter; @@ -468,7 +496,8 @@ object will be a BAR not a FOO, even though the constructor is in class FOO. } package BAR; - @ISA = qw(FOO); + + our @ISA = qw(FOO); sub baz { print "in BAR::baz()\n"; @@ -476,7 +505,7 @@ object will be a BAR not a FOO, even though the constructor is in class FOO. package main; - $a = BAR->new; + my $a = BAR->new; $a->baz; =head1 DELEGATION @@ -493,14 +522,16 @@ behavior by adding custom FETCH() and STORE() methods, if this is desired. package Mydbm; - require SDBM_File; - require Tie::Hash; - @ISA = qw(Tie::Hash); + use SDBM_File; + use Tie::Hash; + + our @ISA = qw( Tie::Hash ); + our $AUTOLOAD; sub TIEHASH { my $type = shift; - my $ref = SDBM_File->new(@_); - bless {'delegate' => $ref}; + my $ref = SDBM_File->new(@_); + bless { delegate => $ref }; } sub AUTOLOAD { @@ -516,12 +547,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 %foo, "Mydbm", "adbm", O_RDWR|O_CREAT, 0640; - $foo{'bar'} = 123; - print "foo-bar = $foo{'bar'}\n"; + tie my %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 40f1d65..d072f00 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -259,13 +259,15 @@ 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 @@ -392,11 +394,9 @@ 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,9 +450,8 @@ 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 @@ -511,10 +510,9 @@ 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. @@ -643,10 +641,9 @@ 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 @@ -748,10 +745,9 @@ 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 @@ -874,10 +870,9 @@ 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. @@ -933,13 +928,12 @@ 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 @@ -1041,16 +1035,21 @@ 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 {}, $_[0] } + + sub new { bless {}, shift } + 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 @@ -1077,12 +1076,11 @@ 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. @@ -1111,11 +1109,12 @@ I instead of I. Because we are using an SV to call I the following can all be used - CallSubSV("fred") ; - CallSubSV(\&fred) ; - $ref = \&fred ; - CallSubSV($ref) ; - CallSubSV( sub { print "Hello there\n" } ) ; + CallSubSV("fred"); + CallSubSV(\&fred); + + my $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. @@ -1144,11 +1143,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. @@ -1160,10 +1159,11 @@ for each of the C lines. Similarly, with this code - $ref = \&fred ; - SaveSub1($ref) ; - $ref = 47 ; - CallSavedSub1() ; + my $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,10 +1183,11 @@ loudly. A similar but more subtle problem is illustrated with this code - $ref = \&fred ; - SaveSub1($ref) ; - $ref = \&joe ; - CallSavedSub1() ; + my $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 @@ -1228,11 +1229,12 @@ 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 @@ -1256,25 +1258,22 @@ This is because I will do it for you. Consider the following Perl code { - 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" ; - } + 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"; + } } It implements just a very simple class to manage an array. Apart from @@ -1283,9 +1282,10 @@ 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. - $a = new Mine ('red', 'green', 'blue') ; - $a->Display(1) ; - PrintID Mine; + my $a = Mine->new('red', 'green', 'blue'); + $a->Display(1); + + Mine->PrintID; will print @@ -1342,9 +1342,9 @@ the C and C methods from C. So the methods C and C can be invoked like this - $a = new Mine ('red', 'green', 'blue') ; - call_Method($a, 'Display', 1) ; - call_PrintID('Mine', 'PrintID') ; + my $a = Mine->new('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 ; - $a = PrintContext ; - @a = PrintContext ; + my $a = PrintContext; + my @a = PrintContext; The output from that will be @@ -1551,9 +1551,8 @@ 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 @@ -1652,15 +1651,14 @@ 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 968588d..9155abc 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: - @whatever = (); + my @whatever = (); $#whatever = -1; If you evaluate an array in scalar context, it returns the length @@ -233,13 +233,6 @@ 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 @@ -261,6 +254,7 @@ 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 @@ -306,8 +300,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." - $Price = '$100'; # not interpreted - print "The price is $Price.\n"; # interpreted + my $Price = '$100'; # not interpolated + print "The price is $Price.\n"; # interpolated As in some shells, you can enclose the variable name in braces to disambiguate it from following alphanumerics (and underscores). @@ -316,7 +310,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: - $who = "Larry"; + my $who = "Larry"; print PASSWD "${who}::0:0:Superuser:/:/bin/perl\n"; print "We use ${who}speak when ${who}'s here.\n"; @@ -399,7 +393,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: - $temp = join($", @ARGV); + my $temp = join($", @ARGV); system "echo $temp"; system "echo @ARGV"; @@ -466,7 +460,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: - ($quote = <<'FINIS') =~ s/^\s+//gm; + (my $quote = <<'FINIS') =~ s/^\s+//gm; The Road goes ever on and on, down from the door where it began. FINIS @@ -515,23 +509,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, - @foo = ('cc', '-E', $bar); + my @foo = ('cc', '-E', $bar); assigns the entire list value to array @foo, but - $foo = ('cc', '-E', $bar); + my $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: - @foo = ('cc', '-E', $bar); - $foo = @foo; # $foo gets 3 + my @foo = ('cc', '-E', $bar); + my $foo = @foo; # $foo gets 3 You may have an optional comma before the closing parenthesis of a list literal, so that you can say: - @foo = ( + my @foo = ( 1, 2, 3, @@ -540,7 +534,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: - @sauces = < in a list. This is useful for throwing away some of the return values of a function: - ($dev, $ino, undef, undef, $uid, $gid) = stat($file); + my($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: - $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2 - $x = (($foo,$bar) = f()); # set $x to f()'s return count + 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 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, @@ -618,7 +612,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: - $count = () = $string =~ /\d+/g; + my $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 @@ -628,14 +622,15 @@ 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 - $count = $string =~ /\d+/g; + my $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: - ($a, $b, @rest) = split; + my($a, $b, @rest) = split; + # or my($a, $b, %rest) = @_; You can actually put an array or hash anywhere in the list, but the first one @@ -646,7 +641,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 - %map = ('red',0x00f,'blue',0x0f0,'green',0xf00); + my %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 @@ -661,7 +656,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: - %map = ( + my %map = ( red => 0x00f, blue => 0x0f0, green => 0xf00, @@ -669,7 +664,7 @@ This makes it nice for initializing hashes: or for initializing hash references to be used as records: - $rec = { + my $rec = { witch => 'Mable the Merciless', cat => 'Fluffy the Ferocious', date => '10/31/1776', @@ -677,12 +672,14 @@ or for initializing hash references to be used as records: or for using call-by-named-parameter to complicated functions: - $field = $query->radio_group( + use CGI; + my $query = CGI->new; + my $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 @@ -694,34 +691,36 @@ 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. - $whoami = $ENV{"USER"}; # one element from the hash - $parent = $ISA[0]; # one element from the array - $dir = (getpwnam("daemon"))[7]; # likewise, but with list + 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 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. - ($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 + 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 Since you can assign to a list of variables, you can also assign to an array or hash slice. - @days[3..5] = qw/Wed Thu Fri/; + my( @days, %colors, @folks ); + @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 - ($days[3], $days[4], $days[5]) = qw/Wed Thu Fri/; - ($colors{'red'}, $colors{'blue'}, $colors{'green'}) + my( @days, %colors, @folks ); + ($days[3], $days[4], $days[5]) = qw(Wed Thu Fri); + ($colors{red}, $colors{blue}, $colors{green}) = (0xff0000, 0x0000ff, 0x00ff00); - ($folks[0], $folks[-1]) = ($folks[0], $folks[-1]); + ($folks[0], $folks[-1]) = ($folks[-1], $folks[0]); 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 @@ -737,19 +736,19 @@ values of the array or hash. A slice of an empty list is still an empty list. Thus: - @a = ()[1,0]; # @a has no elements - @b = (@a)[0,1]; # @b has no elements - @c = (0,1)[2,3]; # @c has no elements + 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 But: - @a = (1)[1,0]; # @a has two elements - @b = (1,undef)[1,0,2]; # @b has three elements + my @a = (1)[1,0]; # @a has two elements + my @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 ( ($home, $user) = (getpwent)[7,0]) { + while ( my($home, $user) = (getpwent)[7,0] ) { printf "%-8s %s\n", $user, $home; } @@ -776,6 +775,8 @@ 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 @@ -788,17 +789,18 @@ 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. +module import/export system. And none of it works under +C. 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: - $fh = *STDOUT; + my $fh = *STDOUT; or perhaps as a real reference, like this: - $fh = \*STDOUT; + my $fh = \*STDOUT; See L for examples of using these as indirect filehandles in functions. @@ -813,7 +815,7 @@ For example: open (FH, $path) or return undef; return *FH; } - $fh = newopen('/etc/passwd'); + my $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 @@ -833,8 +835,9 @@ largely eliminates the need for typeglobs when opening filehandles that must be passed around, as in the following example: sub myopen { - open my $fh, "@_" - or die "Can't open '@_': $!"; + my $filename = shift; + open my $fh, $filename + or die "Can't open '$filename': $!"; return $fh; } diff --git a/pod/perldbmfilter.pod b/pod/perldbmfilter.pod index 8384999..f10bdd0 100644 --- a/pod/perldbmfilter.pod +++ b/pod/perldbmfilter.pod @@ -4,12 +4,13 @@ perldbmfilter - Perl DBM Filters =head1 SYNOPSIS - $db = tie %hash, 'DBM', ... + my $db = tie my %hash, 'DBM', ...; - $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 { ... } ) ; + 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 { ... } ); =head1 DESCRIPTION @@ -85,30 +86,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. @@ -124,7 +125,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 @@ -133,23 +134,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/perlebcdic.pod b/pod/perlebcdic.pod index c98b46c..be2a2e3 100644 --- a/pod/perlebcdic.pod +++ b/pod/perlebcdic.pod @@ -130,8 +130,29 @@ work with a pod2_other_format translation) through: =back - 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 + 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, + ); + } + } If you want to retain the UTF-x code points then in script form you might want to write: @@ -142,20 +163,47 @@ might want to write: =back - 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); + 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 + ); } } } + close FH; If you would rather see this table listing hexadecimal values then run the table through: @@ -166,8 +214,9 @@ run the table through: =back - 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 + 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)}' Or, in order to retain the UTF-x code points in hexadecimal: @@ -177,21 +226,50 @@ Or, in order to retain the UTF-x code points in hexadecimal: =back - open(FH,") { - 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); + 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 + ); } - 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 @@ -454,6 +532,7 @@ 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: @@ -463,11 +542,12 @@ ASCII + Latin-1 order then run the table through: =back - 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 + 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;}' If you would rather see it in CCSID 1047 order then change the digit 42 in the last line to 51, like this: @@ -478,11 +558,12 @@ If you would rather see it in CCSID 1047 order then change the digit =back - 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 + 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;}' If you would rather see it in POSIX-BC order then change the digit 51 in the last line to 60, like this: @@ -493,11 +574,12 @@ If you would rather see it in POSIX-BC order then change the digit =back - 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 + 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;}' =head1 IDENTIFYING CHARACTER CODE SETS @@ -506,44 +588,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: - $is_ascii = "A" eq chr(65); - $is_ebcdic = "A" eq chr(193); + my $is_ascii = "A" eq chr(65); + my $is_ebcdic = "A" eq chr(193); Also, "\t" is a C character so that: - $is_ascii = ord("\t") == 9; - $is_ebcdic = ord("\t") == 5; + my $is_ascii = ord("\t") == 9; + my $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: - $is_ebcdic_37 = "\n" eq chr(37); - $is_ebcdic_1047 = "\n" eq chr(21); + my $is_ebcdic_37 = "\n" eq chr(37); + my $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.: - $is_ascii = ord('[') == 91; - $is_ebcdic_37 = ord('[') == 186; - $is_ebcdic_1047 = ord('[') == 173; - $is_ebcdic_POSIX_BC = ord('[') == 187; + my $is_ascii = ord('[') == 91; + my $is_ebcdic_37 = ord('[') == 186; + my $is_ebcdic_1047 = ord('[') == 173; + my $is_ebcdic_POSIX_BC = ord('[') == 187; However, it would be unwise to write tests such as: - $is_ascii = "\r" ne chr(13); # WRONG - $is_ascii = "\n" ne chr(10); # ILL ADVISED + my $is_ascii = "\r" ne chr(13); # WRONG + my $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; - $is_ebcdic = $Config{'ebcdic'} eq 'define'; + my $is_ebcdic = $Config{'ebcdic'} eq 'define'; =head1 CONVERSIONS @@ -556,29 +638,30 @@ 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: - $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 $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]; 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/// @@ -601,12 +684,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 - $ascii_data = `echo '$ebcdic_data'| iconv -f IBM-1047 -t ISO8859-1` + my $ascii_data = `echo '$ebcdic_data'| iconv -f IBM-1047 -t ISO8859-1` or the inverse map: # OS/390 or z/OS example - $ebcdic_data = `echo '$ascii_data'| iconv -f ISO8859-1 -t IBM-1047` + my $ebcdic_data = `echo '$ascii_data'| iconv -f ISO8859-1 -t IBM-1047` For other perl based conversion options see the Convert::* modules on CPAN. @@ -621,7 +704,7 @@ care on EBCDIC machines. For example the following array will have twenty six elements on either an EBCDIC machine or an ASCII machine: - @alphabet = ('A'..'Z'); # $#alphabet == 25 + my @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 @@ -629,10 +712,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 @@ -989,7 +1072,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: - $url = 'http://www.pvhp.com/%7Epvhp/'; + my $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, @@ -1014,7 +1097,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: - $url = 'http://www.pvhp.com/~pvhp/'; + my $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, @@ -1034,7 +1117,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; @@ -1051,10 +1134,13 @@ 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: - $all_byte_chrs = ''; - for (0..255) { $all_byte_chrs .= chr($_); } - $uuencode_byte_chrs = pack('u', $all_byte_chrs); - ($uu = <<' ENDOFHEREDOC') =~ s/^\s*//gm; + 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; 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& @@ -1062,21 +1148,22 @@ 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/local/bin/perl - @e2a = ( # this must be filled in - ); - $_ = <> until ($mode,$file) = /^begin\s*(\d*)\s*(\S*)/; + #!/usr/bin/perl + my @e2a = ( + # this must be filled in + ); + $_ = <> until my($mode,$file) = /^begin\s*(\d*)\s*(\S*)/; open(OUT, "> $file") if $file ne ""; while(<>) { last if /^end/; @@ -1095,7 +1182,7 @@ On ASCII encoded machines it is possible to strip characters outside of the printable set using: # This QP encoder works on ASCII only - $qp_string =~ s/([=\x00-\x1F\x80-\xFF])/sprintf("=%02X",ord($1))/ge; + my $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 @@ -1104,12 +1191,14 @@ 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) + ); } - $qp_string =~ + my $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 @@ -1144,14 +1233,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 -ne 'tr/n-za-mN-ZA-M/a-zA-Z/;print' + perl -pe 'tr/n-za-mN-ZA-M/a-zA-Z/' =head1 Hashing order and checksums @@ -1297,5 +1386,3 @@ 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. - -