Don't like ads? PRO users don't see any ads ;-)
Public Pastes
Guest

Untitled

By: a guest on May 7th, 2012  |  syntax: None  |  size: 13.71 KB  |  hits: 19  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. #!perl
  2. use strict;
  3. use warnings 'all' => 'FATAL';
  4. require overload;
  5.  
  6. my $SELF           = 0;
  7. my $OTHER          = 1;
  8. my $INVERTED       = 2;
  9. my $TIED_PAYLOAD   = 0;
  10. my $UNTIED_PAYLOAD = 1;
  11. my $CODE           = 2;
  12.  
  13. print <<"HEADER";
  14. #
  15. # Devel/Spy/_overload.pm
  16. #
  17. # Copyright (C) ... by Joshua ben Jore
  18. #
  19. # You may distribute under the terms of either the GNU General Public
  20. # License or the Artistic License, as specified in the README file.
  21. #
  22. # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  23. #  This file is built by @{[__FILE__]} from its data.  Any changes made here
  24. #  will be lost!
  25. #
  26.  
  27. package Devel::Spy::_obj;
  28. use strict;
  29. use warnings;
  30.  
  31. require Sub::Name;
  32. require overload;
  33.  
  34. my \@overloading = (
  35. HEADER
  36.  
  37. print
  38.     map {
  39.         my $deref = $_;
  40.         <<"DEREFERENCING";
  41.     (
  42.         '${deref}',
  43.         Sub::Name::subname(
  44.             'Devel::Spy->${deref}',
  45.             sub {
  46.  
  47.                 # Allow ourselves to access our own guts and let
  48.                 # everyone else have the payload.
  49.                 if ( caller() eq 'Devel::Spy::_obj' ) {
  50.                     return \$_[$SELF];
  51.                 }
  52.                 else {
  53.                     # This idea is really dodgy but I found myself in
  54.                     # an infinite loop of some kind when I returned a
  55.                     # plain Devel::Spy object wrapping the
  56.                     # result. Bummer.
  57.                     my \$followup = \$_[$SELF][$CODE]->( ' ->$deref' );
  58.                     my \$tied = \$_[$SELF][$TIED_PAYLOAD];
  59.                     my \$reftype = CORE::ref( \$tied );
  60.                     my \$obj =
  61.                         'HASH'   eq \$reftype ? ( tied %\$tied  ) :
  62.                         'ARRAY'  eq \$reftype ? ( tied \@\$tied ) :
  63.                         \$reftype =~ /
  64.                             ^
  65.                             (?:
  66.                                 SCALAR
  67.                               | REF
  68.                               | LVALUE
  69.                               | REGEXP
  70.                               | VSTRING
  71.                               | BIND
  72.                             )
  73.                             \\z
  74.                         /x
  75.                             ? ( tied \$\$tied ) :
  76.                         'CODE'   eq \$reftype ? ( tied &\$tied  ) :
  77.                         \$reftype =~ /
  78.                             ^
  79.                             (?:
  80.                                 GLOB
  81.                               | FORMAT
  82.                               | IO
  83.                             )
  84.                             \\z
  85.                         /x
  86.                             ? ( tied *\$tied ) :
  87.                         die "Unknown reftype \$reftype for object \$tied";
  88.                     \$obj->[1] = \$followup;
  89.                     return \$tied;
  90.                 }
  91.             }
  92.         )
  93.     ),
  94. DEREFERENCING
  95.     }
  96.     split ' ',
  97.     $overload::ops{dereferencing};
  98.  
  99. print
  100.     map {
  101.         my $converter = $_;
  102.         <<"CONVERSION";
  103.     (
  104.         '${converter}',
  105.         Sub::Name::subname(
  106.             'Devel::Spy->${converter}',
  107.             sub {
  108.                 \$_[$SELF][$CODE]->(' ->$converter');
  109.                 return \$_[$SELF][$TIED_PAYLOAD];
  110.             }
  111.         )
  112.     ),
  113. CONVERSION
  114.     }
  115.     split ' ',
  116.     $overload::ops{conversion};
  117.  
  118. # Do a common things for all these common binary operators except |=,
  119. # &=, and ^= which are assignment operators and will handled
  120. # elsewhere.
  121. print
  122.     map {
  123.         my $op = $_;
  124.         <<"BINARY";
  125.     (
  126.         '${op}',
  127.         Sub::Name::subname(
  128.             'Devel::Spy->${op}',
  129.             sub {
  130.                 my ( \$result, \$followup );
  131.                 if ( \$_[$INVERTED] ) {
  132.                     \$result = \$_[$OTHER] $op \$_[$SELF][$TIED_PAYLOAD];
  133.                     \$followup = \$_[$SELF][$CODE]->(
  134.                         ' ->('
  135.                         . ( defined \$_[$OTHER]
  136.                             ? \$_[$OTHER]
  137.                             : 'undef')
  138.                         . ' $op '
  139.                         . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
  140.                             ? \$_[$SELF][$UNTIED_PAYLOAD]
  141.                             : 'undef')
  142.                         . ') ->'
  143.                         . overload::StrVal(\$result) );
  144.                 }
  145.                 else {
  146.                     \$result = \$_[$SELF][$TIED_PAYLOAD] $op \$_[$OTHER];
  147.                     \$followup = \$_[$SELF][$CODE]->(
  148.                         ' ->('
  149.                         . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
  150.                             ? \$_[$SELF][$UNTIED_PAYLOAD]
  151.                             : 'undef')
  152.                         . ' $op '
  153.                         . ( defined \$_[$OTHER]
  154.                             ? \$_[$OTHER]
  155.                             : 'undef')
  156.                         . ') ->'
  157.                         . overload::StrVal(\$result) );
  158.                 }
  159.                 return Devel::Spy->new( \$result, \$followup );
  160.             }
  161.         )
  162.     ),
  163. BINARY
  164.     }
  165.     grep { ! /^[|&^]=\z/ }
  166.     map split(' '),
  167.     @overload::ops{qw(
  168.         with_assign
  169.         num_comparison
  170.         3way_comparison
  171.         str_comparison
  172.         binary
  173.         matching
  174.     )};
  175.  
  176. # Handle ++ and --. Overload's copy constructor will take care of
  177. # post-inc/decrement by first making a copy of the value to return and
  178. # invoking ++/-- on the original.
  179. print
  180.     map {
  181.         my $op = $_;
  182.         <<"MUTATOR";
  183.     (
  184.         '${op}',
  185.         Sub::Name::subname(
  186.             'Devel::Spy->${op}',
  187.             sub {
  188.                 my \$result = $op \$_[$SELF][$TIED_PAYLOAD];
  189.                 my \$followup = \$_[$SELF][$CODE]->(
  190.                     ' ->($op '
  191.                     . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
  192.                         ? \$_[$SELF][$UNTIED_PAYLOAD]
  193.                         : 'undef' )
  194.                     . ') ->'
  195.                     . overload::StrVal(\$result) );
  196.                 return Devel::Spy->new( \$result, \$followup );
  197.             }
  198.         )
  199.     ),
  200. MUTATOR
  201.     }
  202.     split ' ',
  203.     $overload::ops{mutators};
  204.  
  205. # Handle assignment operators plus &=, |=, and ^= from 'binary'.
  206. print
  207.     map {
  208.         my $op = $_;
  209.         <<"ASSIGNMENT";
  210.     (
  211.         '${op}',
  212.         Sub::Name::subname(
  213.             'Devel::Spy->${op}',
  214.             sub {
  215.                 \$_[$SELF][$TIED_PAYLOAD] $op \$_[$OTHER];
  216.                 my \$followup = \$_[$SELF][$CODE]->(
  217.                     '->($op '
  218.                     . ( defined \$_[$OTHER]
  219.                         ? \$_[$OTHER]
  220.                         : 'undef' )
  221.                     . ') ->'
  222.                     . overload::StrVal(\$_[$SELF][$UNTIED_PAYLOAD]) );
  223.                 \$_[0] = Devel::Spy->new( \$_[$SELF][$UNTIED_PAYLOAD], \$followup );
  224.             }
  225.         )
  226.     ),
  227. ASSIGNMENT
  228.     }
  229.     grep { /=$/ }
  230.     map split(' '),
  231.     @overload::ops{qw(
  232.         assign
  233.         binary
  234.     )};
  235.  
  236. # Handle unary and math functions except atan2
  237. print
  238.     map {
  239.         my $op = $_;
  240.         my $actual_op = $op eq 'neg' ? '!' : $op;
  241.         <<"UNARY";
  242.     (
  243.         '${op}',
  244.         Sub::Name::subname(
  245.             'Devel::Spy->${op}',
  246.             sub {
  247.                 my \$result = $actual_op \$_[$SELF][$TIED_PAYLOAD];
  248.                 my \$followup = \$_[$SELF][$CODE]->(
  249.                     " ->($actual_op"
  250.                     . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
  251.                         ? \$_[$SELF][$UNTIED_PAYLOAD]
  252.                         : 'undef')
  253.                     . ') ->'
  254.                     . overload::StrVal(\$result) );
  255.                 return Devel::Spy->new( \$result, \$followup );
  256.             }
  257.         )
  258.     ),
  259. UNARY
  260.     }
  261.     grep { $_ ne 'atan2' }
  262.     map split(' '),
  263.     @overload::ops{qw(
  264.         unary
  265.         func
  266.     )};
  267.  
  268. # Handle <>.
  269. print <<"READLINE";
  270.     (
  271.         '<>',
  272.         Sub::Name::subname(
  273.             'Devel::Spy-><>',
  274.             sub {
  275.                 my \$result = readline \$_[$SELF][$TIED_PAYLOAD];
  276.                 my \$followup = \$_[$SELF][$CODE]->(
  277.                     ' ->(readline '
  278.                     . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
  279.                         ? \$_[$SELF][$UNTIED_PAYLOAD]
  280.                         : 'undef' )
  281.                     . ') ->'
  282.                     . overload::StrVal(\$result) );
  283.                 return Devel::Spy->new( \$result, \$followup );
  284.             }
  285.         )
  286.     ),
  287. READLINE
  288.  
  289. # Handle -X
  290. print <<"FILETEST";
  291.     (
  292.         '-X',
  293.         Sub::Name::subname(
  294.             'Devel::Spy->-X',
  295.             sub {
  296.                 my \$result =
  297.                     \$_[2] eq 'r' ? ( -r \$_[$SELF][$TIED_PAYLOAD] ) :
  298.                     \$_[2] eq 'w' ? ( -w \$_[$SELF][$TIED_PAYLOAD] ) :
  299.                     \$_[2] eq 'x' ? ( -x \$_[$SELF][$TIED_PAYLOAD] ) :
  300.                     \$_[2] eq 'o' ? ( -o \$_[$SELF][$TIED_PAYLOAD] ) :
  301.                     \$_[2] eq 'R' ? ( -R \$_[$SELF][$TIED_PAYLOAD] ) :
  302.                     \$_[2] eq 'W' ? ( -W \$_[$SELF][$TIED_PAYLOAD] ) :
  303.                     \$_[2] eq 'X' ? ( -X \$_[$SELF][$TIED_PAYLOAD] ) :
  304.                     \$_[2] eq 'O' ? ( -O \$_[$SELF][$TIED_PAYLOAD] ) :
  305.                     \$_[2] eq 'e' ? ( -e \$_[$SELF][$TIED_PAYLOAD] ) :
  306.                     \$_[2] eq 'z' ? ( -z \$_[$SELF][$TIED_PAYLOAD] ) :
  307.                     \$_[2] eq 's' ? ( -s \$_[$SELF][$TIED_PAYLOAD] ) :
  308.                     \$_[2] eq 'f' ? ( -f \$_[$SELF][$TIED_PAYLOAD] ) :
  309.                     \$_[2] eq 'd' ? ( -d \$_[$SELF][$TIED_PAYLOAD] ) :
  310.                     \$_[2] eq 'l' ? ( -l \$_[$SELF][$TIED_PAYLOAD] ) :
  311.                     \$_[2] eq 'p' ? ( -p \$_[$SELF][$TIED_PAYLOAD] ) :
  312.                     \$_[2] eq 'S' ? ( -S \$_[$SELF][$TIED_PAYLOAD] ) :
  313.                     \$_[2] eq 'b' ? ( -b \$_[$SELF][$TIED_PAYLOAD] ) :
  314.                     \$_[2] eq 'c' ? ( -c \$_[$SELF][$TIED_PAYLOAD] ) :
  315.                     \$_[2] eq 't' ? ( -t \$_[$SELF][$TIED_PAYLOAD] ) :
  316.                     \$_[2] eq 'u' ? ( -u \$_[$SELF][$TIED_PAYLOAD] ) :
  317.                     \$_[2] eq 'g' ? ( -g \$_[$SELF][$TIED_PAYLOAD] ) :
  318.                     \$_[2] eq 'k' ? ( -k \$_[$SELF][$TIED_PAYLOAD] ) :
  319.                     \$_[2] eq 'T' ? ( -T \$_[$SELF][$TIED_PAYLOAD] ) :
  320.                     \$_[2] eq 'B' ? ( -B \$_[$SELF][$TIED_PAYLOAD] ) :
  321.                     \$_[2] eq 'M' ? ( -M \$_[$SELF][$TIED_PAYLOAD] ) :
  322.                     \$_[2] eq 'A' ? ( -A \$_[$SELF][$TIED_PAYLOAD] ) :
  323.                     \$_[2] eq 'C' ? ( -C \$_[$SELF][$TIED_PAYLOAD] ) :
  324.                     eval( "-\$_[2] \$_[$SELF][$TIED_PAYLOAD]" );
  325.                 my \$followup = \$_[$SELF][$CODE]->(
  326.                     " ->(-\$_[2] "
  327.                     . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
  328.                         ? \$_[$SELF][$UNTIED_PAYLOAD]
  329.                         : 'undef' )
  330.                     . ') ->'
  331.                     . overload::StrVal(\$result) );
  332.                 return Devel::Spy->new( \$result, \$followup );
  333.             }
  334.         )
  335.     ),
  336. FILETEST
  337.  
  338. # Handle atan2
  339. print <<"ATAN2";
  340.     (
  341.         'atan2',
  342.         Sub::Name::subname(
  343.             'Devel::Spy->atan2',
  344.             sub {
  345.                 my ( \$result, \$followup );
  346.                 if ( \$_[$INVERTED] ) {
  347.                     \$result = atan2 \$_[$OTHER], \$_[$SELF][$TIED_PAYLOAD];
  348.                     \$followup = \$_[$SELF][$CODE]->(
  349.                         ' ->(atan2 '
  350.                         . ( defined \$_[$OTHER]
  351.                             ? \$_[$OTHER]
  352.                             : 'undef')
  353.                         . ', '
  354.                         . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
  355.                             ? \$_[$SELF][$UNTIED_PAYLOAD]
  356.                             : 'undef')
  357.                         . ') ->'
  358.                         . overload::StrVal(\$result) );
  359.                 }
  360.                 else {
  361.                     \$result = atan2 \$_[$SELF][$TIED_PAYLOAD], \$_[$OTHER];
  362.                     \$followup = \$_[$SELF][$CODE]->(
  363.                         ' ->(atan2 '
  364.                         . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
  365.                             ? \$_[$SELF][$UNTIED_PAYLOAD]
  366.                             : 'undef')
  367.                         . ', '
  368.                         . ( defined \$_[$OTHER]
  369.                             ? \$_[$OTHER]
  370.                             : 'undef')
  371.                         . ') ->'
  372.                         . overload::StrVal(\$result) );
  373.                 }
  374.                 return Devel::Spy->new( \$result, \$followup );
  375.             }
  376.         )
  377.     ),
  378. ATAN2
  379.  
  380. # Handle the copy constructor.
  381. print <<"COPY";
  382.     (
  383.         '=',
  384.         Sub::Name::subname(
  385.             'Devel::Spy->=',
  386.             sub {
  387.                 my \$class = CORE::ref \$_[$SELF];
  388.                 my \$followup = \$_[$SELF][$CODE]->(
  389.                     '->(= '
  390.                     . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
  391.                         ? \$_[$SELF][$UNTIED_PAYLOAD]
  392.                         : 'undef' )
  393.                     . ') -> ');
  394.                 return Devel::Spy->new( \$_[$SELF][$UNTIED_PAYLOAD], \$followup );
  395.             }
  396.         )
  397.     ),
  398. COPY
  399.  
  400. print <<"FALLBACK";
  401.     (
  402.         'fallback',
  403.         0
  404.     ),
  405. FALLBACK
  406.  
  407.  
  408.  
  409. print <<"FOOTER";
  410. );
  411.  
  412. overload->import( \@overloading );
  413.  
  414. # TEST: Verify that all overloadable operations have been overloaded
  415. for my \$category ( sort keys %overload::ops ) {
  416.     my \@ops = split ' ', \$overload::ops{\$category};
  417.     for my \$op ( \@ops ) {
  418.             next if \$category eq 'special' && \$op eq 'nomethod';
  419.             next if \$category eq 'special' && \$op eq 'fallback';
  420.  
  421.         no strict 'refs';
  422.  
  423.         next if defined &{"Devel::Spy::_obj::(\$op"};
  424.  
  425.         warn "Missing op [\$op] from category [\$category]";
  426.     }
  427. }
  428.  
  429. 1;
  430. FOOTER
create a new version of this paste RAW Paste Data