Source code of Windows XP (NT5)
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

77 lines
1.8 KiB

  1. =head1 NAME
  2. base - Establish IS-A relationship with base class at compile time
  3. =head1 SYNOPSIS
  4. package Baz;
  5. use base qw(Foo Bar);
  6. =head1 DESCRIPTION
  7. Roughly similar in effect to
  8. BEGIN {
  9. require Foo;
  10. require Bar;
  11. push @ISA, qw(Foo Bar);
  12. }
  13. Will also initialize the %FIELDS hash if one of the base classes has
  14. it. Multiple inheritance of %FIELDS is not supported. The 'base'
  15. pragma will croak if multiple base classes has a %FIELDS hash. See
  16. L<fields> for a description of this feature.
  17. When strict 'vars' is in scope I<base> also let you assign to @ISA
  18. without having to declare @ISA with the 'vars' pragma first.
  19. This module was introduced with Perl 5.004_04.
  20. =head1 SEE ALSO
  21. L<fields>
  22. =cut
  23. package base;
  24. sub import {
  25. my $class = shift;
  26. my $fields_base;
  27. foreach my $base (@_) {
  28. unless (defined %{"$base\::"}) {
  29. eval "require $base";
  30. # Only ignore "Can't locate" errors from our eval require.
  31. # Other fatal errors (syntax etc) must be reported.
  32. die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
  33. unless (defined %{"$base\::"}) {
  34. require Carp;
  35. Carp::croak("Base class package \"$base\" is empty.\n",
  36. "\t(Perhaps you need to 'use' the module ",
  37. "which defines that package first.)");
  38. }
  39. }
  40. # A simple test like (defined %{"$base\::FIELDS"}) will
  41. # sometimes produce typo warnings because it would create
  42. # the hash if it was not present before.
  43. my $fglob;
  44. if ($fglob = ${"$base\::"}{"FIELDS"} and *$fglob{HASH}) {
  45. if ($fields_base) {
  46. require Carp;
  47. Carp::croak("Can't multiply inherit %FIELDS");
  48. } else {
  49. $fields_base = $base;
  50. }
  51. }
  52. }
  53. my $pkg = caller(0);
  54. push @{"$pkg\::ISA"}, @_;
  55. if ($fields_base) {
  56. require fields;
  57. fields::inherit($pkg, $fields_base);
  58. }
  59. }
  60. 1;