home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _8fd59184c310ab52079e99a6cbf1f5cb < prev    next >
Encoding:
Text File  |  2004-06-01  |  2.7 KB  |  143 lines
  1. package PPM::Result;
  2.  
  3. use strict;
  4. use Exporter;
  5. use Text::Autoformat;
  6. use Data::Dumper;
  7.  
  8. $PPM::Result::VERSION    = '3.00';
  9. @PPM::Result::ISA    = qw(Exporter);
  10. @PPM::Result::EXPORT_OK    = qw(Error Warning Ok Success List Hash);
  11.  
  12. #=============================================================================
  13. # Shortcut constructors for various types of results
  14. #=============================================================================
  15. sub Error {
  16.     my $msg = shift;
  17.     my $code = shift || 1;
  18.     my $res = shift;
  19.     PPM::Result->new($res, $code, $msg);
  20. }
  21.  
  22. sub Warning {
  23.     my $msg = shift;
  24.     my $code = shift || -1;
  25.     my $res = shift;
  26.     PPM::Result->new($res, $code, $msg);
  27. }
  28.  
  29. sub Ok {
  30.     Success(@_);
  31. }
  32.  
  33. sub Success {
  34.     PPM::Result->new(@_);
  35. }
  36.  
  37. # Shortcut for returning a list, successfully.
  38. sub List {
  39.     my @list = @_;
  40.     Ok(\@list);
  41. }
  42.  
  43. # Shortcut for returning a hash, successfully.
  44. sub Hash {
  45.     my %hash = @_;
  46.     Ok(\%hash);
  47. }
  48.  
  49. #=============================================================================
  50. # The class implementation
  51. #=============================================================================
  52. sub new {
  53.     my $self   = shift;
  54.     my $class  = ref($self) || $self;
  55.     my $result = shift;
  56.     $result = '' unless defined $result;
  57.     my $code   = shift || '0';
  58.     my $msg    = shift || '';
  59.     chomp $msg;
  60.     bless {
  61.     result => $result,
  62.     code   => $code,
  63.     msg    => $msg,
  64.     on_destruct => [],
  65.     }, $class;
  66. }
  67.  
  68. sub DESTROY {
  69.     my $o = shift;
  70.     for my $cref (@{$o->{on_destruct}}) {
  71.     $cref->($o);
  72.     }
  73. }
  74.  
  75. sub on_destruct {
  76.     my $o = shift;
  77.     my $cref = shift;
  78.     push @{$o->{on_destruct}}, $cref;
  79. }
  80.  
  81. sub ok {
  82.     my $o = shift;
  83.     $o->{code} <= 0;
  84. }
  85.  
  86. sub is_success {
  87.     my $o = shift;
  88.     $o->{code} == 0;
  89. }
  90.  
  91. sub is_warning {
  92.     my $o = shift;
  93.     $o->{code} < 0;
  94. }
  95.  
  96. sub is_error {
  97.     my $o = shift;
  98.     $o->{code} > 0;
  99. }
  100.  
  101. sub errorcode {
  102.     my $o = shift;
  103.     $o->{code};
  104. }
  105.  
  106. sub msg {
  107.     my $o = shift;
  108.     my $w = $o->is_error    ? "Error: "    :
  109.         $o->is_warning    ? "Warning: "    :
  110.                   "Success";
  111.     $w .= $o->msg_raw;
  112.     $w .= "\n";
  113.     autoformat($w, { all => 1 } );
  114. }
  115.  
  116. sub msg_raw {
  117.     my $o = shift;
  118.     defined $o->{msg} ? $o->{msg} : '';
  119. }
  120.  
  121. sub result {
  122.     my $o = shift;
  123.     my $key = shift;
  124.     return $o->{result} unless defined $key;
  125.     return $o->{result}{$key} if eval { exists $o->{result}{$key} };
  126.     return $o->{result}[$key] if eval { exists $o->{result}[$key] };
  127.     return undef;
  128. }
  129. sub result_s {
  130.     my $o = shift;
  131.     scalar $o->result(@_);
  132. }
  133. sub result_l {
  134.     my $o = shift;
  135.     @{$o->result(@_)};
  136. }
  137. sub result_h {
  138.     my $o = shift;
  139.     %{$o->result(@_)};
  140. }
  141.  
  142. 1;
  143.