#!/usr/local/bin/perl5
#
# This document is in the public domain.
#
# The purpose is to document by example some of the new Perl5 features.
# It also functions as a mini test suite; you can extracted the
# expected output using:
#     perl -ne 'm/.*prints ``(.*)..$/ && print $1,"\n";'
# There are a couple of places that print out internal address so it's
# not perfect yet, those should be fixed.
#
# Thanks to the following for their input:
#     Johan.Vromans@NL.net
#     Daniel Faken <absinthe@viva.chem.washington.edu>
#     Tom Christiansen <tchrist@wraeththu.cs.colorado.edu>
#     Dean Roehrich <roehrich@ferrari.cray.com>
#     Larry Wall <lwall@netlabs.com>
#
# TODO when I get perl5a6 to play with
#	*foo = \&func;			# replaces only function (etc)
#	AUTOLOAD { ...; }		# called if method not found
#	goto &func;			# goto's a function
#	require FOOBAR;			# loads FOOBAR.pm
#	@ISA
#
#	import()/@EXPORT/etc

#   my
	# static scoping
	sub samp1 { print $z,"\n"; }
	sub samp2 { my($z) = "world"; &samp1; }
	$z = "hello"; &samp2;		# prints ``hello''

#   package;
	# for catching non-local variable references
	sub samp3 {
	    my $x = shift;		# local() would work also
	    package;			# empty package
	    $main::count += $x;		# this is ok.
	    # $y = 1;			# compile time error
	}

#   =>
	# works like comma (,); use for key/value pairs
        # sometimes used to disambiguate the final expression in a block
	# might someday supply warnings if you get out of sync
	%foo = ( abc => foo );
	print $foo{abc},"\n";		# prints ``foo''

#   ::
	# works like tick (') (use of ' is deprecated in perl5)
        print $main::foo{abc},"\n";	# prints ``foo''

#   bless ref;
	# Bless takes a reference and returns an "object"
	$oref = bless \$scalar;

#   ->
	# dereferences an "object"
	$x = { def => bar };		# $x is ref to anonymous hash
	print $x->{def},"\n";		# prints ``bar''

	# method derefs must be bless'ed
	{
	    package sample;
	    sub samp4 { my($this) = shift; print $this->{def},"\n"; }
	    sub samp5 { print "samp5: @_\n"; }
	    $main::y = bless $main::x;	# $x is ref, $y is "object"
	}
	$y->samp4();			# prints ``bar''

	# indirect object calls
	samp5 $y arglist;		# prints ``samp5: sample=HASH(0xa85e0) arglist''

	# static method calls (often used for constructors, see below)
	samp5 sample arglist;		# prints ``samp5: sample arglist''

#   function calls without &
	sub samp6 { print "look ma\n"; }
	samp6;				# prints ``look ma''

#   ref
	# returns "object" type
	{
	    package OBJ1;
	    $x = bless \$y;		# returns "object" $x in "class" OBJ1
	    print ref $x,"\n";		# prints ``OBJ1''
	}

	# and non-references return undef.
	$z = 1;
	print "non-ref\n" if !defined(ref $z);		# prints ``non-ref''

	# ref's to "builtins" return type
	print ref \$ascalar,"\n";		# prints ``SCALAR''
	print ref \@array,"\n";			# prints ``ARRAY''
	print ref \%hash,"\n";			# prints ``HASH''
	sub func { print shift,"\n"; }
	print ref \&func,"\n";			# prints ``CODE''
	print ref \\$scalar,"\n";		# prints ``REF''

#   tie
	# bind a variable to a package with magic functions:
        #     new, fetch, store, delete, firstkey, nextkey (XXX: others???)
	# Usage: tie variable, PackageName, ARGLIST
	{
	    package TIEPACK;
	    sub new { print "NEW: @_\n"; my($class, $x) = @_; bless \$x }
	    sub fetch { print "fetch @_\n"; my($this) = @_; ${$this} }
	    sub store { print "store @_\n"; my($this, $x) = @_; ${$this} = $x }
	    sub DESTROY { print "DESTROY @_\n" }
	}
	tie $h, TIEPACK, "black_tie";	# prints ``NEW: TIEPACK black_tie''
	print $h, "\n";			# prints ``fetch TIEPACK=SCALAR(0x882a0)''
					# prints ``black_tie''
	$h = 'bar';			# prints ``store TIEPACK=SCALAR(0x882a0) bar''
	untie $h;			# DESTROY (XXX: broken in perl5a5???)

#   References and Anonymous data-structures
	$sref = \$scalar;		# $$sref is scalar
	$aref = \@array;		# @$aref is array
	$href = \%hash;			# %$href is hash table
	$fref = \&func;			# &$fref is function
	$refref = \$fref;		# ref to ref to function
	&$$refref("call the function");	# prints ``call the function''

	%hash = ( abc => foo );		# hash (just like perl4)
	print $hash{abc},"\n";		# prints ``foo''
	$ref = { abc => bar };		# reference to anon hash
	print $ref->{abc},"\n";		# prints ``bar''

	@ary = ( 0, 1, 2 );		# array (just like perl4)
	print $ary[1],"\n";		# prints ``1''
	$ref = [ 3, 4, 5 ];		# reference to anon array
	print $ref->[1],"\n";		# prints ``4''

#   Nested data-structures
	@foo = ( 0, { name => foobar }, 2, 3 );		# $#foo == 3
	$aref = [ 0, { name => foobar }, 2, 3 ];	# ref to anon array
	$href = {					# ref to hash of arrays
	    John => [ Mary, Pat, Blanch ],
	    Paul => [ Sally, Jill, Jane ],
	    Mark => [ Ann, Bob, Dawn ],
	};
	print $href->{Paul}->[0], "\n";			# prints ``Sally''
	print $href->{Paul}[0],"\n";			# shorthand version, prints ``Sally''

#   Multiple Inheritence (get rich quick :-)
	{
	    package OBJ2; sub abc { print "abc\n"; }
	    package OBJ3; sub def { print "def\n"; }
	    package OBJ4; @ISA = ("OBJ2", "OBJ3");
	    $x = bless { foo => bar };
	    $x->abc;					# prints ``abc''
	    $x->def;					# prints ``def''
	}

#   Packages, Classes, Objects, Methods, Constructors, Destructors, etc.
    	# XXX: I'll add more explinations/samples about the above here
	{
	    package OBJ5;
	    sub new { print "NEW: @_\n"; my($x) = "empty"; bless \$x }
	    sub DESTROY { print "DESTROY\n" }
	    sub output { my($this) = shift; print "value = $$this\n"; }
	}
	# Constructors are often written as static method calls:
	$x = new OBJ5;		# prints ``NEW: OBJ5''
	$x->output;		# prints ``value = empty''
	# The destructor is responsible for calling any base class destructors.
	undef $x;