Aspect-1.04/0000755000175100017510000000000012130724444011246 5ustar adamadamAspect-1.04/Makefile.PL0000644000175100017510000000035612130724241013217 0ustar adamadamuse inc::Module::Install::DSL 1.06; all_from lib/Aspect.pm requires_from lib/Aspect.pm requires Task::Weaken 1.00 test_requires Test::More 0.70 test_requires Test::Exception 0.29 test_requires Test::NoWarnings 0.084 Aspect-1.04/META.yml0000644000175100017510000000152312130724401012511 0ustar adamadam--- abstract: 'Aspect-Oriented Programming (AOP) for Perl' author: - 'Adam Kennedy ' build_requires: ExtUtils::MakeMaker: 6.59 Test::Exception: 0.29 Test::More: 0.70 Test::NoWarnings: 0.084 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 0 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 module_name: Aspect name: Aspect no_index: directory: - examples - inc - t - xt requires: Params::Util: 1.00 Sub::Install: 0.92 Sub::Uplevel: 0.2002 Task::Weaken: 1.00 perl: 5.8.2 resources: ChangeLog: http://fisheye2.atlassian.com/changelog/cpan/trunk/Aspect license: http://dev.perl.org/licenses/ repository: http://svn.ali.as/cpan/trunk/Aspect version: 1.04 Aspect-1.04/LICENSE0000644000175100017510000005014012130724241012246 0ustar adamadam Terms of Perl itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" ---------------------------------------------------------------------------- GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS ---------------------------------------------------------------------------- The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Aspect-1.04/README0000644000175100017510000013165212130724241012131 0ustar adamadamNAME Aspect - Aspect-Oriented Programming (AOP) for Perl SYNOPSIS use Aspect; # Run some code "Advice" before a particular function before { print "About to call create\n"; } call 'Person::create'; # Run Advice after several methods and hijack their return values after { print "Called getter/setter " . $_->sub_name . "\n"; $_->return_value(undef); } call qr/^Person::[gs]et_/; # Run Advice conditionally based on multiple factors before { print "Calling a get method in void context within Tester::run_tests"; } wantvoid & ( call qr/^Person::get_/ & ! call 'Person::get_not_trapped' ) & cflow 'Tester::run_tests'; # Context-aware runtime hijacking of a method if certain condition is true around { if ( $_->self->customer_name eq 'Adam Kennedy' ) { # Ensure I always have cash $_->return_value('One meeeelion dollars'); } else { # Take a dollar off everyone else $_->proceed; $_->return_value( $_->return_value - 1 ); } } call 'Bank::Account::balance'; # Catch and handle unexpected exceptions in a function into a formal object after { $_->exception( Exception::Unexpected->new($_->exception) ); } throwing() & ! throwing('Exception::Expected') & ! throwing('Exception::Unexpected'); # Run Advice only on the outmost of a recursive series of calls around { print "Starting recursive child search\n"; $_->proceed; print "Finished recursive child search\n"; } call 'Person::find_child' & highest; # Run Advice only during the current lexical scope SCOPE: { my $hook = before { print "About to call create\n"; } call 'Person::create'; Person->create('Bob'); # Advice will run } Person->create('Tom'); # Advice won't run # Use a pre-packaged collection "Aspect" of Advice rules to change a class aspect Singleton => 'Foo::new'; # Define debugger breakpoints with high precision and conditionality aspect Breakpoint => call qr/^Foo::.+::Bar::when_/ & wantscalar & highest; DESCRIPTION What is Aspect-Oriented Programming? Aspect-Oriented Programming (AOP) is a programming paradigm which aims to increase modularity by allowing the separation of "cross-cutting "concerns. It includes programming methods and tools that support the modularization of concerns at the level of the source code, while "aspect-oriented software development" refers to a whole engineering discipline. Aspect-Oriented Programming (AOP) allows you to modularise code for issues that would otherwise be spread across many parts of a program and be problematic to both implement and maintain. Logging exemplifies a crosscutting concern because a logging strategy necessarily affects every logged part of the system. Logging thereby "crosscuts" all logged classes and methods. Typically, an aspect is scattered or tangled as code, making it harder to understand and maintain. It is scattered by virtue of the function (such as logging) being spread over a number of unrelated functions that might use its function, possibly in entirely unrelated systems That means to change logging can require modifying all affected modules. Aspects become tangled not only with the mainline function of the systems in which they are expressed but also with each other. That means changing one concern entails understanding all the tangled concerns or having some means by which the effect of changes can be inferred. Because Aspect-Oritented Programming moves this scattered code into a single module which is loaded as a single unit, another major benefit of this method is conditional compilation. Features implemented via Aspects can be compiled and added to you program only in certain situations, and because of this Aspects are useful when debugging or testing large or complex programs. Aspects can implement features necessary for correctness of programs such as reactivity or synchronisation, and can be used to add checking assertions to your or other people's modules. They can cause code to emit useful side effects not considered by the original author of a module, without changing the original function of the module. And, if necessary (although not recommended), they can do various types of "Monkey Patching", hijacking the functionality of some other module in an unexpected (by the original author) way so that the module acts differently when used in your program, when those changes might otherwise be dangerous or if encountered by other programs. Aspects can be used to implement space or time optimisations. One popular use case of AOP is to add caching to a module or function that does not natively implement caching itself. For more details on Aspect-Oriented Programming in general, and . About This Implementation The Perl Aspect module tries to closely follow the terminology of the basic Java AspectJ project wherever possible and reasonable (). However due to the dynamic nature of the Perl language, several "AspectJ" features are useless for us: exception softening, mixin support, out-of-class method declarations, annotations, and others. Currently the Perl Aspect module is focused exclusively on subroutine matching and wrapping. It allows you to select collections of subroutines and conditions using a flexible pointcut language, and modify their behavior in any way you want. In this regard it provides a similar set of functionality to the venerable Hook::LexWrap, but with much more precision and with much more control and maintainability as the complexity of the problems you are solving increases. In addition, where the Java implementation of Aspect-Oriented Programming is limited to concepts expressable at compile time, the more fluid nature of Perl means that the Aspect module can weave in aspect code at run-time. Pointcuts in Perl can also take advantage of run-time information and Perl-specific features like closures to implement more sophisticated pointcuts than are possible in Java. This allows the Perl implementation of Aspect-Oriented Programming to be stateful and adaptive in a way that Java cannot (although the added power can come with a significant speed cost if not used carefully). Terminology One of the more opaque aspects (no pun intended) of Aspect-Oriented programming is that it has an entire unique set of terms that can be confusing for people learning to use the Aspect module. In this section, we will attempt to define all the major terms in a way that will hopefully make sense to Perl programmers. What is an Aspect? An *Aspect* is a modular unit of cross-cutting implementation, consisting of "Advice" on "Pointcuts" (we'll define those two shortly, don't worry if they don't make sense for now). In Perl, this would typically mean a package or module containing declarations of where to inject code, the code to run at these points, and any variables or support functions needed by the injected functionality. The most critical point here is that the Aspect represents a collection of many different injection points which collectively implement a single function or feature and which should be enabled on an all or nothing basis. For example, you might implement the Aspect My::SecurityMonitor as a module which will inject hooks into a dozen different strategic places in your program to watch for valid-but-suspicious values and report these values to an external network server. Aspects can often written to be highly reusable, and be released via the CPAN. When these generic aspects are written in the special namespace Aspect::Library they can be called using the following special shorthand. use Aspect; # Load and enable the Aspect::Library::NYTProf aspect to constrain profiling # to only the object constructors for each class in your program. aspect NYTProf => call qr/^MyProgram\b.*::new$/; What is a Pointcut? A *Join Point* is a well-defined location at a point in the execution of a program at which Perl can inject functionality, in effect joining two different bits of code together. In the Perl Aspect implementation, this consists only of the execution of named subroutines on the symbol table such as "Foo::Bar::function_name". In other languages, additional join points can exist such as the instantiation or destruction of an object or the static initialisation of a class. A *Pointcut* is a well-defined set of join points, and any conditions that must be true when at these join points. Example include "All public methods in class "Foo::Bar"" or "Any non-recursive call to the function "Some::recursive_search"". We will discuss each of the available pointcut types later in this document. In addition to the default pointcut types it is possible to write your own specialised pointcut types, although this is challenging due to the complex API they follow to allow aggressive multi-pass optimisation. See Aspect::Pointcut for more information. What is Advice? *Advice* is code designed to run automatically at all of the join points in a particular pointcut. Advice comes in several types, instructing that the code be run "before", "after" or "around" (in place of) the different join points in the pointcut. Advice code is introduced lexically to the target join points. That is, the new functionality is injected in place to the existing program rather the class being extended into some new version. For example, function "Foo::expensive_calculation" may not support caching because it is unsafe to do so in the general case. But you know that in the case of your program, the reasons it is unsafe in the general case don't apply. So for your program you might use the Aspect::Library::Memoise aspect to "Weave" Advice code into the "Foo" class which adds caching to the function by integrating it with Memoise. Each of the different advice types needs to be used slightly differently, and are best employed for different types of jobs. We will discuss the use of each of the different advice types later in this document. But in general, the more specific advice type you use, the more optimisation can be applied to your advice declaration, and the less impact the advice will have on the speed of your program. In addition to the default pointcut types, it is (theoretically) possible to write your own specialised Advice types, although this would be extremely difficult and probably involve some form of XS programming. For the brave, see Aspect::Advice and the source for the different advice classes for more information. What is Weaving? *Weaving* is the installation of advice code to the subs that match a pointcut, or might potentially match depending on certain run-time conditions. In the Perl Aspect module, weaving happens on the declaration of each advice block. Unweaving happens when a lexically-created advice variable goes out of scope. Unfortunately, due to the nature of the mechanism Aspect uses to hook into function calls, unweaving can never be guarenteed to be round-trip clean. While the pointcut matching logic and advice code will never be run for unwoven advice, it may be necessary to leave the underlying hooking artifact in place on the join point indefinitely (imposing a small performance penalty and preventing clean up of the relevant advice closure from memory). Programs that repeatedly weave and unweave during execution will thus gradually slow down and leak memory, and so is discouraged despite being permitted. If advice needs to be repeatedly enabled and disabled you should instead consider using the "true" pointcut and a variable in the aspect package or a closure to introduce a remote "on/off" switch for the aspect. into the advice code. package My::Aspect; my $switch = 1; before { print "Calling Foo::bar\n"; } call 'Foo::bar' & true { $switch }; sub enable { $switch = 1; } sub disable { $switch = 0; } 1; Under the covers weaving is done using a mechanism that is very similar to the venerable Hook::LexWrap, although in some areas Aspect will try to make use of faster mechanisms if it knows these are safe. Feature Summary * Create permanent pointcuts, advice, and aspects at compile time or run-time. * Flexible pointcut language: select subs to match using string equality, regexp, or "CODE" ref. Match currently running sub, a sub in the call flow, calls in particular void, scalar, or array contexts, or only the highest call in a set of recursive calls. * Build pointcuts composed of a logical expression of other pointcuts, using conjunction, disjunction, and negation. * In advice code, you can modify parameter list for matched sub, modify return value, throw or supress exceptions, decide whether or not to proceed to matched sub, access a "CODE" ref for matched sub, and access the context of any call flow pointcuts that were matched, if they exist. * Add/remove advice and entire aspects lexically during run-time. The scope of advice and aspect objects, is the scope of their effect (This does, however, come with some caveats). * A basic library of reusable aspects. A base class makes it easy to create your own reusable aspects. The Aspect::Library::Memoize aspect is an example of how to interface with AOP-like modules from CPAN. Using Aspect.pm The Aspect package allows you to create pointcuts, advice, and aspects in a simple declarative fashion. This declarative form is a simple facade on top of the Perl AOP framework, which you can also use directly if you need the increased level of control or you feel the declarative form is not clear enough. For example, the following two examples are equivalent. use Aspect; # Declarative advice creation before { print "Calling " . $_->sub_name . "\n"; } call 'Function::one' | call 'Function::two'; # Longhand advice creation Aspect::Advice::Before->new( Aspect::Pointcut::Or->new( Aspect::Pointcut::Call->new('Function::one'), Aspect::Pointcut::Call->new('Function::two'), ), sub { print "Calling " . $_->sub_name . "\n"; }, ); You will be mostly working with this package (Aspect) and the Aspect::Point package, which provides the methods for getting information about the call to the join point within advice code. When you "use Aspect;" you will import a family of around fifteen functions. These are all factories that allow you to create pointcuts, advice, and aspects. Back Compatibility The various APIs in Aspect have changed a few times between older versions and the current implementation. By default, none of these changes are available in the current version of the Aspect module. They can, however, be accessed by providing one of two flags when loading Aspect. # Support for pre-1.00 Aspect usage use Aspect ':deprecated'; The ":deprecated" flag loads in all alternative and deprecated function and method names, and exports the deprecated "after_returning", "after_throwing" advice constructors, and the deprecated "if_true" alias for the "true" pointcut. # Support for pre-2010 Aspect usage (both usages are equivalent) use Aspect ':legacy'; use Aspect::Legacy; The ":legacy" flag loads in all alternative and deprecated functions as per the ":deprecated" flag. Instead of exporting all available functions and pointcut declarators it exports "only" the set of functions that were available in Aspect 0.12. Finally, it changes the behaviour of the exported version of "after" to add an implicit "& returning" to all pointcuts, as the original implementation did not trap exceptions. FUNCTIONS The following functions are exported by default (and are documented as such) but are also available directly in Aspect:: namespace as well if needed. They are documented in order from the simplest and and most common pointcut declarator to the highest level declarator for enabling complete aspect classes. call my $single = call 'Person::get_address'; my $multiple = call qr/^Person::get_/; my $complex = call sub { lc($_[0]) eq 'person::get_address' }; my $object = Aspect::Pointcut::Call->new('Person::get_address'); The most common pointcut is "call". All three of the examples will match the calling of "Person::get_address()" as defined in the symbol table at the time an advice is declared. The "call" declarator takes a single parameter which is the pointcut spec, and can be provided in three different forms. string Select only the specific full resolved subroutine whose name is equal to the specification string. For example "call 'Person::get'" will only match the plain "get" method and will not match the longer "get_address" method. regexp Select all subroutines whose name matches the regular expression. The following will match all the subs defined on the "Person" class, but not on the "Person::Address" or any other child classes. $p = call qr/^Person::\w+$/; CODE Select all subroutines where the supplied code returns true when passed a full resolved subroutine name as the only parameter. The following will match all calls to subroutines whose names are a key in the hash %subs_to_match: $p = call sub { exists $subs_to_match{$_[0]}; } For more information on the "call" pointcut see Aspect::Pointcut::Call. cflow before { print "Called My::foo somewhere within My::bar\n"; } call 'My::foo' & cflow 'My::bar'; The "cflow" declarator is used to specify that the join point must be somewhere within the control flow of the "My::bar" function. That is, at the time "My::foo" is being called somewhere up the call stack is "My::bar". The parameters to "cflow" are identical to the parameters to "call". Due to an idiosyncracy in the way "cflow" is implemented, they do not always parse properly well when joined with an operator. In general, you should use any "cflow" operator last in your pointcut specification, or use explicit braces for it. # This works fine my $x = call 'My::foo' & cflow 'My::bar'; # This will error my $y = cflow 'My::bar' & call 'My::foo'; # Use explicit braces if you can't have the flow last my $z = cflow('My::bar') & call 'My::foo'; For more information on the "cflow" pointcut, see Aspect::Pointcut::Cflow. wantlist my $pointcut = call 'Foo::bar' & wantlist; The "wantlist" pointcut traps a condition based on Perl "wantarray" context, when a function is called in list context. When used with "call", this pointcut can be used to trap list-context calls to one or more functions, while letting void or scalar context calls continue as normal. For more information on the "wantlist" pointcut see Aspect::Pointcut::Wantarray. wantscalar my $pointcut = call 'Foo::bar' & wantscalar; The "wantscalar" pointcut traps a condition based on Perl "wantarray" context, when a function is called in scalar context. When used with "call", this pointcut can be used to trap scalar-context calls to one or more functions, while letting void or list context calls continue as normal. For more information on the "wantscalar" pointcut see Aspect::Pointcut::Wantarray. wantvoid my $bug = call 'Foo::get_value' & wantvoid; The "wantvoid" pointcut traps a condition based on Perl "wantarray" context, when a function is called in void context. When used with "call", this pointcut can be used to trap void-context calls to one or more functions, while letting scalar or list context calls continue as normal. This is particularly useful for methods which make no sense to call in void context, such as getters or other methods calculating and returning a useful result. For more information on the "wantvoid" pointcut see Aspect::Pointcut::Wantarray. highest my $entry = call 'Foo::recurse' & highest; The "highest" pointcut is used to trap the first time a particular function is encountered, while ignoring any subsequent recursive calls into the same pointcut. It is unusual in that unlike all other types of pointcuts it is stateful, and so some detailed explaination is needed to understand how it will behave. Pointcut declarators follow normal Perl precedence and shortcutting in the same way that a typical set of "foo() and bar()" might do for regular code. When the "highest" is evaluated for the first time it returns true and a counter is to track the depth of the call stack. This counter is bound to the join point itself, and will decrement back again once we exit the advice code. If we encounter another function that is potentially contained in the same pointcut, then "highest" will always return false. In this manner, you can trigger functionality to run only at the outermost call into a recursive series of functions, or you can negate the pointcut with "! highest" and look for recursive calls into a function when there shouldn't be any recursion. In the current implementation, the semantics and behaviour of pointcuts containing multiple highest declarators is not defined (and the current implementation is also not amenable to supporting it). For these reasons, the usage of multiple highest declarators such as in the following example is not support, and so the following will throw an exception. before { print "This advice will not compile\n"; } wantscalar & ( (call 'My::foo' & highest) | (call 'My::bar' & highest) ); This limitation may change in future releases. Feedback welcome. For more information on the "highest" pointcut see Aspect::Pointcut::Highest. throwing my $string = throwing qr/does not exist/; my $object = throwing 'Exception::Class'; The "throwing" pointcut is used with the "after" to restrict the pointcut so advice code is only fired for a specific die message or a particular exception class (or subclass). The "throwing" declarator takes a single parameter which is the pointcut spec, and can be provided in two different forms. regexp If a regular expression is passed to "throwing" it will be matched against the exception if and only if the exception is a plain string. Thus, the regexp form can be used to trap unstructured errors emitted by "die" or "croak" while NOT trapping any formal exception objects of any kind. string If a string is passed to "throwing" it will be treated as a class name and will be matched against the exception via an "isa" method call if and only if the exception is an object. Thus, the string form can be used to trap and handle specific types of exceptions while allowing other types of exceptions or raw string errors to pass through. For more information on the "throwing" pointcut see Aspect::Pointcut::Throwing. returning after { print "No exception\n"; } call 'Foo::bar' & returning; The "returning" pointcut is used with "after" advice types to indicate the join point should only occur when a function is returning without throwing an exception. true # Intercept an adjustable random percentage of calls to a function our $RATE = 0.01; before { print "The few, the brave, the 1%\n"; } call 'My::foo' & true { rand() < $RATE }; Because of the lengths that Aspect goes to internally to optimise the selection and interception of calls, writing your own custom pointcuts can be very difficult. When a custom or unusual pattern of interception is needed, often all that is desired is to extend a relatively normal pointcut with an extra caveat. To allow for this scenario, Aspect provides the "true" pointcut. This pointcut allows you to specify any arbitrary code to match on. This code will be executed at run-time if the join point matches all previous conditions. The join point matches if the function or closure returns true, and does not match if the code returns false or nothing at all. before before { # Don't call the function, return instead $_->return_value(1); } call 'My::foo'; The before advice declaration is used to defined advice code that will be run instead of the code originally at the join points, but continuing on to the real function if no action is taken to say otherwise. When called in void context, as shown above, "before" will install the advice permanently into your program. When called in scalar context, as shown below, "before" will return a guard object and enable the advice for as long as that guard object continues to remain in scope or otherwise avoid being destroyed. SCOPE: { my $guard = before { print "Hello World!\n"; } call 'My::foo'; # This will print My::foo(); } # This will NOT print My::foo(); Because the end result of the code at the join points is irrelevant to this type of advice and the Aspect system does not need to hang around and maintain control during the join point, the underlying implementation is done in a way that is by far the fastest and with the least impact (essentially none) on the execution of your program. You are strongly encouraged to use "before" advice wherever possible for the current implementation, resorting to the other advice types when you truly need to be there are the end of the join point execution (or on both sides of it). For more information, see Aspect::Advice::Before. after # Confuse a program by bizarely swapping return values and exceptions after { if ( $_->exception ) { $_->return_value($_->exception); } else { $_->exception($_->return_value); } } call 'My::foo' & wantscalar; The "after" declarator is used to create advice in which the advice code will be run after the join point has run, regardless of whether the function return correctly or throws an exception. For more information, see Aspect::Advice::After. around # Trace execution time for a function around { my @start = Time::HiRes::gettimeofday(); $_->proceed; my @stop = Time::HiRes::gettimeofday(); my $elapsed = Time::HiRes::tv_interval( \@start, \@stop ); print "My::foo executed in $elapsed seconds\n"; } call 'My::foo'; The "around" declarator is used to create the most general form of advice, and can be used to implement the most high level functionality. It allows you to make changes to the calling parameters, to change the result of the function, to subvert or prevent the calling altogether, and to do so while storing extra lexical state of your own across the join point. For example, the code shown above tracks the time at which a single function is called and returned, and then uses the two pieces of information to track the execution time of the call. Similar functionality to the above is used to implement the CPAN modules Aspect::Library::Timer and the more complex Aspect::Library::ZoneTimer. Within the "around" advice code, the "$_->proceed" method is used to call the original function with whatever the current parameter context is, storing the result (whether return values or an exception) in the context as well. Alternatively, you can use the "original" method to get access to a reference to the original function and call it directly without using context parameters and without storing the function results. around { $_->original->('alternative param'); $_->return_value('fake result'); } call 'My::foo'; The above example calls the original function directly with an alternative parameter in void context (regardless of the original "wantarray" context) ignoring any return values. It then sets an entirely made up return value of it's own. Although it is the most powerful advice type, "around" is also the slowest advice type with the highest memory cost per join point. Where possible, you should try to use a more specific advice type. For more information, see Aspect::Advice::Around. aspect aspect Singleton => 'Foo::new'; The "aspect" declarator is used to enable complete reusable aspects. The first parameter to "aspect" identifies the aspect library class. If the parameter is a fully resolved class name (i.e. it contains double colons like Foo::Bar) the value it will be used directly. If it is a simple "Identifier" without colons then it will be interpreted as "Aspect::Library::Identifier". If the aspect class is not loaded, it will be loaded for you and validated as being a subclass of "Aspect::Library". And further parameters will be passed on to the constructor for that class. See the documentation for each class for more information on the appropriate parameters for that class. As with each individual advice type complete aspects can be defined globally by using "aspect" in void context, or lexically via a guard object by calling "aspect" in scalar context. # Break on the topmost call to function for a limited time SCOPE: { my $break = aspect Breakpoint => call 'My::foo' & highest; do_something(); } For more information on writing reusable aspects, see Aspect::Library. OPERATORS & Overloading of bitwise "&" for pointcut declarations allows a natural looking boolean "and" logic for pointcuts. When using the "&" operator the combined pointcut expression will match if all pointcut subexpressions match. In the original Java AspectJ framework, the subexpressions are considered to be a union without an inherent order at all. In Perl you may treat them as ordered since they are ordered internally, but since all subexpressions run anyway you should probably not do anything that relies on this order. The optimiser may do interesting things with order in future, or we may move to an unordered implementation. For more information, see Aspect::Pointcut::And. | Overloading of bitwise "|" for pointcut declarations allows a natural looking boolean "or" logic for pointcuts. When using the "|" operator the combined pointcut expression will match if either pointcut subexpressions match. The subexpressions are ostensibly considered without any inherent order, and you should treat them that way when you can. However, they are internally ordered and shortcutting will be applied as per normal Perl expressions. So for speed reasons, you may with to put cheap pointcut declarators before expensive ones where you can. The optimiser may do interesting things with order in future, or we may move to an unordered implementation. So as a general rule, avoid things that require order while using order to optimise where you can. For more information, see Aspect::Pointcut::Or. ! Overload of negation "!" for pointcut declarations allows a natural looking boolean "not" logic for pointcuts. When using the "!" operator the resulting pointcut expression will match if the single subexpression does not match. For more information, see Aspect::Pointcut::Not. METHODS A range of different methods are available within each type of advice code. The are summarised below, and described in more detail in Aspect::Point. type The "type" method is a convenience provided in the situation advice code is used in more than one type of advice, and wants to know the advice declarator is was made form. Returns "before", "after" or "around". pointcut my $pointcut = $_->pointcut; The "pointcut" method provides access to the original join point specification (as a tree of Aspect::Pointcut objects) that the current join point matched against. original $_->original->( 1, 2, 3 ); In a pointcut, the "original" method returns a "CODE" reference to the original function before it was hooked by the Aspect weaving process. # Prints "Full::Function::name" before { print $_->sub_name . "\n"; } call 'Full::Function::name'; The "sub_name" method returns a string with the full resolved function name at the join point the advice code is running at. package_name # Prints "Just::Package" before { print $_->package_name . "\n"; } call 'Just::Package::name'; The "package_name" parameter is a convenience wrapper around the "sub_name" method. Where "sub_name" will return the fully resolved function name, the "package_name" method will return just the namespace of the package of the join point. short_name # Prints "name" before { print $_->short_name . "\n"; } call 'Just::Package::name'; The "short_name" parameter is a convenience wrapper around the "sub_name" method. Where "sub_name" will return the fully resolved function name, the "short_name" method will return just the name of the function. args # Get the parameters as a list my @list = $_->args; # Set the parameters $_->args( 1, 2, 3 ); # Append a parameter $_->args( $_->args, 'more' ); The "args" method allows you to get or set the list of parameters to a function. It is the method equivalent of manipulating the @_ array. self after { $_->self->save; } My::Foo::set; The "self" method is a convenience provided for when you are writing advice that will be working with object-oriented Perl code. It returns the first parameter to the method (which should be object), which you can then call methods on. wantarray # Return differently depending on the calling context if ( $_->wantarray ) { $_->return_value(5); } else { $_->return_value(1, 2, 3, 4, 5); } The "wantarray" method returns the "wantarray" in perlfunc context of the call to the function for the current join point. As with the core Perl "wantarray" function, returns true if the function is being called in list context, false if the function is being called in scalar context, or "undef" if the function is being called in void context. exception unless ( $_->exception ) { $_->exception('Kaboom'); } The "exception" method is used to get the current die message or exception object, or to set the die message or exception object. return_value # Add an extra value to the returned list $_->return_value( $_->return_value, 'thing' ); # Return null (equivalent to "return;") $_->return_value; The "return_value" method is used to get or set the return value for the join point function, in a similar way to the normal Perl "return" keyword. proceed around { my $before = time; $_->proceed; my $elapsed = time - $before; print "Call to " . $_->sub_name . " took $elapsed seconds\n"; } call 'My::function'; Available only in "around" advice, the "proceed" method is used to run the join point function with the current join point context (parameters, scalar vs list call, etc) and store the result of the original call in the join point context (return values, exceptions etc). LIBRARY The main Aspect distribution ships with the following set of libraries. These are not necesarily recommended or the best on offer. The are shipped with Aspect for convenience, because they have no additional CPAN dependencies. Their purpose is summarised below, but see their own documentation for more information. Aspect::Library::Singleton Aspect::Library::Singleton can be used to convert an existing class to function as a singleton and return the same object for every constructor call. Aspect::Library::Breakpoint Aspect::Library::Breakpoint allows you to inject debugging breakpoints into a program using the full power and complexity of the "Aspect" pointcuts. Aspect::Library::Wormhole Aspect::Library::Wormhole is a tool for passing objects down a call flow, without adding extra arguments to the frames between the source and the target, letting a function implicit context. Aspect::Library::Listenable Aspect::Library::Listenable assysts in the implementation of the "Listenable" design pattern. It lets you define a function as emitting events that can be registed for by subscribers, and then add/remove subscribers for these events over time. When the functions that are listenable are called, registered subscribers will be notified. This lets you build a general event subscription system for your program. This could be as part of a plugin API or just for your own convenience. INTERNALS Due to the dynamic nature of Perl, there is no need for processing of source or byte code, as required in the Java and .NET worlds. The implementation is conceptually very simple: when you create advice, its pointcut is matched to find every sub defined in the symbol table that might match against the pointcut (potentially subject to further runtime conditions). Those that match, will get a special wrapper installed. The wrapper only executes if, during run-time, a compiled context test for the pointcut returns true. The wrapper code creates an advice context, and gives it to the advice code. Most of the complexity comes from the extensive optimisation that is used to reduce the impact of both weaving of the advice and the run-time costs of the wrappers added to your code. Some pointcuts like "call" are static and their full effect is known at weave time, so the compiled run-time function can be optimised away entirely. Some pointcuts like "cflow" are dynamic, so they are not used to select the functions to hook, but impose a run-time cost to determine whether or not they match. To make this process faster, when the advice is installed, the pointcut will not use itself directly for the compiled run-time function but will additionally generate a "curried" (optimised) version of itself. This curried version uses the fact that the run-time check will only be called if it matches the "call" pointcut pattern, and so no "call" pointcuts needed to be tested at run-time unless they are in deep and complex nested coolean logic. It also handles collapsing any boolean logic impacted by the safe removal of the "call" pointcuts. Further, where possible the pointcuts will be expressed as Perl source (including logic operators) and compiled into a single Perl expression. This not only massively reduces the number of functions to be called, but allows further optimisation of the pointcut by the opcode optimiser in perl itself. If you use only "call" pointcuts (alone or in boolean combinations) the currying results in a null test (the pointcut is optimised away entirely) and so the need to make a run-time point test will be removed altogether from the generated advice hooks, reducing call overheads significantly. If your pointcut does not have any static conditions (i.e. "call") then the wrapper code will need to be installed into every function on the symbol table. This is highly discouraged and liable to result in hooks on unusual functions and unwanted side effects, potentially breaking your program. LIMITATIONS Inheritance Support Support for inheritance is lacking. Consider the following two classes: package Automobile; sub compute_mileage { # ... } package Van; use base 'Automobile'; And the following two advice: before { print "Automobile!\n"; } call 'Automobile::compute_mileage'; before { print "Van!\n"; } call 'Van::compute_mileage'; Some join points one would expect to be matched by the call pointcuts above, do not: $automobile = Automobile->new; $van = Van->new; $automobile->compute_mileage; # Automobile! $van->compute_mileage; # Automobile!, should also print Van! "Van!" will never be printed. This happens because Aspect installs advice code on symbol table entries. "Van::compute_mileage" does not have one, so nothing happens. Until this is solved, you have to do the thinking about inheritance yourself. Performance You may find it very easy to shoot yourself in the foot with this module. Consider this advice: # Do not do this! before { print $_->sub_name; } cflow 'MyApp::Company::make_report'; The advice code will be installed on every sub loaded. The advice code will only run when in the specified call flow, which is the correct behavior, but it will be *installed* on every sub in the system. This can be extremely slow because the run-time cost of checking "cflow" will occur on every single function called in your program. It happens because the "cflow" pointcut matches *all* subs during weave-time. It matches the correct sub during run-time. The solution is to narrow the pointcut: # Much better before { print $_->sub_name; } call qr/^MyApp::/ & cflow 'MyApp::Company::make_report'; TO DO There are a many things that could be added, if people have an interest in contributing to the project. Documentation * cookbook * tutorial * example of refactoring a useful CPAN module using aspects Pointcuts * New pointcuts: execution, cflowbelow, within, advice, calledby. Sure you can implement them today with Perl treachery, but it is too much work. * We need a way to match subs with an attribute, attributes::get() will currently not work. * isa() support for method pointcuts as Gaal Yahas suggested: match methods on class hierarchies without callbacks * Perl join points: phasic- BEGIN/INIT/CHECK/END Weaving * The current optimation has gone as far as it can, next we need to look into XS acceleration and byte code manipulation with B:: modules. * A debug flag to print out subs that were matched during weaving * Warnings when over 1000 methods wrapped * Allow finer control of advice execution order * Centralised hooking in wrappers so that each successive advice won't need to wrap around the previous one. * Allow lexical aspects to be safely removed completely, rather than being left in place and disabled as in the current implementation. SUPPORT Please report any bugs or feature requests through the web interface at . INSTALLATION See perlmodinstall for information and options on installing Perl modules. AVAILABILITY The latest version of this module is available from the Comprehensive Perl Archive Network (CPAN). Visit to find a CPAN site near you. Or see . AUTHORS Adam Kennedy Marcel Grünauer Ran Eilam SEE ALSO You can find AOP examples in the "examples/" directory of the distribution. Aspect::Library::Memoize Aspect::Library::Profiler Aspect::Library::Trace COPYRIGHT Copyright 2001 by Marcel Grünauer Some parts copyright 2009 - 2013 Adam Kennedy. Parts of the initial introduction courtesy Wikipedia. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Aspect-1.04/benchmark/0000755000175100017510000000000012130724444013200 5ustar adamadamAspect-1.04/benchmark/advice.pl0000644000175100017510000000773112130724241014773 0ustar adamadam#!/usr/bin/perl # Benchmark a variety of different Aspect use cases. # # Set 1 shows the main Aspect uses with Sub::Uplevel 0.22 # # C:\cpan\trunk\Aspect>perl -Mblib benchmark\advice.pl # Benchmark: timing 500000 iterations of after, after_returning, after_throwing, around, before, control, deep1, deep10, deep5... # after: 14 wallclock secs (12.76 usr + 0.00 sys = 12.76 CPU) @ 39181.88/s (n=500000) # after_returning: 15 wallclock secs (13.56 usr + 0.02 sys = 13.57 CPU) @ 36840.55/s (n=500000) # after_throwing: 14 wallclock secs (13.31 usr + 0.00 sys = 13.31 CPU) @ 37574.21/s (n=500000) # around: 26 wallclock secs (23.53 usr + 0.00 sys = 23.53 CPU) @ 21253.99/s (n=500000) # before: 4 wallclock secs ( 3.82 usr + 0.00 sys = 3.82 CPU) @ 130821.56/s (n=500000) # control: 0 wallclock secs ( 0.09 usr + 0.00 sys = 0.09 CPU) @ 5319148.94/s (n=500000) # (warning: too few iterations for a reliable count) # deep1: 40 wallclock secs (37.99 usr + 0.00 sys = 37.99 CPU) @ 13162.40/s (n=500000) # deep10: 26 wallclock secs (23.24 usr + 0.02 sys = 23.26 CPU) @ 21496.13/s (n=500000) # deep5: 34 wallclock secs (31.79 usr + 0.00 sys = 31.79 CPU) @ 15726.73/s (n=500000) # # # # # Set 2 shows the main Aspect uses with the frame warning in Sub::Uplevel disabled # # C:\cpan\trunk\Aspect>perl -Mblib benchmark\advice.pl # Benchmark: timing 500000 iterations of after, after_returning, after_throwing, around, before, control, deep1, deep10, deep5... # after: 5 wallclock secs ( 6.12 usr + 0.00 sys = 6.12 CPU) @ 81766.15/s (n=500000) # after_returning: 7 wallclock secs ( 7.33 usr + 0.00 sys = 7.33 CPU) @ 68194.22/s (n=500000) # after_throwing: 7 wallclock secs ( 6.33 usr + 0.00 sys = 6.33 CPU) @ 78951.52/s (n=500000) # around: 9 wallclock secs ( 9.13 usr + 0.00 sys = 9.13 CPU) @ 54788.52/s (n=500000) # before: 4 wallclock secs ( 3.87 usr + 0.00 sys = 3.87 CPU) @ 129232.36/s (n=500000) # control: 1 wallclock secs ( 0.08 usr + 0.00 sys = 0.08 CPU) @ 6410256.41/s (n=500000) # (warning: too few iterations for a reliable count) # deep1: 11 wallclock secs (10.72 usr + 0.00 sys = 10.72 CPU) @ 46650.49/s (n=500000) # deep10: 9 wallclock secs ( 9.14 usr + 0.00 sys = 9.14 CPU) @ 54698.61/s (n=500000) # deep5: 10 wallclock secs (10.27 usr + 0.00 sys = 10.27 CPU) @ 48709.21/s (n=500000) use strict; use Sub::Uplevel; use Aspect; ###################################################################### # Test Class SCOPE: { package Foo; sub control { return 1; } sub before { return 1; } sub after { return 1; } sub after_returning { return 1; } sub after_throwing { return 1; } sub around { return 1; } sub deep1 { deep2(@_); } sub deep2 { deep3(@_); } sub deep3 { deep4(@_); } sub deep4 { deep5(@_); } sub deep5 { deep6(@_); } sub deep6 { deep7(@_); } sub deep7 { deep8(@_); } sub deep8 { deep9(@_); } sub deep9 { deep10(@_); } sub deep10 { return 1; } } ###################################################################### # Aspect Setup my $foo = 1; before { $foo++; } call 'Foo::before'; after { $foo++; } call 'Foo::after'; after { $foo++; } call 'Foo::after_returning' & returning; after { $foo++; } call 'Foo::after_throwing' & throwing; around { $foo++; $_->proceed } call 'Foo::around'; around { $foo++; $_->proceed; } call 'Foo::deep10'; ###################################################################### # Benchmark Execution use Benchmark qw{ :all :hireswallclock }; timethese( 100000, { control => 'Foo::control()', before => 'Foo::before()', after => 'Foo::after()', after_returning => 'Foo::after_returning()', after_throwing => 'Foo::after_throwing()', around => 'Foo::around()', deep1 => 'Foo::deep1()', deep5 => 'Foo::deep5()', deep10 => 'Foo::deep10()', uplevel => 'Sub::Uplevel::uplevel( 1, \&Foo::control )', } ); Aspect-1.04/xt/0000755000175100017510000000000012130724444011701 5ustar adamadamAspect-1.04/xt/meta.t0000644000175100017510000000107312130724241013010 0ustar adamadam#!/usr/bin/perl # Test that our META.yml file matches the current specification. use strict; BEGIN { $| = 1; $^W = 1; } my $MODULE = 'Test::CPAN::Meta 0.17'; # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing module eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } meta_yaml_ok(); Aspect-1.04/xt/pmv.t0000644000175100017510000000125212130724241012663 0ustar adamadam#!/usr/bin/perl # Test that our declared minimum Perl version matches our syntax use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Perl::MinimumVersion 1.27', 'Test::MinimumVersion 0.101080', ); # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } all_minimum_version_from_metayml_ok(); Aspect-1.04/xt/pod.t0000644000175100017510000000116712130724241012650 0ustar adamadam#!/usr/bin/perl # Test that the syntax of our POD documentation is valid use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Pod::Simple 3.14', 'Test::Pod 1.44', ); # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } all_pod_files_ok(); Aspect-1.04/inc/0000755000175100017510000000000012130724444012017 5ustar adamadamAspect-1.04/inc/Module/0000755000175100017510000000000012130724444013244 5ustar adamadamAspect-1.04/inc/Module/Install.pm0000644000175100017510000003013512130724400015202 0ustar adamadam#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Aspect-1.04/inc/Module/Install/0000755000175100017510000000000012130724444014652 5ustar adamadamAspect-1.04/inc/Module/Install/DSL.pm0000644000175100017510000000457012130724400015630 0ustar adamadam#line 1 package Module::Install::DSL; use strict; use vars qw{$VERSION $ISCORE}; BEGIN { $VERSION = '1.06'; $ISCORE = 1; *inc::Module::Install::DSL::VERSION = *VERSION; @inc::Module::Install::DSL::ISA = __PACKAGE__; } sub import { # Read in the rest of the Makefile.PL open 0 or die "Couldn't open $0: $!"; my $dsl; SCOPE: { local $/ = undef; $dsl = join "", <0>; } # Change inc::Module::Install::DSL to the regular one. # Remove anything before the use inc::... line. $dsl =~ s/.*?^\s*use\s+(?:inc::)?Module::Install::DSL(\b[^;]*);\s*\n//sm; # Load inc::Module::Install as we would in a regular Makefile.Pl SCOPE: { package main; require inc::Module::Install; inc::Module::Install->import; } # Add the ::DSL plugin to the list of packages in /inc my $admin = $Module::Install::MAIN->{admin}; if ( $admin ) { my $from = $INC{"$admin->{path}/DSL.pm"}; my $to = "$admin->{base}/$admin->{prefix}/$admin->{path}/DSL.pm"; $admin->copy( $from => $to ); } # Convert the basic syntax to code my $code = "INIT {\n" . "package main;\n\n" . dsl2code($dsl) . "\n\nWriteAll();\n" . "}\n"; # Execute the script eval $code; print STDERR "Failed to execute the generated code...\n$@" if $@; exit(0); } sub dsl2code { my $dsl = shift; # Split into lines and strip blanks my @lines = grep { /\S/ } split /[\012\015]+/, $dsl; # Each line represents one command my @code = (); my $static = 1; foreach my $line ( @lines ) { # Split the lines into tokens my @tokens = split /\s+/, $line; # The first word is the command my $command = shift @tokens; my @params = (); my @suffix = (); while ( @tokens ) { my $token = shift @tokens; if ( $token eq 'if' or $token eq 'unless' ) { # This is the beginning of a suffix push @suffix, $token; push @suffix, @tokens; # The conditional means this distribution # can no longer be considered fully static. $static = 0; last; } else { # Convert to a string $token =~ s/([\\\'])/\\$1/g; push @params, "'$token'"; } }; # Merge to create the final line of code @tokens = ( $command, @params ? join( ', ', @params ) : (), @suffix ); push @code, join( ' ', @tokens ) . ";\n"; } # Is our configuration static? push @code, "static_config;\n" if $static; # Join into the complete code block return join( '', @code ); } 1; Aspect-1.04/inc/Module/Install/Can.pm0000644000175100017510000000615712130724400015712 0ustar adamadam#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Aspect-1.04/inc/Module/Install/Fetch.pm0000644000175100017510000000462712130724400016242 0ustar adamadam#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Aspect-1.04/inc/Module/Install/Win32.pm0000644000175100017510000000340312130724400016102 0ustar adamadam#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Aspect-1.04/inc/Module/Install/WriteAll.pm0000644000175100017510000000237612130724400016733 0ustar adamadam#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Aspect-1.04/inc/Module/Install/Metadata.pm0000644000175100017510000004327712130724400016735 0ustar adamadam#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Aspect-1.04/inc/Module/Install/Base.pm0000644000175100017510000000214712130724400016056 0ustar adamadam#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Aspect-1.04/inc/Module/Install/Makefile.pm0000644000175100017510000002743712130724400016732 0ustar adamadam#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Aspect-1.04/MANIFEST0000644000175100017510000000364712130724401012402 0ustar adamadambenchmark/advice.pl Changes examples/Singleton/aop.pl examples/Singleton/oop.pl examples/Singleton/README examples/Wormhole/after_aop.pl examples/Wormhole/after_oop.pl examples/Wormhole/before.pl examples/Wormhole/README inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/DSL.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Aspect.pm lib/Aspect/Advice.pm lib/Aspect/Advice/After.pm lib/Aspect/Advice/Around.pm lib/Aspect/Advice/Before.pm lib/Aspect/Guard.pm lib/Aspect/Hook.pm lib/Aspect/Legacy.pm lib/Aspect/Library.pm lib/Aspect/Library/Breakpoint.pm lib/Aspect/Library/Listenable.pm lib/Aspect/Library/Listenable/Event.pm lib/Aspect/Library/Singleton.pm lib/Aspect/Library/Wormhole.pm lib/Aspect/Modular.pm lib/Aspect/Point.pm lib/Aspect/Point/Functions.pm lib/Aspect/Point/Static.pm lib/Aspect/Pointcut.pm lib/Aspect/Pointcut/And.pm lib/Aspect/Pointcut/Call.pm lib/Aspect/Pointcut/Cflow.pm lib/Aspect/Pointcut/Highest.pm lib/Aspect/Pointcut/Logic.pm lib/Aspect/Pointcut/Not.pm lib/Aspect/Pointcut/Or.pm lib/Aspect/Pointcut/Returning.pm lib/Aspect/Pointcut/Throwing.pm lib/Aspect/Pointcut/True.pm lib/Aspect/Pointcut/Wantarray.pm LICENSE Makefile.PL MANIFEST This list of files META.yml README t/00_closure.t t/00_context.t t/01_compile.t t/10_pointcut.t t/11_pointcut_call.t t/12_pointcut_cflow.t t/13_pointcut_true.t t/14_pointcut_highest.t t/15_pointcut_wantarray.t t/16_pointcut_throwing.t t/17_pointcut_returning.t t/21_advice_around.t t/22_advice_around.t t/23_advice_before.t t/24_advice_after.t t/30_return_value.t t/31_feature_caller.t t/32_feature_wantarray.t t/33_feature_topic.t t/34_point_functions.t t/50_legacy.t t/51_legacy_wantarray.t t/60_legacy_after_returning.t t/61_legacy_after_throwing.t t/70_listenable.t t/71_singleton.t t/72_wormhole.t t/rt_57417.t xt/meta.t xt/pmv.t xt/pod.t Aspect-1.04/examples/0000755000175100017510000000000012130724444013064 5ustar adamadamAspect-1.04/examples/Singleton/0000755000175100017510000000000012130724444015026 5ustar adamadamAspect-1.04/examples/Singleton/oop.pl0000644000175100017510000000077512130724241016164 0ustar adamadam#!/usr/bin/perl use strict; use warnings; my $printer1 = Printer->new; my $printer2 = Printer->new; print 'using new(): '. ($printer1 eq $printer2? '': 'not '). "equal\n"; my $printer3 = Printer->instance; my $printer4 = Printer->instance; print 'using instance(): '. ($printer3 eq $printer4? '': 'not '). "equal\n"; # ----------------------------------------------------------------------------- package Printer; my $Instance; sub instance { $Instance ||= Printer->new } sub new { bless {}, shift } Aspect-1.04/examples/Singleton/aop.pl0000644000175100017510000000054012130724241016134 0ustar adamadam#!/usr/bin/perl use strict; use warnings; use Aspect; aspect Singleton => 'Printer::new'; my $printer1 = Printer->new; my $printer2 = Printer->new; print 'using new(): '. ($printer1 eq $printer2? '': 'not '). "equal\n"; # ----------------------------------------------------------------------------- package Printer; sub new { bless {}, shift } Aspect-1.04/examples/Singleton/README0000644000175100017510000000146212130724241015704 0ustar adamadam Singleton Example ================= An example of using the singleton aspect. Shows how an AOP solution requires less code, and suffers from less EEK, compared with an OOP solution. oop.pl - we want to make sure users create only one printer, per Perl interperter. And we don't want to pass it around in argument lists all over the place. So we make it into a singleton. The OOP solution suffers from EEK: clients and the singleton itself, are both aware of the singleton requirement. aop.pl - the AOP solution is exactly like the solution before the singleton requirement was added, except for setting up the aspect. The only place in the system where the singleton requirement is specified is in the aspect. Aspect-1.04/examples/Wormhole/0000755000175100017510000000000012130724444014660 5ustar adamadamAspect-1.04/examples/Wormhole/before.pl0000644000175100017510000000132212130724241016450 0ustar adamadam#!/usr/bin/perl use strict; use warnings; my $printer = Printer->new; my $job = SpamPrintJob->new; $printer->print($job); # ----------------------------------------------------------------------------- package Printer; sub new { bless {}, shift } sub print { my ($self, $job) = @_; $job->spool; } # ----------------------------------------------------------------------------- package SpamPrintJob; sub new { bless {}, shift } sub spool { SpamDocument->new->spool } # ----------------------------------------------------------------------------- package SpamDocument; sub new { bless {}, shift } sub spool { # run system print command on spam postscript file print "SpamDocument has been spooled.\n"; } Aspect-1.04/examples/Wormhole/README0000644000175100017510000000355512130724241015543 0ustar adamadam Wormhole Example ================ An example of using the wormhole aspect. Shows how the design degrades when a feature is added, and how refactoring to aspects improves the design. before.pl - the initial design. Our company prints documents. We have the classes Printer, SpamPrintJob, and SpamDocument. To print a job you create it, create a Printer, and call $printer->print($job). The call flow will be (Class::method): Printer::print SpamPrintJob::spool SpamDocument::spool All is well: the design is nice and clean, and allows us to create a hierarchy of classes for different jobs and different documents. after_oop.pl - we are told the company has purchased several new printers. This means that SpamDocument::spool must get the name of the printer from somewhere. And it must be the name of the printer that is currently printing this document. So we append the Printer object to the argument list of each method in the call flow. SpamPrintJob now suffers from EEK. It knows about the fact that SpamDocument needs a Printer. after_aop.pl - to remove EEK we refactor to use the Wormhole aspect. SpamPrintJob now knows nothing of the fact that we have several printers. In fact, the code is exactly like before.pl, except for these changes: * added to Printer instance data for name support * added a wormhole aspect * appended a Printer argument to SpamDocument::spool The wormhole allows us to pass the Printer down a call flow, without modifying any objects along the way. Aspect-1.04/examples/Wormhole/after_oop.pl0000644000175100017510000000163612130724241017174 0ustar adamadam#!/usr/bin/perl use strict; use warnings; my $printer = Printer->new("TheBigOneOnTheSecondFloor"); my $job = SpamPrintJob->new; $printer->print($job); # ----------------------------------------------------------------------------- package Printer; sub new { bless {name => pop}, shift } sub print { my ($self, $job) = @_; $job->spool($self); } sub get_name { shift->{name} } # ----------------------------------------------------------------------------- package SpamPrintJob; sub new { bless {}, shift } sub spool { my ($self, $printer) = @_; SpamDocument->new->spool($printer); } # ----------------------------------------------------------------------------- package SpamDocument; sub new { bless {}, shift } sub spool { my ($self, $printer) = @_; my $printerName = $printer->get_name; # run system print command on spam postscript file print "SpamDocument has been spooled to: $printerName.\n"; } Aspect-1.04/examples/Wormhole/after_aop.pl0000644000175100017510000000167112130724241017155 0ustar adamadam#!/usr/bin/perl use strict; use warnings; use Aspect; aspect Wormhole => 'Printer::print', 'SpamDocument::spool'; my $printer = Printer->new("TheBigOneOnTheSecondFloor"); my $job = SpamPrintJob->new; $printer->print($job); # ----------------------------------------------------------------------------- package Printer; sub new { bless {name => pop}, shift } sub print { my ($self, $job) = @_; $job->spool; } sub get_name { shift->{name} } # ----------------------------------------------------------------------------- package SpamPrintJob; sub new { bless {}, shift } sub spool { SpamDocument->new->spool } # ----------------------------------------------------------------------------- package SpamDocument; sub new { bless {}, shift } sub spool { my ($self, $printer) = @_; my $printerName = $printer->get_name; # run system print command on spam postscript file print "SpamDocument has been spooled to: $printerName.\n"; } Aspect-1.04/Changes0000644000175100017510000006457712130724241012557 0ustar adamadamRevision history for Perl extension Aspect 1.04 Mon 8 Apr 2013 - fix failures on 5.17.6 (RT#81400) 1.03 Fri 19 Oct 2012 - Updating to Module::Install 1.06 - Removed warnings except in the test suite to prevent log spamming 1.02 Wed 1 Feb 2012 - Updating to Module::Install 1.04 - Adding B:: to the recursively excluded classes to avoid hooking 1.01 Thu 9 Jun 2011 - Added experimental function interface for the join point context. - Move the library tests into the numeric order 1.00 Thu 26 May 2011 - First production release of the second-generation Aspect.pm! - Support passing an explicit function list to import as per Exporter - Final POD spelling tweaks 0.983 Thu 26 May 2011 - Added a convenience wrapper over Sub::Install - Rewrote the initial introduction by drawing language from Wikipedia. - Moved all legacy code into a dedicated legacy module - Split out tests for deprecated features into their own test scripts 0.982 Wed 25 May 2011 - Refactored away the ->{proceed} flag on before join point objects. - Unified return_value across all advice types, and optimised further. - Completing the POD documentation for the Aspect::Point:: modules - Folded down Aspect::Point::Before/After/Around into a single class 0.981 Wed 25 May 2011 - Removed the proceed method from the begin advice, you now only signal to not continue with either exception or return_value. - Remove some leftover references to after_throwing and after_returning - Moved all advice code method documentation into Aspect::Point - Added a reduced volume copy of the Aspect::Point method documentation to the main Aspect documentation. - Ensure $_ is passed through intact during around advice using proceed - Aspect::Library::Single no longer incorrectly checks for exceptions, as the around advice doesn't catch them during proceed (that will be fixed some time after 1.00) - Expanded the testing of various edge cases - Localise $_ in a more contained manner so that don't copy/backup $_ for hooked around pointcuts that don't match the runtime part of the join point. Using a global for this instead of overloading $_ also makes pointcut marginally slightly faster. 0.98 Tue 24 May 2011 - Production release, no change from 0.97_06 - Major refactoring, documentation and and 1.00 preparation release - The API has now moved closed to the AspectJ API where sensible 0.97_06 Tue 24 May 2011 - Generalised and moved Aspec::Pointcut::Highest::Clean to Aspect::Guard - Removed dedicated Aspect::Advice::AfterReturning advice type - Removed dedicated Aspect::Advice::AfterThrowing advice type - Collapsing of nested and/or pointcuts is now done at constructor time - Expanded testing for corner case pointcut currying scenarios - Deprecated after_returning and after_throwing 0.97_05 Mon 23 May 2011 - Advice code is now always run consistently in void context, the ->wantarray method is now the only way to check the calling context of the active joint point. This is not only more consistent in having all context come from methods, is also prevents inconsistent behaviour when calling methods directly with $_->self->method and it allows context-senstive behaviour to be added to the advice methods. - Replaced params and params_ref with args, with a different behaviour based on the wantarray context it is called in. This is semantically much closer to the AspectJ version, and more importantly it has no "convenience" features which will prevent weird complexity later on. - Rewrote return_value to act on context in the same manner as args. This is theoretically not backwards compatible, but the entire test suite continued to pass after change, which shows that the only things backcompatible would be things using methods in a strange manner. - Added POD documentation for most of the methods in Aspect::Point. - Added basic POD skeletons for the different Aspect::Advice:: classes. - Minor optimisation in generated code to check for exceptions directly, rather than via the slower accessor method. - Clarified that only after and after_throwing support exception handling and throwing. - Aspect::Advice::AfterReturning now inherits from ::After - Aspect::Advice::AfterThrowing now inherits from ::After - Added the returning pointcut for use with after advice - Added a second curry method for use prior to weave-time compilation - Added support for naked throwing() without a specific exception value 0.97_04 Sat 21 May 2011 - Added more POD to the main page, this is closer to the final form 0.97_03 Fri 20 May 2011 - Simplified if_true to true and ::If to ::True - Expanded XS acceleration to more classes and methods - Completed reasonable thorough main documentation for Aspect.pm - Prohibit usage of the highest pointcut to one per advice declaration due to implementation complexity and unclear semantics. - Added Advice::Point::Static for the cflow point details in line with AspectJ's idea of "static parts" of join points. - Removed deprecated Aspect::AdviceContext now it is no longer needed by the cflow pointcut. - Pointcut logic operations & | ! now validate their children - The cflow declarator is now documented everywhere as single param, defaulting to an "enclosing" accessor, which is accelerated. - Added specific accelerated Aspect::Point::pointcut method - Move Aspect::Pointcut::Highest::Cleanup into its own module file 0.97_02 Wed 18 May 2011 - Removed the barely document, untested and rarely used append_param(s) - Added an improved SYNOPSIS and generally improving main POD - Added limited XS acceleration if Class::XSAccessor 1.08 installed. - Remove the use of test recursion in preparation for XS vs PP copying 0.97_01 Thu 24 Mar 2011 - Now all standard keys have their own methods, remove the weird automagic from the AUTOLOAD method. - Some more minor performance tweaks - Removed excessive exception method from begin advice - Moved proceed to the specific method it is used - Renamed run_original to proceed, keeping the original as an alias 0.96 Thu 24 Mar 2011 - Updating copyright year - Moved exception method away from a slow generic implementation - Moved original method away from slow generic implementation - Moved type method away from slow generic implementation - Rewrote return_value method into a much faster version - Removed get_value method, AUTOLOAD now reads the value directly 0.95 Mon 13 Dec 2010 - Fixed #57528 ([PATCH] Fix spelling error - Fixed #57417 Bad return value in list context 0.94 Fri 10 Dec 2010 - CPAN Testers is happy, moving to production release 0.93_02 Fri 10 Dec 2010 - Applied the fix from 0.93_01 to an additional place it was occuring in Aspect::Pointcut::Throwing. - Corrected the Aspect::Advice::Around documentation to refer to $_->run_original instead of $_->proceed until the proceed method actually works like that. 0.93_01 Thu 9 Dec 2010 - This contains a potential fix for the 5.13.6 breakage to be confirmed by CPAN Testers. 0.92 Wed 21 Jul 2010 - Correcting bad link to search.cpan 0.91 Tue 20 Jul 2010 - Updating to Module::Install::DSL 1.00 - The bundled libraries now use the new $_ mechanism to use the point context object. - Expanding the documentation and modernising it to match the API changes in the last few releases. 0.90 Thu 27 May 2010 - Updating to Module::Install::DSL 0.97 - Upgraded the old method-based match_run run-time context testing interface to a newer compiled_runtime context testing interface. The new interface cooks the run-time tests down to a single compiled perl condition where possible, and a set of nested function calls where strings cannot be used. The function calls alone are faster than methods, and the functions have no parameters, making them faster still. Tests that can be compiled all the way down to a string are even faster, because they avoid Perl's expensive function calls, and get even faster because Perl's opcode optimisations get a much better shot at improving the generated code. - Upgraded the weave-time mechanism to work using compiled code in the same fashion as the run-time code. This should make the weave costs (the time to scan the entire namespace) much lower as well. - Expanded out the POD documentation to cover the entire namespace tree. 0.45 Mon 10 May 2010 - Updating to Module::Install::DSL 0.96 - More performance tuning of the namespace scanner in match_all. - A wide range of cleanups, improvements and expansions to the previously existing documentation. This includes full documentation for the entire Aspect::Pointcut tree. - Renamed the new API for join point contexts from Aspect::Context to Aspect::Point. - Aspect libraries in namespaces other than Aspect::Library:: can now be used as long as the module inherits from the (empty) identifying base class Aspect::Library. All libraries that currently inherit from Aspect::Modular automatically inherit from the new Aspect::Library as well. - Started work on third-generation optimiser for Aspect::Pointcut. This functionality will be hidden until it is complete enough to use. 0.44 Mon 15 Feb 2010 - Adam Kennedy - Inlined and reimplemented a stripped down and faster replacement for the functionality provided by Devel::Symdump to make match_all significantly faster and remove potential issues with Devel::Symdump on Mac OS 5.10.0 0.43 Thu 28 Jan 2010 - Adam Kennedy - Fixed a pointcut optimisation problem where we were currying away call checking in complex nested pointcuts where runtime pointcuts needed to retain the call checking to limit the run-time checks to an appropriate subset of the total number of functions hooked. - More elements of what will ultimately become the pointcut context are passed through to the curried pointcut tests (in preparation for moving to a File::Find::Rule-like string-eval-compiled form of the pointcut. 0.42 Wed 20 Jan 2010 - Adam Kennedy - Began the implementation of the new Aspect::Context tree - Generated advice hook code now cheats for speed and blesses context objects directly into the advice-specific Aspect::Context class, which should be safe now the contexts have a dumb constructor. - Pointcut matching now correctly ignores exported Aspect functions. - Added in initial stub for Aspect::Library (the renaming of Aspect::Modular). - Moved Aspect::Advice::Hook to Aspect::Hook to provide Advice/Hook class symmetry, and make it no longer an Advice subclass. - Removed temporary debugging code in Aspect::Library::Breakpoint that slipped through into production 0.41 Wed 20 Jan 2010 - Adam Kennedy - So few pointcuts care about the sub name at run-time that it doesn't make sense to pass it as a separate parameter to match_run. Include it in the run-time HASH instead. - Normalise changes to return_value inside the advice code, rather than after it by using the ->{wantarray} context attribute to know when that normalisation is needed. This allows us to cheat in the hook code and use ->{return_value} directly, which is significantly faster than calling ->return_value. 0.40 Tue 19 Jan 2010 - Adam Kennedy - Added experimental Aspect::Library::Throwing pointcut - Only nested pointcuts containing only call() would curry away. Now nested mixed pointcuts curry out as well. - Nested And|Or pointcuts curry to faster flat 3+ element And|Or 0.39 Tue 19 Jan 2010 - Adam Kennedy - All hook code is now generated in a single namespace - Added the Aspect::Library::Wantarray pointcut 0.38 Tue 19 Jan 2010 - Adam Kennedy - Added experimental support for the "highest" pointcut. - Added experimental support for the Breakpoint reusable library. 0.37 Wed 13 Jan 2010 - Adam Kennedy - Added support for "Aspect ':legacy'", which will cause the Aspect module to export functions with their original behaviours. Only the original aspect/before/after/call/cflow functions are exported and after() advice applies the same behaviour as the equivalent new-API advice function after_returning(). - To prevent hassles with Exporter (and since we need Sub::Install anyway to implement :legacy) replace all uses of Exporter with a trivial hand-rolled equivalent using Sub::Install. - Added the Aspect::Pointcut::If pointcut to match Java's equivalent if PointCut primitive. Unfortunately, since it's going to be a bit to hard to actually use "if" in a function, we will use "if_true" instead. - Added Sub::Uplevel to the list of untouchables to prevent infinite circular loops. 0.36 Wed 13 Jan 2010 - Adam Kennedy - WARNING: THIS RELEASE CONTAINS API CHANGES. To retain compatibility with previous releases, you should change all of your after() calls to after_returning() calls. - The after () advice now traps BOTH orginary return values and exceptions, as per the AspectJ implementation. - To provide a more consistent naming of pointcuts (in preparation for adding more of them) renamed the logical pointcut classes to remove the "Op" part of the class name. - Bumped Test::Exception dependency to 0.29, since it has some Sub::Uplevel fixes, and we use that heavily. 0.35 Mon 11 Jan 2010 - Adam Kennedy - Adding initial support for exceptions, with after_throwing 0.34 Sun 10 Jan 2010 - Adam Kennedy - Adding Aspect::Advice::AfterReturning before we implement exception support in the main ::After advice. 0.33 Fri 8 Jan 2010 - Adam Kennedy - Added Test::NoWarnings to all of the tests - Refactoring advice testing into one test per advice type - Testing now covers more combinations of cases, including for around() - Fixed bug in return values for listwise before () calls - Calls to run_original for advice called in void context now correctly runs the underlying hooked method in void context as well. - When called in after() or around() advice, proceed will throw an exception. - Removed some of the author tests I don't care about as much. 0.32 Thu 7 Jan 2010 - Adam Kennedy - The actual term "forever" is meaningless. Reversed the flag to be used as "lexical" instead. 0.31 Thu 7 Jan 2010 - Adam Kennedy - Removed the loading of Aspect::Library::Memoize and Aspect::Library::TestClass in 01_compile.t which was causing installation failure. 0.30 Thu 7 Jan 2010 - Adam Kennedy - Extended the forever currying support to the overall Aspect itself, and upgraded the regular Library classes to implement it properly. - Renamed the term "forever" to a more simple "global" name. - Moved Aspect::Library::Memoize into a seperate distribution to remove the Memoize dependency, which isn't 100% reliable. 0.29 Wed 6 Jan 2010 - Adam Kennedy - Added "forever currying" support. If advice is created in void context we never add the $out_of_scope hook, and as a result we don't need to save the advice object at all (and just let it immediately destroy). As well as removing the need for a bunch of the nasty curried objects, we remove an unnecessary if () test for every single call (to non-lexical hooks). 0.28 Wed 6 Jan 2010 - Adam Kennedy - Implemented Pointcut currying. The pointcut objects will optimise themselves down to just the section that should run if we assume the function was hooked correctly. This not only makes the hooks much more efficient in working out if they need to fire, but it also fixes a major bug with negative call pointcuts always causing all functions to not fire. - Resolved RT #36527 - Minor doc bug s/Profiled/Profiler/ - Moved Aspect::Library::Listenable into it's own distribution - Migrated all the tests from Test::Class to normal Test::More - Various code clean up and simplification, with less exporting - Added missing Task::Weaken dependency - Fixed, hopefully, the "variables will not remain shared" but by moving from using pure named hook functions to assigning anonymous subroutines to the typeglob instead. - Pointcuts now boolify (quickly) to true, and don't stringify to a Data::Dumper debugging spew any more. - Implemted the internals needed to support AndOp and OrOp pointcuts with more than 2 elements, so that in future long chained collections of & or | pointcuts will collapse down into a single object, instead of building as giant nested trees of boolean pairs. 0.27 Sun 3 Jan 2010 - Adam Kennedy - Various micro-optimisation of Aspect::AdviceContext which would normally be somewhat pointless, but is useful in this case when an Aspect hook is applied to something which is in the hot loop for some program. - Added a test script to specifically hunt down the problems with variable sharing in string-eval'ed closures. 0.26 Thu 31 Dec 2009 - Adam Kennedy - With the primary internals refactoring completely, we now start a series of commits to remove excessive abstractions, and to alter others to more appropriate abstractions (still without changing any of the APIs) - Cleaning up and refactoring the Aspect/Advice constructor code in Aspect.pm - Removed the weird Aspect::Advice->new( type, code, pointcut ) for a more conventional ->new setup. - Attempt to load Sub::Uplevel earlier (before we load Exporter) so there is an increased likelyhood that we don't have to reload Exporter later. - Removed redundant references to Hook::LexWrap from the POD, and removed the "Convert to Sub::Uplevel" item from the TO DO list. - Rewrote the Pointcut family of classes to have a simpler structure which should be faster. Some now use blessed ARRAYs as a preparatory step for allowing the AndOp/OrOp pointcuts to have more than just two elements (and to allow enable certain optimisation strategies down the line). - Removed the faulty Aspect::Pointcut::BinOp abstraction entirely. It was causing boolean and/or operations to always run both sides, so unlike the overloaded expression they were created from, they would never shortcut. This is now resolved, and the an/or pointcut elements now shortcut properly. 0.25 Thu 31 Dec 2009 - Adam Kennedy - Debundled various out-of-date testing libraries, and reverted to more conventional build_requires dependencies now that our downstream packaging systems have the ability to consume them. - Since the code documents the Aspect::Advice->install method as private (and it is undocumented) rename to ->_install as a precursor to changing it's behaviour at an API level. - Now that the descope execution of the closure hook is able to be trusted, we no longer need the Aspect::Cleanup DESTROY-time self-execution magick. - Added the ->wantarray property to the AdviceContext object. This is provided as a convenience to the user (since the wantarray) function works properly inside the advice code. It's main use is for some AspectContext internals. - Added wantarray context test, which uncovered a bug where void-context calls were incorrectly running the advice in scalar context. 0.24 Wed 30 Dec 2009 - Adam Kennedy - Changes file now uses tabs (to make it less annoying for me) :) - Moved the inline Aspect::Hook::LexWrap::Cleanup class into it's own dedicated Aspect::Cleanup class. - Merged Advice-specific hooks from Aspect::Hook::Lexwrap into the advice classes. - Removed the now-redundant Aspect::Hook::Lexwrap entirely - Simplified the Aspect::AdviceContext constructor to make it faster - Logically merged the code-generated functionality from ->install and the Hook::LexWrap-inspired ->hook methods for each Advice class. This removes a lot of guess work and double handling from the main execution path, and should be significantly faster. - With the code merged, pushed the scope exit flag outside the symbol table iteration in the installer. Instead of a large array of separate exit-tracking objects, we can instead use one single shared lexical hook that works via mixed depth closure Magick. - Only call wantarray once per hook execution and share the result therafter as a variable. Saves two function calls per hook. 0.23 Thu 24 Dec 2009 - Adam Kennedy - Removed the concept of a standalone Aspect::Weaver class - Each Aspect::Advice:: subclass now does most of the setup for the weaving individually, with similar but slightly different implementations. This adds some duplication of code, but removes a lot of architectural complexity. It should make the creation of new types of Advice simpler. - Corrected the versions of the test libs (which went out of sync) - The Hook::LexWrap wrap function is now split into Advice-specific hooks before and after, duplicating some code but making each type simpler and faster. 0.22 Mon 21 Dec 2009 - Adam Kennedy - Part one of an upcoming series of major upgrades - Migrating to Sub::Uplevel to remove our custom CORE::GLOBAL::caller 0.21 Tue 21 Jul 2009 - Adam Kennedy - Bumped the version to 0.21 so the Hook::LexWrap module indexes 0.16 Tue 19 May 2009 - Adam Kennedy - Moved out Aspect::Library::Profiler into a standalone distribution 0.15 Thu Jul 24 23:02:11 CEST 2008 (Marcel Gruenauer ) - fixed version in all modules. *sigh* 0.14 Thu Jul 24 22:46:43 CEST 2008 (Marcel Gruenauer ) - fixed dist style 0.13 Thu Jul 24 18:22:15 CEST 2008 (Marcel Gruenauer ) - Made sure every module has a $VERSION - updated MANIFEST and MANIFEST.SKIP - removed META.yml as it is being generated by Module::Install - added requirements to Makefile.PL - converted Makefile.PL to use Module::Install - Aspect::Hook::LexWrap now uses warnings and strict; some changes were necessary for those to go through - fixed POD error in Aspect::Modular - added spaces where necessary to avoid having the template's start_tag in the code - renamed t/all_tests.t to t/01_all.t - added t/perlcriticrc - added .shipit - set version to 0.13 - updated MANIFEST - updated t/perlcriticrc 0.12 Sat, 24 Mar 2007 00:00:00 +0100 (Ran Eilam ) - You can now attach advice to subs in main:: package, see Advice tests - Made everything easier to install by including dependencies required for testing - Added __always_fire option to Listenable - Listenable: You can now let listeners receive any parameters, not just the event, see the test object_listener - Modified our hack on Hook::LexWrap so it does not ignore prototypes, see Advice tests - Removed old warning from Makefile.PL 0.11 Tue, 03 Aug 2004 00:00:00 +0100 (Ran Eilam ) - Fixed problem in upgrading from 0.08, CPAN.pm was getting confused on Advice and Modular, because they had no version numbers, and undef is smaller than 0.08. (merlyn) - Lowered dependency on Test::Class to 0.03 0.10 Fri, 30 Jul 2004 00:00:00 +0100 (Ran Eilam ) - No longer a developer release - Added Listenable reusable aspect - Added subject_params() support for TestClass library aspect 0.09_03 Tue, 06 Jul 2004 00:00:00 +0100 (Ran Eilam ) - Added Carp::Heavy to list of untouchables in Weaver.pm, to avoid Carp dumping core - Test::Class aspect allows for customizing IUT through init_subject_state 0.09_02 Sat, 06 Mar 2004 00:00:00 +0100 (Ran Eilam ) - AdviceContext now has the original code, so you can do AspectJ-style around advice. You can call the original code from before or after advice. Added AdviceContext::run_original. - Memoize can memoize in any context, not just scalar, again - Added Test::Class helper aspect - Started using Devel::Symdump 0.09_01 Sat, 06 Mar 2004 00:00:00 +0100 (Ran Eilam ) - Released for review by participants in YAPC::Israel 2004 - New syntax is incompatible with old - New maintainer, Ran Eilam - Control flow pointcut: cflow(), done according to Marcel's design - Advice context trapping for control flow pointcuts - Use Test::Class for unit tests - Wormhole reusable aspect - Added prototypes so you can dispense with parentheses - Removed return/around pointcuts, added after advice - Removed attribute interface - Added a mutated version of Hook::LexWrap with support for appending/removing arguments - Moved reusable aspects to Aspect::Library - regression: Aspect exported subs generate join points again 0.07 Wed, 31 Jul 2002 22:42:27 +0200 (Marcel Gruenauer ) - The distribution has been adapted for use with perl5.8.0. C is now a core module, but there was a problem with context (wantarray) handling with Aspect::Memoize. Sorry about the perl 5.6.x users, but this is bleeding-edge stuff, so you're expected to use the very latest gear. Anyway, you can still get an earlier version (up to 0.07) from CPAN, which will work with perl 5.6.x. - Aspect::Memoize is now intended for subroutines returning scalars only. That is, if the sub is called in list context, it will still only memoize, and return, a memoized scalar. Void context obviously doesn't matter when it comes to memoization; subroutines returning lists are something I have to think about. - Tests now use Test::More 0.07 Fri, 15 Mar 2002 09:04:51 +0100 (Marcel Gruenauer ) - symbols exported from Aspect.pm now don't generate join points. So I added Aspect::import() and modified Aspect::JoinPoint::enum() to check for %Aspect::exp_syms. 0.06 Fri, 26 Oct 2001 16:42:51 +0200 (Marcel Gruenauer ) - added around() function to Aspect.pm - added Aspect::Profiled - added Aspect::Attribute interface to creating advice - made Aspect::Advice's enable() and disable() return $self - added cookbook example program callflow_attr.pl - added cookbook recipes for bounds checking and change tracking, plus sample programs 0.05 Thu, 11 Oct 2001 09:44:50 +0200 (Marcel Gruenauer ) - removed dependency on Data::Denter 0.04 Mon, 01 Oct 2001 18:33:00 +0200 (Marcel Gruenauer ) - removed the patched Hook::LexWrap now that 0.20 is out which fixes all the problems of 0.10 - added documentation (a recurring theme, never finishes) 0.03 Sun, 30 Sep 2001 19:43:56 +0200 (Marcel Gruenauer ) - added documentation - Included a patched Hook::LexWrap that fixes a bug with wantarray preservation in subroutine wrappers. Will be removed if and when Damian approves of the patch or otherwise fixes the bug. 0.02 Fri, 28 Sep 2001 12:59:06 +0200 (Marcel Gruenauer ) - added documentation - added '$::thisjp' global variable - added modular memoization aspect: Aspect::Memoize - added modular tracing aspect: Aspect::Trace 0.01 Fri, 28 Sep 2001 10:36:08 +0200 (Marcel Gruenauer ) - original version Aspect-1.04/lib/0000755000175100017510000000000012130724444012014 5ustar adamadamAspect-1.04/lib/Aspect.pm0000644000175100017510000013443012130724241013571 0ustar adamadampackage Aspect; =pod =head1 NAME Aspect - Aspect-Oriented Programming (AOP) for Perl =head1 SYNOPSIS use Aspect; # Run some code "Advice" before a particular function before { print "About to call create\n"; } call 'Person::create'; # Run Advice after several methods and hijack their return values after { print "Called getter/setter " . $_->sub_name . "\n"; $_->return_value(undef); } call qr/^Person::[gs]et_/; # Run Advice conditionally based on multiple factors before { print "Calling a get method in void context within Tester::run_tests"; } wantvoid & ( call qr/^Person::get_/ & ! call 'Person::get_not_trapped' ) & cflow 'Tester::run_tests'; # Context-aware runtime hijacking of a method if certain condition is true around { if ( $_->self->customer_name eq 'Adam Kennedy' ) { # Ensure I always have cash $_->return_value('One meeeelion dollars'); } else { # Take a dollar off everyone else $_->proceed; $_->return_value( $_->return_value - 1 ); } } call 'Bank::Account::balance'; # Catch and handle unexpected exceptions in a function into a formal object after { $_->exception( Exception::Unexpected->new($_->exception) ); } throwing() & ! throwing('Exception::Expected') & ! throwing('Exception::Unexpected'); # Run Advice only on the outmost of a recursive series of calls around { print "Starting recursive child search\n"; $_->proceed; print "Finished recursive child search\n"; } call 'Person::find_child' & highest; # Run Advice only during the current lexical scope SCOPE: { my $hook = before { print "About to call create\n"; } call 'Person::create'; Person->create('Bob'); # Advice will run } Person->create('Tom'); # Advice won't run # Use a pre-packaged collection "Aspect" of Advice rules to change a class aspect Singleton => 'Foo::new'; # Define debugger breakpoints with high precision and conditionality aspect Breakpoint => call qr/^Foo::.+::Bar::when_/ & wantscalar & highest; =head1 DESCRIPTION =head2 What is Aspect-Oriented Programming? Aspect-Oriented Programming (AOP) is a programming paradigm which aims to increase modularity by allowing the separation of "cross-cutting "concerns. It includes programming methods and tools that support the modularization of concerns at the level of the source code, while "aspect-oriented software development" refers to a whole engineering discipline. Aspect-Oriented Programming (AOP) allows you to modularise code for issues that would otherwise be spread across many parts of a program and be problematic to both implement and maintain. Logging exemplifies a crosscutting concern because a logging strategy necessarily affects every logged part of the system. Logging thereby "crosscuts" all logged classes and methods. Typically, an aspect is scattered or tangled as code, making it harder to understand and maintain. It is scattered by virtue of the function (such as logging) being spread over a number of unrelated functions that might use its function, possibly in entirely unrelated systems That means to change logging can require modifying all affected modules. Aspects become tangled not only with the mainline function of the systems in which they are expressed but also with each other. That means changing one concern entails understanding all the tangled concerns or having some means by which the effect of changes can be inferred. Because Aspect-Oritented Programming moves this scattered code into a single module which is loaded as a single unit, another major benefit of this method is conditional compilation. Features implemented via Aspects can be compiled and added to you program only in certain situations, and because of this Aspects are useful when debugging or testing large or complex programs. Aspects can implement features necessary for correctness of programs such as reactivity or synchronisation, and can be used to add checking assertions to your or other people's modules. They can cause code to emit useful side effects not considered by the original author of a module, without changing the original function of the module. And, if necessary (although not recommended), they can do various types of "Monkey Patching", hijacking the functionality of some other module in an unexpected (by the original author) way so that the module acts differently when used in your program, when those changes might otherwise be dangerous or if encountered by other programs. Aspects can be used to implement space or time optimisations. One popular use case of AOP is to add caching to a module or function that does not natively implement caching itself. For more details on Aspect-Oriented Programming in general, L and L. =head2 About This Implementation The Perl B module tries to closely follow the terminology of the basic Java AspectJ project wherever possible and reasonable (L). However due to the dynamic nature of the Perl language, several C features are useless for us: exception softening, mixin support, out-of-class method declarations, annotations, and others. Currently the Perl B module is focused exclusively on subroutine matching and wrapping. It allows you to select collections of subroutines and conditions using a flexible pointcut language, and modify their behavior in any way you want. In this regard it provides a similar set of functionality to the venerable L, but with much more precision and with much more control and maintainability as the complexity of the problems you are solving increases. In addition, where the Java implementation of Aspect-Oriented Programming is limited to concepts expressable at compile time, the more fluid nature of Perl means that the B module can weave in aspect code at run-time. Pointcuts in Perl can also take advantage of run-time information and Perl-specific features like closures to implement more sophisticated pointcuts than are possible in Java. This allows the Perl implementation of Aspect-Oriented Programming to be stateful and adaptive in a way that Java cannot (although the added power can come with a significant speed cost if not used carefully). =head2 Terminology One of the more opaque aspects (no pun intended) of Aspect-Oriented programming is that it has an entire unique set of terms that can be confusing for people learning to use the B module. In this section, we will attempt to define all the major terms in a way that will hopefully make sense to Perl programmers. =head3 What is an Aspect? An I is a modular unit of cross-cutting implementation, consisting of "Advice" on "Pointcuts" (we'll define those two shortly, don't worry if they don't make sense for now). In Perl, this would typically mean a package or module containing declarations of where to inject code, the code to run at these points, and any variables or support functions needed by the injected functionality. The most critical point here is that the Aspect represents a collection of many different injection points which collectively implement a single function or feature and which should be enabled on an all or nothing basis. For example, you might implement the Aspect B as a module which will inject hooks into a dozen different strategic places in your program to watch for valid-but-suspicious values and report these values to an external network server. Aspects can often written to be highly reusable, and be released via the CPAN. When these generic aspects are written in the special namespace L they can be called using the following special shorthand. use Aspect; # Load and enable the Aspect::Library::NYTProf aspect to constrain profiling # to only the object constructors for each class in your program. aspect NYTProf => call qr/^MyProgram\b.*::new$/; =head3 What is a Pointcut? A I is a well-defined location at a point in the execution of a program at which Perl can inject functionality, in effect joining two different bits of code together. In the Perl B implementation, this consists only of the execution of named subroutines on the symbol table such as C. In other languages, additional join points can exist such as the instantiation or destruction of an object or the static initialisation of a class. A I is a well-defined set of join points, and any conditions that must be true when at these join points. Example include "All public methods in class C" or "Any non-recursive call to the function C". We will discuss each of the available pointcut types later in this document. In addition to the default pointcut types it is possible to write your own specialised pointcut types, although this is challenging due to the complex API they follow to allow aggressive multi-pass optimisation. See L for more information. =head3 What is Advice? I is code designed to run automatically at all of the join points in a particular pointcut. Advice comes in several types, instructing that the code be run C, C or C (in place of) the different join points in the pointcut. Advice code is introduced lexically to the target join points. That is, the new functionality is injected in place to the existing program rather the class being extended into some new version. For example, function C may not support caching because it is unsafe to do so in the general case. But you know that in the case of your program, the reasons it is unsafe in the general case don't apply. So for your program you might use the L aspect to "Weave" Advice code into the C class which adds caching to the function by integrating it with L. Each of the different advice types needs to be used slightly differently, and are best employed for different types of jobs. We will discuss the use of each of the different advice types later in this document. But in general, the more specific advice type you use, the more optimisation can be applied to your advice declaration, and the less impact the advice will have on the speed of your program. In addition to the default pointcut types, it is (theoretically) possible to write your own specialised Advice types, although this would be extremely difficult and probably involve some form of XS programming. For the brave, see L and the source for the different advice classes for more information. =head3 What is Weaving? I is the installation of advice code to the subs that match a pointcut, or might potentially match depending on certain run-time conditions. In the Perl B module, weaving happens on the declaration of each advice block. Unweaving happens when a lexically-created advice variable goes out of scope. Unfortunately, due to the nature of the mechanism B uses to hook into function calls, unweaving can never be guarenteed to be round-trip clean. While the pointcut matching logic and advice code will never be run for unwoven advice, it may be necessary to leave the underlying hooking artifact in place on the join point indefinitely (imposing a small performance penalty and preventing clean up of the relevant advice closure from memory). Programs that repeatedly weave and unweave during execution will thus gradually slow down and leak memory, and so is discouraged despite being permitted. If advice needs to be repeatedly enabled and disabled you should instead consider using the C pointcut and a variable in the aspect package or a closure to introduce a remote "on/off" switch for the aspect. into the advice code. package My::Aspect; my $switch = 1; before { print "Calling Foo::bar\n"; } call 'Foo::bar' & true { $switch }; sub enable { $switch = 1; } sub disable { $switch = 0; } 1; Under the covers weaving is done using a mechanism that is very similar to the venerable L, although in some areas B will try to make use of faster mechanisms if it knows these are safe. =head2 Feature Summary =over =item * Create permanent pointcuts, advice, and aspects at compile time or run-time. =item * Flexible pointcut language: select subs to match using string equality, regexp, or C ref. Match currently running sub, a sub in the call flow, calls in particular void, scalar, or array contexts, or only the highest call in a set of recursive calls. =item * Build pointcuts composed of a logical expression of other pointcuts, using conjunction, disjunction, and negation. =item * In advice code, you can modify parameter list for matched sub, modify return value, throw or supress exceptions, decide whether or not to proceed to matched sub, access a C ref for matched sub, and access the context of any call flow pointcuts that were matched, if they exist. =item * Add/remove advice and entire aspects lexically during run-time. The scope of advice and aspect objects, is the scope of their effect (This does, however, come with some caveats). =item * A basic library of reusable aspects. A base class makes it easy to create your own reusable aspects. The L aspect is an example of how to interface with AOP-like modules from CPAN. =back =head2 Using Aspect.pm The B package allows you to create pointcuts, advice, and aspects in a simple declarative fashion. This declarative form is a simple facade on top of the Perl AOP framework, which you can also use directly if you need the increased level of control or you feel the declarative form is not clear enough. For example, the following two examples are equivalent. use Aspect; # Declarative advice creation before { print "Calling " . $_->sub_name . "\n"; } call 'Function::one' | call 'Function::two'; # Longhand advice creation Aspect::Advice::Before->new( Aspect::Pointcut::Or->new( Aspect::Pointcut::Call->new('Function::one'), Aspect::Pointcut::Call->new('Function::two'), ), sub { print "Calling " . $_->sub_name . "\n"; }, ); You will be mostly working with this package (B) and the L package, which provides the methods for getting information about the call to the join point within advice code. When you C you will import a family of around fifteen functions. These are all factories that allow you to create pointcuts, advice, and aspects. =head2 Back Compatibility The various APIs in B have changed a few times between older versions and the current implementation. By default, none of these changes are available in the current version of the B module. They can, however, be accessed by providing one of two flags when loading B. # Support for pre-1.00 Aspect usage use Aspect ':deprecated'; The C<:deprecated> flag loads in all alternative and deprecated function and method names, and exports the deprecated C, C advice constructors, and the deprecated C alias for the C pointcut. # Support for pre-2010 Aspect usage (both usages are equivalent) use Aspect ':legacy'; use Aspect::Legacy; The C<:legacy> flag loads in all alternative and deprecated functions as per the C<:deprecated> flag. Instead of exporting all available functions and pointcut declarators it exports C the set of functions that were available in B 0.12. Finally, it changes the behaviour of the exported version of C to add an implicit C<& returning> to all pointcuts, as the original implementation did not trap exceptions. =head1 FUNCTIONS The following functions are exported by default (and are documented as such) but are also available directly in Aspect:: namespace as well if needed. They are documented in order from the simplest and and most common pointcut declarator to the highest level declarator for enabling complete aspect classes. =cut use 5.008002; use strict; # Added by eilara as hack around caller() core dump # NOTE: Now we've switched to Sub::Uplevel can this be removed? # -- ADAMK use Carp::Heavy (); use Carp (); use Params::Util 1.00 (); use Sub::Install 0.92 (); use Sub::Uplevel 0.2002 (); use Aspect::Pointcut (); use Aspect::Pointcut::Or (); use Aspect::Pointcut::And (); use Aspect::Pointcut::Not (); use Aspect::Pointcut::True (); use Aspect::Pointcut::Call (); use Aspect::Pointcut::Cflow (); use Aspect::Pointcut::Highest (); use Aspect::Pointcut::Throwing (); use Aspect::Pointcut::Returning (); use Aspect::Pointcut::Wantarray (); use Aspect::Advice (); use Aspect::Advice::After (); use Aspect::Advice::Around (); use Aspect::Advice::Before (); use Aspect::Point (); use Aspect::Point::Static (); our $VERSION = '1.04'; our %FLAGS = (); # Track the location of exported functions so that pointcuts # can avoid accidentally binding them. our %EXPORTED = (); sub install { Sub::Install::install_sub( { into => $_[1], code => $_[2], as => $_[3] || $_[2], } ); $EXPORTED{"$_[1]::$_[2]"} = 1; } sub import { my $class = shift; my $into = caller(); my %flag = (); my @export = (); # Handle import params while ( @_ ) { my $value = shift; if ( $value =~ /^:(\w+)$/ ) { $flag{$1} = 1; } else { push @export, $_; } } # Legacy API and deprecation support if ( $flag{legacy} or $flag{deprecated} ) { require Aspect::Legacy; if ( $flag{legacy} ) { return Aspect::Legacy->import; } } # Custom method export list if ( @export ) { $class->install( $into => $_ ) foreach @export; return 1; } # Install the modern API $class->install( $into => $_ ) foreach qw{ aspect before after around call cflow throwing returning wantlist wantscalar wantvoid highest true }; # Install deprecated API elements if ( $flag{deprecated} ) { $class->install( $into => $_ ) foreach qw{ after_returning after_throwing if_true }; } return 1; } ###################################################################### # Public (Exported) Functions =pod =head2 call my $single = call 'Person::get_address'; my $multiple = call qr/^Person::get_/; my $complex = call sub { lc($_[0]) eq 'person::get_address' }; my $object = Aspect::Pointcut::Call->new('Person::get_address'); The most common pointcut is C. All three of the examples will match the calling of C as defined in the symbol table at the time an advice is declared. The C declarator takes a single parameter which is the pointcut spec, and can be provided in three different forms. B Select only the specific full resolved subroutine whose name is equal to the specification string. For example C will only match the plain C method and will not match the longer C method. B Select all subroutines whose name matches the regular expression. The following will match all the subs defined on the C class, but not on the C or any other child classes. $p = call qr/^Person::\w+$/; B Select all subroutines where the supplied code returns true when passed a full resolved subroutine name as the only parameter. The following will match all calls to subroutines whose names are a key in the hash C<%subs_to_match>: $p = call sub { exists $subs_to_match{$_[0]}; } For more information on the C pointcut see L. =cut sub call ($) { Aspect::Pointcut::Call->new(@_); } =pod =head2 cflow before { print "Called My::foo somewhere within My::bar\n"; } call 'My::foo' & cflow 'My::bar'; The C declarator is used to specify that the join point must be somewhere within the control flow of the C function. That is, at the time C is being called somewhere up the call stack is C. The parameters to C are identical to the parameters to C. Due to an idiosyncracy in the way C is implemented, they do not always parse properly well when joined with an operator. In general, you should use any C operator last in your pointcut specification, or use explicit braces for it. # This works fine my $x = call 'My::foo' & cflow 'My::bar'; # This will error my $y = cflow 'My::bar' & call 'My::foo'; # Use explicit braces if you can't have the flow last my $z = cflow('My::bar') & call 'My::foo'; For more information on the C pointcut, see L. =cut sub cflow ($;$) { Aspect::Pointcut::Cflow->new(@_); } =pod =head2 wantlist my $pointcut = call 'Foo::bar' & wantlist; The C pointcut traps a condition based on Perl C context, when a function is called in list context. When used with C, this pointcut can be used to trap list-context calls to one or more functions, while letting void or scalar context calls continue as normal. For more information on the C pointcut see L. =cut sub wantlist () { Aspect::Pointcut::Wantarray->new(1); } =pod =head2 wantscalar my $pointcut = call 'Foo::bar' & wantscalar; The C pointcut traps a condition based on Perl C context, when a function is called in scalar context. When used with C, this pointcut can be used to trap scalar-context calls to one or more functions, while letting void or list context calls continue as normal. For more information on the C pointcut see L. =cut sub wantscalar () { Aspect::Pointcut::Wantarray->new(''); } =pod =head2 wantvoid my $bug = call 'Foo::get_value' & wantvoid; The C pointcut traps a condition based on Perl C context, when a function is called in void context. When used with C, this pointcut can be used to trap void-context calls to one or more functions, while letting scalar or list context calls continue as normal. This is particularly useful for methods which make no sense to call in void context, such as getters or other methods calculating and returning a useful result. For more information on the C pointcut see L. =cut sub wantvoid () { Aspect::Pointcut::Wantarray->new(undef); } =pod =head2 highest my $entry = call 'Foo::recurse' & highest; The C pointcut is used to trap the first time a particular function is encountered, while ignoring any subsequent recursive calls into the same pointcut. It is unusual in that unlike all other types of pointcuts it is stateful, and so some detailed explaination is needed to understand how it will behave. Pointcut declarators follow normal Perl precedence and shortcutting in the same way that a typical set of C might do for regular code. When the C is evaluated for the first time it returns true and a counter is to track the depth of the call stack. This counter is bound to the join point itself, and will decrement back again once we exit the advice code. If we encounter another function that is potentially contained in the same pointcut, then C will always return false. In this manner, you can trigger functionality to run only at the outermost call into a recursive series of functions, or you can negate the pointcut with C and look for recursive calls into a function when there shouldn't be any recursion. In the current implementation, the semantics and behaviour of pointcuts containing multiple highest declarators is not defined (and the current implementation is also not amenable to supporting it). For these reasons, the usage of multiple highest declarators such as in the following example is not support, and so the following will throw an exception. before { print "This advice will not compile\n"; } wantscalar & ( (call 'My::foo' & highest) | (call 'My::bar' & highest) ); This limitation may change in future releases. Feedback welcome. For more information on the C pointcut see L. =cut sub highest () { Aspect::Pointcut::Highest->new; } =pod =head2 throwing my $string = throwing qr/does not exist/; my $object = throwing 'Exception::Class'; The C pointcut is used with the C to restrict the pointcut so advice code is only fired for a specific die message or a particular exception class (or subclass). The C declarator takes a single parameter which is the pointcut spec, and can be provided in two different forms. B If a regular expression is passed to C it will be matched against the exception if and only if the exception is a plain string. Thus, the regexp form can be used to trap unstructured errors emitted by C or C while B trapping any formal exception objects of any kind. B If a string is passed to C it will be treated as a class name and will be matched against the exception via an C method call if and only if the exception is an object. Thus, the string form can be used to trap and handle specific types of exceptions while allowing other types of exceptions or raw string errors to pass through. For more information on the C pointcut see L. =cut sub throwing (;$) { Aspect::Pointcut::Throwing->new(@_); } =pod =head2 returning after { print "No exception\n"; } call 'Foo::bar' & returning; The C pointcut is used with C advice types to indicate the join point should only occur when a function is returning B throwing an exception. =cut sub returning () { Aspect::Pointcut::Returning->new; } =pod =head2 true # Intercept an adjustable random percentage of calls to a function our $RATE = 0.01; before { print "The few, the brave, the 1%\n"; } call 'My::foo' & true { rand() < $RATE }; Because of the lengths that B goes to internally to optimise the selection and interception of calls, writing your own custom pointcuts can be very difficult. When a custom or unusual pattern of interception is needed, often all that is desired is to extend a relatively normal pointcut with an extra caveat. To allow for this scenario, B provides the C pointcut. This pointcut allows you to specify any arbitrary code to match on. This code will be executed at run-time if the join point matches all previous conditions. The join point matches if the function or closure returns true, and does not match if the code returns false or nothing at all. =cut sub true (&) { Aspect::Pointcut::True->new(@_); } =pod =head2 before before { # Don't call the function, return instead $_->return_value(1); } call 'My::foo'; The B advice declaration is used to defined advice code that will be run instead of the code originally at the join points, but continuing on to the real function if no action is taken to say otherwise. When called in void context, as shown above, C will install the advice permanently into your program. When called in scalar context, as shown below, C will return a guard object and enable the advice for as long as that guard object continues to remain in scope or otherwise avoid being destroyed. SCOPE: { my $guard = before { print "Hello World!\n"; } call 'My::foo'; # This will print My::foo(); } # This will NOT print My::foo(); Because the end result of the code at the join points is irrelevant to this type of advice and the Aspect system does not need to hang around and maintain control during the join point, the underlying implementation is done in a way that is by far the fastest and with the least impact (essentially none) on the execution of your program. You are B encouraged to use C advice wherever possible for the current implementation, resorting to the other advice types when you truly need to be there are the end of the join point execution (or on both sides of it). For more information, see L. =cut sub before (&$) { Aspect::Advice::Before->new( lexical => defined wantarray, code => $_[0], pointcut => $_[1], ); } =pod =head2 after # Confuse a program by bizarely swapping return values and exceptions after { if ( $_->exception ) { $_->return_value($_->exception); } else { $_->exception($_->return_value); } } call 'My::foo' & wantscalar; The C declarator is used to create advice in which the advice code will be run after the join point has run, regardless of whether the function return correctly or throws an exception. For more information, see L. =cut sub after (&$) { Aspect::Advice::After->new( lexical => defined wantarray, code => $_[0], pointcut => $_[1], ); } =pod =head2 around # Trace execution time for a function around { my @start = Time::HiRes::gettimeofday(); $_->proceed; my @stop = Time::HiRes::gettimeofday(); my $elapsed = Time::HiRes::tv_interval( \@start, \@stop ); print "My::foo executed in $elapsed seconds\n"; } call 'My::foo'; The C declarator is used to create the most general form of advice, and can be used to implement the most high level functionality. It allows you to make changes to the calling parameters, to change the result of the function, to subvert or prevent the calling altogether, and to do so while storing extra lexical state of your own across the join point. For example, the code shown above tracks the time at which a single function is called and returned, and then uses the two pieces of information to track the execution time of the call. Similar functionality to the above is used to implement the CPAN modules L and the more complex L. Within the C advice code, the C<$_-Eproceed> method is used to call the original function with whatever the current parameter context is, storing the result (whether return values or an exception) in the context as well. Alternatively, you can use the C method to get access to a reference to the original function and call it directly without using context parameters and without storing the function results. around { $_->original->('alternative param'); $_->return_value('fake result'); } call 'My::foo'; The above example calls the original function directly with an alternative parameter in void context (regardless of the original C context) ignoring any return values. It then sets an entirely made up return value of it's own. Although it is the most powerful advice type, C is also the slowest advice type with the highest memory cost per join point. Where possible, you should try to use a more specific advice type. For more information, see L. =cut sub around (&$) { Aspect::Advice::Around->new( lexical => defined wantarray, code => $_[0], pointcut => $_[1], ); } =pod =head2 aspect aspect Singleton => 'Foo::new'; The C declarator is used to enable complete reusable aspects. The first parameter to C identifies the aspect library class. If the parameter is a fully resolved class name (i.e. it contains double colons like Foo::Bar) the value it will be used directly. If it is a simple C without colons then it will be interpreted as C. If the aspect class is not loaded, it will be loaded for you and validated as being a subclass of C. And further parameters will be passed on to the constructor for that class. See the documentation for each class for more information on the appropriate parameters for that class. As with each individual advice type complete aspects can be defined globally by using C in void context, or lexically via a guard object by calling C in scalar context. # Break on the topmost call to function for a limited time SCOPE: { my $break = aspect Breakpoint => call 'My::foo' & highest; do_something(); } For more information on writing reusable aspects, see L. =cut sub aspect { my $class = _LIBRARY(shift); return $class->new( lexical => defined wantarray, args => [ @_ ], ); } ###################################################################### # Private Functions # Run-time use call # NOTE: Do we REALLY need to do this as a use? # If the ->import method isn't important, change to native require. sub _LIBRARY { my $package = shift; if ( Params::Util::_IDENTIFIER($package) ) { $package = "Aspect::Library::$package"; } Params::Util::_DRIVER($package, 'Aspect::Library'); } 1; =pod =head1 OPERATORS =head2 & Overloading of bitwise C<&> for pointcut declarations allows a natural looking boolean "and" logic for pointcuts. When using the C<&> operator the combined pointcut expression will match if all pointcut subexpressions match. In the original Java AspectJ framework, the subexpressions are considered to be a union without an inherent order at all. In Perl you may treat them as ordered since they are ordered internally, but since all subexpressions run anyway you should probably not do anything that relies on this order. The optimiser may do interesting things with order in future, or we may move to an unordered implementation. For more information, see L. =head2 | Overloading of bitwise C<|> for pointcut declarations allows a natural looking boolean "or" logic for pointcuts. When using the C<|> operator the combined pointcut expression will match if either pointcut subexpressions match. The subexpressions are ostensibly considered without any inherent order, and you should treat them that way when you can. However, they are internally ordered and shortcutting will be applied as per normal Perl expressions. So for speed reasons, you may with to put cheap pointcut declarators before expensive ones where you can. The optimiser may do interesting things with order in future, or we may move to an unordered implementation. So as a general rule, avoid things that require order while using order to optimise where you can. For more information, see L. =head2 ! Overload of negation C for pointcut declarations allows a natural looking boolean "not" logic for pointcuts. When using the C operator the resulting pointcut expression will match if the single subexpression does B match. For more information, see L. =head1 METHODS A range of different methods are available within each type of advice code. The are summarised below, and described in more detail in L. =head2 type The C method is a convenience provided in the situation advice code is used in more than one type of advice, and wants to know the advice declarator is was made form. Returns C<"before">, C<"after"> or C<"around">. =head2 pointcut my $pointcut = $_->pointcut; The C method provides access to the original join point specification (as a tree of L objects) that the current join point matched against. =head2 original $_->original->( 1, 2, 3 ); In a pointcut, the C method returns a C reference to the original function before it was hooked by the L weaving process. # Prints "Full::Function::name" before { print $_->sub_name . "\n"; } call 'Full::Function::name'; The C method returns a string with the full resolved function name at the join point the advice code is running at. =head2 package_name # Prints "Just::Package" before { print $_->package_name . "\n"; } call 'Just::Package::name'; The C parameter is a convenience wrapper around the C method. Where C will return the fully resolved function name, the C method will return just the namespace of the package of the join point. =head2 short_name # Prints "name" before { print $_->short_name . "\n"; } call 'Just::Package::name'; The C parameter is a convenience wrapper around the C method. Where C will return the fully resolved function name, the C method will return just the name of the function. =head2 args # Get the parameters as a list my @list = $_->args; # Set the parameters $_->args( 1, 2, 3 ); # Append a parameter $_->args( $_->args, 'more' ); The C method allows you to get or set the list of parameters to a function. It is the method equivalent of manipulating the C<@_> array. =head2 self after { $_->self->save; } My::Foo::set; The C method is a convenience provided for when you are writing advice that will be working with object-oriented Perl code. It returns the first parameter to the method (which should be object), which you can then call methods on. =head2 wantarray # Return differently depending on the calling context if ( $_->wantarray ) { $_->return_value(5); } else { $_->return_value(1, 2, 3, 4, 5); } The C method returns the L context of the call to the function for the current join point. As with the core Perl C function, returns true if the function is being called in list context, false if the function is being called in scalar context, or C if the function is being called in void context. =head2 exception unless ( $_->exception ) { $_->exception('Kaboom'); } The C method is used to get the current die message or exception object, or to set the die message or exception object. =head2 return_value # Add an extra value to the returned list $_->return_value( $_->return_value, 'thing' ); # Return null (equivalent to "return;") $_->return_value; The C method is used to get or set the return value for the join point function, in a similar way to the normal Perl C keyword. =head2 proceed around { my $before = time; $_->proceed; my $elapsed = time - $before; print "Call to " . $_->sub_name . " took $elapsed seconds\n"; } call 'My::function'; Available only in C advice, the C method is used to run the join point function with the current join point context (parameters, scalar vs list call, etc) and store the result of the original call in the join point context (return values, exceptions etc). =head1 LIBRARY The main L distribution ships with the following set of libraries. These are not necesarily recommended or the best on offer. The are shipped with B for convenience, because they have no additional CPAN dependencies. Their purpose is summarised below, but see their own documentation for more information. =head2 Aspect::Library::Singleton L can be used to convert an existing class to function as a singleton and return the same object for every constructor call. =head2 Aspect::Library::Breakpoint L allows you to inject debugging breakpoints into a program using the full power and complexity of the C pointcuts. =head2 Aspect::Library::Wormhole L is a tool for passing objects down a call flow, without adding extra arguments to the frames between the source and the target, letting a function implicit context. =head2 Aspect::Library::Listenable L assysts in the implementation of the "Listenable" design pattern. It lets you define a function as emitting events that can be registed for by subscribers, and then add/remove subscribers for these events over time. When the functions that are listenable are called, registered subscribers will be notified. This lets you build a general event subscription system for your program. This could be as part of a plugin API or just for your own convenience. =head1 INTERNALS Due to the dynamic nature of Perl, there is no need for processing of source or byte code, as required in the Java and .NET worlds. The implementation is conceptually very simple: when you create advice, its pointcut is matched to find every sub defined in the symbol table that might match against the pointcut (potentially subject to further runtime conditions). Those that match, will get a special wrapper installed. The wrapper only executes if, during run-time, a compiled context test for the pointcut returns true. The wrapper code creates an advice context, and gives it to the advice code. Most of the complexity comes from the extensive optimisation that is used to reduce the impact of both weaving of the advice and the run-time costs of the wrappers added to your code. Some pointcuts like C are static and their full effect is known at weave time, so the compiled run-time function can be optimised away entirely. Some pointcuts like C are dynamic, so they are not used to select the functions to hook, but impose a run-time cost to determine whether or not they match. To make this process faster, when the advice is installed, the pointcut will not use itself directly for the compiled run-time function but will additionally generate a "curried" (optimised) version of itself. This curried version uses the fact that the run-time check will only be called if it matches the C pointcut pattern, and so no C pointcuts needed to be tested at run-time unless they are in deep and complex nested coolean logic. It also handles collapsing any boolean logic impacted by the safe removal of the C pointcuts. Further, where possible the pointcuts will be expressed as Perl source (including logic operators) and compiled into a single Perl expression. This not only massively reduces the number of functions to be called, but allows further optimisation of the pointcut by the opcode optimiser in perl itself. If you use only C pointcuts (alone or in boolean combinations) the currying results in a null test (the pointcut is optimised away entirely) and so the need to make a run-time point test will be removed altogether from the generated advice hooks, reducing call overheads significantly. If your pointcut does not have any static conditions (i.e. C) then the wrapper code will need to be installed into every function on the symbol table. This is highly discouraged and liable to result in hooks on unusual functions and unwanted side effects, potentially breaking your program. =head1 LIMITATIONS =head2 Inheritance Support Support for inheritance is lacking. Consider the following two classes: package Automobile; sub compute_mileage { # ... } package Van; use base 'Automobile'; And the following two advice: before { print "Automobile!\n"; } call 'Automobile::compute_mileage'; before { print "Van!\n"; } call 'Van::compute_mileage'; Some join points one would expect to be matched by the call pointcuts above, do not: $automobile = Automobile->new; $van = Van->new; $automobile->compute_mileage; # Automobile! $van->compute_mileage; # Automobile!, should also print Van! C will never be printed. This happens because B installs advice code on symbol table entries. C does not have one, so nothing happens. Until this is solved, you have to do the thinking about inheritance yourself. =head2 Performance You may find it very easy to shoot yourself in the foot with this module. Consider this advice: # Do not do this! before { print $_->sub_name; } cflow 'MyApp::Company::make_report'; The advice code will be installed on B sub loaded. The advice code will only run when in the specified call flow, which is the correct behavior, but it will be I on every sub in the system. This can be extremely slow because the run-time cost of checking C will occur on every single function called in your program. It happens because the C pointcut matches I subs during weave-time. It matches the correct sub during run-time. The solution is to narrow the pointcut: # Much better before { print $_->sub_name; } call qr/^MyApp::/ & cflow 'MyApp::Company::make_report'; =head1 TO DO There are a many things that could be added, if people have an interest in contributing to the project. =head2 Documentation * cookbook * tutorial * example of refactoring a useful CPAN module using aspects =head2 Pointcuts * New pointcuts: execution, cflowbelow, within, advice, calledby. Sure you can implement them today with Perl treachery, but it is too much work. * We need a way to match subs with an attribute, attributes::get() will currently not work. * isa() support for method pointcuts as Gaal Yahas suggested: match methods on class hierarchies without callbacks * Perl join points: phasic- BEGIN/INIT/CHECK/END =head2 Weaving * The current optimation has gone as far as it can, next we need to look into XS acceleration and byte code manipulation with B:: modules. * A debug flag to print out subs that were matched during weaving * Warnings when over 1000 methods wrapped * Allow finer control of advice execution order * Centralised hooking in wrappers so that each successive advice won't need to wrap around the previous one. * Allow lexical aspects to be safely removed completely, rather than being left in place and disabled as in the current implementation. =head1 SUPPORT Please report any bugs or feature requests through the web interface at L. =head1 INSTALLATION See L for information and options on installing Perl modules. =head1 AVAILABILITY The latest version of this module is available from the Comprehensive Perl Archive Network (CPAN). Visit to find a CPAN site near you. Or see L. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 SEE ALSO You can find AOP examples in the C directory of the distribution. L L L =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. Parts of the initial introduction courtesy Wikipedia. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/0000755000175100017510000000000012130724444013233 5ustar adamadamAspect-1.04/lib/Aspect/Pointcut.pm0000644000175100017510000002523612130724241015401 0ustar adamadampackage Aspect::Pointcut; =pod =head1 NAME Aspect::Pointcut - API for determining which events should be hooked =head1 DESCRIPTION Aspect-Oriented Programming implementations draw much of their power from the flexibility that can be applied to when a function call should or should not be hooked. B provides a robust and powerful API for defining the rules for when a function call should be hooked, and then applying the rules as optimally as possible. This optimisation is particularly important for any pure-Perl implementation, which cannot hook deeply into the underlying virtual machine as you might with a Java or Perl XS-based implementation. A running program can be seen as a collection of events. Events like a sub returning from a call, or a package being used. These are called join points. A pointcut defines a set of join points, taken from all the join points in the program. Different pointcut classes allow you to define the set in different ways, so you can target the exact join points you need. Pointcuts are constructed as trees; logical operations on pointcuts with one or two arguments (not, and, or) are themselves pointcut operators. You can construct them explicitly using object syntax, or you can use the convenience functions exported by Aspect and the overloaded operators C, C<&> and C<|>. =head1 METHODS =cut use strict; use Aspect::Pointcut::Or (); use Aspect::Pointcut::And (); use Aspect::Pointcut::Not (); our $VERSION = '1.04'; use overload ( # Keep traditional Perl boolification and stringification 'bool' => sub () { 1 }, '""' => sub { ref $_[0] }, # Overload bitwise boolean operators to perform logical transformations. '|' => sub { Aspect::Pointcut::Or->new( $_[0], $_[1] ) }, '&' => sub { Aspect::Pointcut::And->new( $_[0], $_[1] ) }, '!' => sub { Aspect::Pointcut::Not->new( $_[0] ) }, # Everything else should fail to match and throw an exception ); ###################################################################### # Constructor =pod =head2 new The C constructor creates new pointcut objects. All pointcut classes define their own rules around the parameters that are provided, but once created these pointcuts can then all be mixed together in an arbitrary fashion. Note: Unlike most Perl objects the default and recommended underlying datatype for pointcut objects is an C reference rather than C references. This is done because pointcut code can directly impact the speed of function calls, and so is extremely performance sensitive. =cut sub new { my $class = shift; bless [ @_ ], $class; } ###################################################################### # Weaving Methods my %PRUNE; my %IGNORE; BEGIN { # Classes we should not recurse down into %PRUNE = map { $_ => 1 } qw{ main B CORE DB Aspect }; # Classes we should not hook functions in %IGNORE = map { $_ => 1 } qw{ Aspect B Carp Carp::Heavy Config CORE DB DynaLoader Exporter Exporter::Heavy IO IO::Handle Regexp Sub::Uplevel UNIVERSAL attributes base feature fields lib strict warnings warnings::register }; } =pod =head2 match_all my @fully_resolved_function_names = $pointcut->match_all; The C method is the primary compile-time function called on the pointcut model by the core Aspect library. It will examine the list of all loaded functions and identify those which could potentially match, and will need to have hooks installed to intercept calls to those functions. These functions will not necesarily all result in Aspect code being run. Some functions may be called in all cases, but often further run-time analyis needs to be done before we can be sure the particular function call respresents a match. Returns a list of fully-resolved function names (e.g. "Module::Name::function") =cut sub match_all { my $self = shift; my @matches = (); # Curry the pointcut and compile the weave-time function my $curried = $self->curry_weave; my $compiled = $curried ? $self->compiled_weave : sub () { 1 }; unless ( $compiled ) { die "Failed to generate weave filter"; } # Quick initial root package scan to remove the need # for special-casing of main:: in the recursive scan. no strict 'refs'; my @search = (); my ($key,$value); while ( ($key,$value) = each %{*{"::"}} ) { next unless defined $value; local (*ENTRY) = $value; next unless defined *ENTRY{HASH}; next unless $key =~ /^([^\W\d]\w*)::\z/; # Suppress aggressively ignored things if ( $IGNORE{$1} and $PRUNE{$1} ) { next; } push @search, $1; } # Search using a simple package list-recursion while ( my $package = shift @search ) { no strict 'refs'; my ($key,$value); while ( ($key,$value) = each %{*{"$package\::"}} ) { next if $key =~ /[^\w:]/; next unless defined $value; $_ = "$package\::$key"; local(*ENTRY) = $value; # Is this a matched function? if ( defined *ENTRY{CODE} and not $IGNORE{$package} and not $Aspect::EXPORTED{$_} and $compiled->() ) { push @matches, $_; } # Is this a package we should recurse into? if ( not $PRUNE{$package} and s/::\z// and defined *ENTRY{HASH} ) { push @search, $_; } } } return @matches; } =pod =head2 match_define my $should_hook = $pointcut->match_define; At compile time, the only common factor in predicting the future state of a function call is the name of the function itself. The C method is called on the pointcut for each theoretically-matchable function in the entire Perl namespace that part of an ignored namespace, passing a single parameter of the fully-resolved function name. The method will determine if the function B match, and needs to be hooked for further checking at run-time, potentially calling C on child objects as well. Returns true if the function might match the pointcut, or false if the function can never possibly match the pointcut and should never be checked at run-time. =cut sub match_define { my $class = ref $_[0] || $_[0]; die("Method 'match_define' not implemented in class '$class'"); } =pod =head2 compile_weave The C method generates a custom function that is used to test if a particular named function should be hooked as a potential join point. =cut # Most pointcut conditions always match at weave time, so default to that sub compile_weave { return 1; } sub compiled_weave { my $self = shift; my $code = $self->compile_weave; return $code if ref $code; return eval "sub () { $code }"; } =pod =head2 compile_runtime The C method generates a custom function that is used to test if a particular named function should be hooked as a potential join point. =cut sub compile_runtime { my $class = ref $_[0] || $_[0]; die "Missing compile_runtime method for $class"; } sub compiled_runtime { my $self = shift; my $code = $self->compile_runtime; return $code if ref $code; return eval "sub () { $code }"; } =pod =head2 match_contains my $calls = $pointcut->match_contains('Aspect::Pointcut::Call'); The C method provides a convenience for the validation and optimisation systems. It is used to check for the existance of a particular condition type anywhere within the pointcut object tree. Returns the number of instances of a particular pointcut type within the tree. =cut sub match_contains { my $self = shift; return 1 if $self->isa($_[0]); return 0; } =pod =head2 match_always my $always = $pointcut->match_contains('Aspect::Pointcut::Throwing'); The C method provides a convenience for the validation and optimisation systems. It is used to check that a particular condition type will be tested at least once for a matching join point, regardless of which path the match takes through branching pointcut logic. Returns true if an expression type is encounter at least once in all branches, or false if there is any branch path that can be taken in which the condition won't be encountered. =cut sub match_always { die "CODE NOT IMPLEMENTED"; } =pod =head2 curry_runtime my $optimized_pointcut = $raw_pointcut->curry_runtime; In a production system, pointcut declarations can result in large and complex B object trees. Because this tree can contain a large amount of structure that is no longer relevant at run-time, it can end up making a long series of prohibitively expensive cascading method or function calls before every single regular function call. To reduce this cost down to something more reasonable, pointcuts are run through a currying process (see L). A variety of optimisations are used to simplify boolean nesting, to remove tests that are irrelevant once the compile-time hooks have all been set up, and to remove other tests that the currying process can determine will never need to be tested. The currying process will generate and return a new pointcut tree that is independent from the original, and that can perform a match test at the structurally minimum computational cost. Returns a new optimised B object if any further testing needs to be done at run-time for the pointcut. Returns null (C in scalar context or C<()> in list context) if the pointcut can be curried away to nothing, and no further testing needs to be done at run-time. =cut sub curry_runtime { my $class = ref $_[0] || $_[0]; die("Method 'curry_runtime' not implemented in class '$class'"); } =pod =head2 curry_weave The C method is similar to the C method, except that instead of reducing the pointcut to only elements that are relevant at run-time, it reduces the pointcut to only elements that are relevant at weave time. By remove purely run-time elements, the compile weave test code is made both faster and more accurate (some complicated situations can occur when there is a L in the tree). =cut sub curry_weave { my $class = ref $_[0] || $_[0]; die("Method 'curry_weave' not implemented in class '$class'"); } sub match_runtime { return 1; } ###################################################################### # Optional XS Acceleration BEGIN { local $@; eval <<'END_PERL'; use Class::XSAccessor::Array 1.08 { replace => 1, true => [ 'compile_weave', 'match_runtime' ], }; END_PERL } 1; __END__ =pod =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Guard.pm0000644000175100017510000000222212130724241014624 0ustar adamadampackage Aspect::Guard; =pod =head1 NAME Aspect::Guard - General purpose guard object for destroy-time actions =head1 SYNOPSIS SCOPE: { my $guard = Aspect::Guard->new( sub { print "Goodbye World!\n"; } ); } # Prints here as it exits the scope =head1 DESCRIPTION The B class shipping with L is a convenience module for creating C based objects that execute when they fall out of scope. It's usage is effectively summarised by the synopsis. =head1 METHODS =cut use strict; our $VERSION = '1.04'; =pod =head2 new my $guard = Aspect::Guard->new( sub { do_something(); } ); The C method creates a new guard object. It takes a single C references as a parameter, which it will bless into the guard class, which will execute the code reference when it's C hook is called. =cut sub new { bless $_[1], $_[0]; } sub DESTROY { $_[0]->(); } 1; =pod =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2011 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Advice/0000755000175100017510000000000012130724444014426 5ustar adamadamAspect-1.04/lib/Aspect/Advice/Around.pm0000644000175100017510000001311712130724241016212 0ustar adamadampackage Aspect::Advice::Around; use strict; # Added by eilara as hack around caller() core dump # NOTE: Now we've switched to Sub::Uplevel can this be removed? --ADAMK use Carp::Heavy (); use Carp (); use Sub::Uplevel (); use Aspect::Hook (); use Aspect::Advice (); use Aspect::Point (); our $VERSION = '1.04'; our @ISA = 'Aspect::Advice'; sub _install { my $self = shift; my $pointcut = $self->pointcut; my $code = $self->code; my $lexical = $self->lexical; # Get the curried version of the pointcut we will use for the # runtime checks instead of the original. # Because $MATCH_RUN is used in boolean conditionals, if there # is nothing to do the compiler will optimise away the code entirely. my $curried = $pointcut->curry_runtime; my $compiled = $curried ? $curried->compiled_runtime : undef; my $MATCH_RUN = $compiled ? 'do { local $_ = $Aspect::POINT; $compiled->() }' : 1; # When an aspect falls out of scope, we don't attempt to remove # the generated hook code, because it might (for reasons potentially # outside our control) have been recursively hooked several times # by both Aspect and other modules. # Instead, we store an "out of scope" flag that is used to shortcut # past the hook as quickely as possible. # This flag is shared between all the generated hooks for each # installed Aspect. # If the advice is going to last lexical then we don't need to # check or use the $out_of_scope variable. my $out_of_scope = undef; my $MATCH_DISABLED = $lexical ? '$out_of_scope' : '0'; # Find all pointcuts that are statically matched # wrap the method with advice code and install the wrapper foreach my $name ( $pointcut->match_all ) { my $NAME = $name; # For completeness no strict 'refs'; my $original = *$name{CODE}; unless ( $original ) { Carp::croak("Can't wrap non-existent subroutine ", $name); } # Any way to set prototypes other than eval? my $PROTOTYPE = prototype($original); $PROTOTYPE = defined($PROTOTYPE) ? "($PROTOTYPE)" : ''; # Generate the new function no warnings 'redefine'; eval <<"END_PERL"; die $@ if $@; package Aspect::Hook; *$NAME = sub $PROTOTYPE { # Is this a lexically scoped hook that has finished goto &\$original if $MATCH_DISABLED; # Apply any runtime-specific context checks my \$wantarray = wantarray; local \$Aspect::POINT = bless { type => 'around', pointcut => \$pointcut, original => \$original, sub_name => \$name, wantarray => \$wantarray, args => \\\@_, return_value => \$wantarray ? [ ] : undef, topic => \\\$_, }, 'Aspect::Point'; # Can we shortcut the advice code goto &\$original unless $MATCH_RUN; # Run the advice code SCOPE: { local \$_ = \$Aspect::POINT; Sub::Uplevel::uplevel( 1, \$code, \$Aspect::POINT, ); } # Return the result return \@{\$Aspect::POINT->{return_value}} if \$wantarray; return \$Aspect::POINT->{return_value}; }; END_PERL $self->{installed}++; } # If this will run lexical we don't need a descoping hook return unless $lexical; # Return the lexical descoping hook. # This MUST be stored and run at DESTROY-time by the # parent object calling _install. This is less bullet-proof # than the DESTROY-time self-executing blessed coderef return sub { $out_of_scope = 1 }; } # Check for pointcut usage not supported by the advice type sub _validate { my $self = shift; my $pointcut = $self->pointcut; # Pointcuts using "throwing" are irrelevant in before advice if ( $pointcut->match_contains('Aspect::Pointcut::Throwing') ) { return 'The pointcut throwing is illegal when used by around advice'; } # Pointcuts using "throwing" are irrelevant in before advice if ( $pointcut->match_contains('Aspect::Pointcut::Returning') ) { return 'The pointcut returning is illegal when used by around advice'; } $self->SUPER::_validate(@_); } 1; =pod =head1 NAME Aspect::Advice::Around - Execute code both before and after a function =head1 SYNOPSIS use Aspect; around { # Trace all calls to your module print STDERR "Called my function " . $_->sub_name . "\n"; # Lexically alter a global for this function local $MyModule::MAXSIZE = 1000; # Continue and execute the function $_->run_original; # Suppress exceptions for the call $_->return_value(1) if $_->exception; } call qr/^ MyModule::\w+ $/; =head1 DESCRIPTION The C advice type is used to execute code on either side of a function, allowing deep and precise control of how the function will be called when none of the other advice types are good enough. Using C advice is also critical if you want to lexically alter the environment in which the call will be made (as in the example above where a global variable is temporarily changed). This advice type is also the most computationally expensive to run, so if your problem can be solved with the use of a different advice type, particularly C, you should use that instead. Please note that unlike the other advice types, your code in C is required to trigger the execution of the target function yourself with the C method. If you do not C and also do not set either a C or C, the function call will return C in scalar context or the null list C<()> in list context. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2010 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Advice/After.pm0000644000175100017510000001505512130724241016026 0ustar adamadampackage Aspect::Advice::After; use strict; # Added by eilara as hack around caller() core dump # NOTE: Now we've switched to Sub::Uplevel can this be removed? --ADAMK use Carp::Heavy (); use Carp (); use Sub::Uplevel (); use Aspect::Hook (); use Aspect::Advice (); use Aspect::Point (); our $VERSION = '1.04'; our @ISA = 'Aspect::Advice'; # NOTE: To simplify debugging of the generated code, all injected string # fragments will be defined in $UPPERCASE, and all lexical variables to be # accessed via the closure will be in $lowercase. sub _install { my $self = shift; my $pointcut = $self->pointcut; my $code = $self->code; my $lexical = $self->lexical; # Get the curried version of the pointcut we will use for the # runtime checks instead of the original. # Because $MATCH_RUN is used in boolean conditionals, if there # is nothing to do the compiler will optimise away the code entirely. my $curried = $pointcut->curry_runtime; my $compiled = $curried ? $curried->compiled_runtime : undef; my $MATCH_RUN = $compiled ? '$compiled->()' : 1; # When an aspect falls out of scope, we don't attempt to remove # the generated hook code, because it might (for reasons potentially # outside our control) have been recursively hooked several times # by both Aspect and other modules. # Instead, we store an "out of scope" flag that is used to shortcut # past the hook as quickely as possible. # This flag is shared between all the generated hooks for each # installed Aspect. # If the advice is going to last lexical then we don't need to # check or use the $out_of_scope variable. my $out_of_scope = undef; my $MATCH_DISABLED = $lexical ? '$out_of_scope' : '0'; # Find all pointcuts that are statically matched # wrap the method with advice code and install the wrapper foreach my $name ( $pointcut->match_all ) { my $NAME = $name; # For completeness no strict 'refs'; my $original = *$name{CODE}; unless ( $original ) { Carp::croak("Can't wrap non-existent subroutine ", $name); } # Any way to set prototypes other than eval? my $PROTOTYPE = prototype($original); $PROTOTYPE = defined($PROTOTYPE) ? "($PROTOTYPE)" : ''; # Generate the new function no warnings 'redefine'; eval <<"END_PERL"; die $@ if $@; package Aspect::Hook; *$NAME = sub $PROTOTYPE { # Is this a lexically scoped hook that has finished goto &\$original if $MATCH_DISABLED; my \$wantarray = wantarray; if ( \$wantarray ) { my \$return = eval { [ Sub::Uplevel::uplevel( 2, \$original, \@_, ) ] }; local \$Aspect::POINT = bless { type => 'after', pointcut => \$pointcut, original => \$original, sub_name => \$name, wantarray => \$wantarray, args => \\\@_, return_value => \$return, exception => \$\@, }, 'Aspect::Point'; unless ( $MATCH_RUN ) { return \@\$return unless \$Aspect::POINT->{exception}; die \$Aspect::POINT->{exception}; } # Execute the advice code local \$_ = \$Aspect::POINT; &\$code(\$Aspect::POINT); # Throw the same (or modified) exception my \$exception = \$_->{exception}; die \$exception if \$exception; # Get the (potentially) modified return value return \@{\$_->{return_value}}; } if ( defined \$wantarray ) { my \$return = eval { Sub::Uplevel::uplevel( 2, \$original, \@_, ) }; local \$Aspect::POINT = bless { type => 'after', pointcut => \$pointcut, original => \$original, sub_name => \$name, wantarray => \$wantarray, args => \\\@_, return_value => \$return, exception => \$\@, }, 'Aspect::Point'; unless ( $MATCH_RUN ) { return \$return unless \$Aspect::POINT->{exception}; die \$Aspect::POINT->{exception}; } # Execute the advice code local \$_ = \$Aspect::POINT; &\$code(\$Aspect::POINT); # Throw the same (or modified) exception my \$exception = \$_->{exception}; die \$exception if \$exception; # Return the potentially-modified value return \$_->{return_value}; } eval { Sub::Uplevel::uplevel( 2, \$original, \@_, ) }; local \$Aspect::POINT = bless { type => 'after', pointcut => \$pointcut, original => \$original, sub_name => \$name, wantarray => \$wantarray, args => \\\@_, return_value => undef, exception => \$\@, }, 'Aspect::Point'; unless ( $MATCH_RUN ) { return unless \$Aspect::POINT->{exception}; die \$Aspect::POINT->{exception}; } # Execute the advice code local \$_ = \$Aspect::POINT; &\$code(\$Aspect::POINT); # Throw the same (or modified) exception my \$exception = \$_->{exception}; die \$exception if \$exception; return; }; END_PERL $self->{installed}++; } # If this will run lexical we don't need a descoping hook return unless $lexical; # Return the lexical descoping hook. # This MUST be stored and run at DESTROY-time by the # parent object calling _install. This is less bullet-proof # than the DESTROY-time self-executing blessed coderef return sub { $out_of_scope = 1 }; } 1; __END__ =pod =head1 NAME Aspect::Advice::After - Execute code after a function is called =head1 SYNOPSIS use Aspect; after { # Trace all returning calls to your module print STDERR "Called my function " . $_->sub_name . "\n"; # Suppress exceptions AND alter the results to foo() if ( $_->short_name eq 'foo' ) { if ( $_->exception ) { $_->return_value(1); } else { $_->return_value( $_->return_value + 1 ); } } } call qr/^ MyModule::\w+ $/ =head1 DESCRIPTION The C advice type is used to execute code after a function is called, regardless of whether or not the function returned normally or threw an exception. The C advice type should be used when you need to potentially make multiple different changes to the returned value or the thrown exception. If you only care about normally returned values you should use C in the pointcut to exclude join points occuring due to exceptions. If you only care about handling exceptions you should use C in the pointcut to exclude join points occuring due to normal return. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2010 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Advice/Before.pm0000644000175100017510000001343312130724241016165 0ustar adamadampackage Aspect::Advice::Before; use strict; # Added by eilara as hack around caller() core dump # NOTE: Now we've switched to Sub::Uplevel can this be removed? --ADAMK use Carp::Heavy (); use Carp (); use Aspect::Hook (); use Aspect::Advice (); use Aspect::Point (); our $VERSION = '1.04'; our @ISA = 'Aspect::Advice'; sub _install { my $self = shift; my $pointcut = $self->pointcut; my $code = $self->code; my $lexical = $self->lexical; # Get the curried version of the pointcut we will use for the # runtime checks instead of the original. # Because $MATCH_RUN is used in boolean conditionals, if there # is nothing to do the compiler will optimise away the code entirely. my $curried = $pointcut->curry_runtime; my $compiled = $curried ? $curried->compiled_runtime : undef; my $MATCH_RUN = $compiled ? '$compiled->()' : 1; # When an aspect falls out of scope, we don't attempt to remove # the generated hook code, because it might (for reasons potentially # outside our control) have been recursively hooked several times # by both Aspect and other modules. # Instead, we store an "out of scope" flag that is used to shortcut # past the hook as quickely as possible. # This flag is shared between all the generated hooks for each # installed Aspect. # If the advice is going to last lexical then we don't need to # check or use the $out_of_scope variable. my $out_of_scope = undef; my $MATCH_DISABLED = $lexical ? '$out_of_scope' : '0'; # Find all pointcuts that are statically matched # wrap the method with advice code and install the wrapper foreach my $name ( $pointcut->match_all ) { my $NAME = $name; # For completeness no strict 'refs'; my $original = *$name{CODE}; unless ( $original ) { Carp::croak("Can't wrap non-existent subroutine ", $name); } # Any way to set prototypes other than eval? my $PROTOTYPE = prototype($original); $PROTOTYPE = defined($PROTOTYPE) ? "($PROTOTYPE)" : ''; # Generate the new function no warnings 'redefine'; eval <<"END_PERL"; die $@ if $@; package Aspect::Hook; *$NAME = sub $PROTOTYPE { # Is this a lexically scoped hook that has finished goto &\$original if $MATCH_DISABLED; # Apply any runtime-specific context checks my \$wantarray = wantarray; local \$Aspect::POINT = bless { type => 'before', pointcut => \$pointcut, original => \$original, sub_name => \$name, wantarray => \$wantarray, args => \\\@_, exception => \$\@, ### Not used (yet) }, 'Aspect::Point'; local \$_ = \$Aspect::POINT; goto &\$original unless $MATCH_RUN; # Run the advice code &\$code(\$_); # Shortcut if they set a return value if ( exists \$_->{return_value} ) { return \@{\$_->{return_value}} if \$wantarray; return \$_->{return_value}; } # Proceed to the original function \@_ = \$_->args; ### Superfluous? goto &\$original; }; END_PERL $self->{installed}++; } # If this will run lexical we don't need a descoping hook return unless $lexical; # Return the lexical descoping hook. # This MUST be stored and run at DESTROY-time by the # parent object calling _install. This is less bullet-proof # than the DESTROY-time self-executing blessed coderef return sub { $out_of_scope = 1 }; } # Check for pointcut usage not supported by the advice type sub _validate { my $self = shift; my $pointcut = $self->pointcut; # The method used by the Highest pointcut is incompatible # with the goto optimisation used by the before() advice. if ( $pointcut->match_contains('Aspect::Pointcut::Highest') ) { return 'The pointcut highest is not currently supported by before advice'; } # Pointcuts using "throwing" are irrelevant in before advice if ( $pointcut->match_contains('Aspect::Pointcut::Throwing') ) { return 'The pointcut throwing is illegal when used by before advice'; } # Pointcuts using "throwing" are irrelevant in before advice if ( $pointcut->match_contains('Aspect::Pointcut::Returning') ) { return 'The pointcut returning is illegal when used by before advice'; } $self->SUPER::_validate(@_); } 1; __END__ =pod =head1 NAME Aspect::Advice::Before - Execute code before a function is called =head1 SYNOPSIS use Aspect; before { # Trace all calls to your module print STDERR "Called my function " . $_->sub_name . "\n"; # Shortcut calls to foo() to always be true if ( $_->short_name eq 'foo' ) { return $_->return_value(1); } # Add an extra flag to bar() but call as normal if ( $_->short_name eq 'bar' ) { $_->args( $_->args, 'flag' ); } } call qr/^ MyModule::\w+ $/ =head1 DESCRIPTION The C advice type is used to execute advice code prior to entry into a target function. It is implemented by B. As well as creating side effects that run before the main code, the C advice type is particularly useful for changing parameters or shortcutting calls to functions entirely and replacing the value they would normally return with a different value. Please note that the C pointcut (L) is incompatible with C. Creating a C advice with a pointcut tree that contains a C pointcut will result in an exception. If speed is important to your program then C is particular interesting as the C implementation is the only one that can take advantage of tail calls via Perl's C function, where the rest of the advice types need the more costly L to keep caller() returning correctly. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2010 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/0000755000175100017510000000000012130724444015040 5ustar adamadamAspect-1.04/lib/Aspect/Pointcut/Cflow.pm0000644000175100017510000000473012130724241016447 0ustar adamadampackage Aspect::Pointcut::Cflow; use strict; use Carp (); use Params::Util (); use Aspect::Pointcut (); use Aspect::Pointcut::Call (); use Aspect::Point::Static (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut'; use constant KEY => 0; use constant SPEC => 2; ###################################################################### # Constructor Methods sub new { my $class = shift; # Check and default the cflow key my $key = @_ > 1 ? shift : 'enclosing'; unless ( Params::Util::_IDENTIFIER($key) ) { Carp::croak('Invalid runtime context key'); } # Generate it via call my $call = Aspect::Pointcut::Call->new(shift); return bless [ $key, @$call ], $class; } ###################################################################### # Weaving Methods # The cflow pointcut is currently of no value at weave time, because it is # actually implemented as something closer to cflowbelow. sub curry_weave { return; } # The cflow pointcuts do not curry at all. # So they don't need to clone, and can be used directly. sub curry_runtime { return $_[0]; } ###################################################################### # Runtime Methods sub compile_runtime { my $self = shift; return sub { my $level = 2; my $caller = undef; while ( my $cc = caller_info($level++) ) { next unless $self->[SPEC]->( $cc->{sub_name} ); $caller = $cc; last; } return 0 unless $caller; my $static = bless { sub_name => $caller->{sub_name}, pointcut => $Aspect::POINT->{pointcut}, args => $caller->{args}, }, 'Aspect::Point::Static'; $Aspect::POINT->{$self->[KEY]} = $static; return 1; }; } sub caller_info { my $level = shift; package DB; my %call_info; @call_info{ qw( calling_package sub_name has_params ) } = (CORE::caller($level))[0, 3, 4]; return defined $call_info{calling_package} ? { %call_info, args => [ $call_info{has_params} ? @DB::args : () ], } : 0; } 1; __END__ =pod =head1 NAME Aspect::Pointcut::Cflow - Cflow pointcut =head1 SYNOPSIS Aspect::Pointcut::Cflow->new; =head1 DESCRIPTION None yet. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/Not.pm0000644000175100017510000000661312130724241016137 0ustar adamadampackage Aspect::Pointcut::Not; use strict; use Aspect::Pointcut::Logic (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut::Logic'; ###################################################################### # Constructor sub new { my $class = shift; # Check the thing we are negating unless ( Params::Util::_INSTANCE($_[0], 'Aspect::Pointcut') ) { Carp::croak("Attempted to apply pointcut logic to non-pointcut '$_[0]'"); } $class->SUPER::new(@_); } ###################################################################### # Weaving Methods sub compile_weave { my $child = $_[0]->[0]->compile_weave; if ( ref $child ) { return sub { not $child->() }; } unless ( $child eq '1' ) { return "not ( $child )"; } # When the child matches everything, the negation doesn't negate # the set of things matched. So we match everything too. return 1; } sub compile_runtime { my $child = $_[0]->[0]->compile_runtime; if ( ref $child ) { return sub { not $child->() }; } else { return "not ( $child )"; } } sub match_contains { my $self = shift; my $count = $self->[0]->match_contains($_[0]); return $self->isa($_[0]) ? ++$count : $count; } sub match_runtime { $_[0]->[0]->match_runtime; } # Logical not inherits it's curryability from the element contained # within it. We continue to be needed if and only if something below us # continues to be needed as well. sub curry_weave { my $self = shift; my $child = $self->[0]->curry_weave or return; # Handle the special case where the collapsing pointcut results # in a "double not". Fetch the child of our child not and return # it directly. if ( $child->isa('Aspect::Pointcut::Not') ) { return $child->[0]; } # Return our clone with the curried child my $class = ref($self); return $class->new( $child ); } # Logical not inherits it's curryability from the element contained # within it. We continue to be needed if and only if something below us # continues to be needed as well. # For cleanliness (and to avoid accidents) we make a copy of ourself # in case our child curries to something other than it's pure self. sub curry_runtime { my $self = shift; my $child = $self->[0]->curry_runtime or return; # Handle the special case where the collapsing pointcut results # in a "double not". Fetch the child of our child not and return # it directly. if ( $child->isa('Aspect::Pointcut::Not') ) { return $child->[0]; } # Return our clone with the curried child my $class = ref($self); return $class->new( $child ); } 1; __END__ =pod =head1 NAME Aspect::Pointcut::Not - Logical 'not' pointcut =head1 SYNOPSIS use Aspect; # High-level creation my $pointcut1 = ! call 'one'; # Manual creation my $pointcut2 = Aspect::Pointcut::Not->new( Aspect::Pointcut::Call->new('one') ); =head1 DESCRIPTION B is a logical condition, which is used to create higher-order conditions from smaller parts. It takes two or more conditions, and applies appropriate logic during the various calculations that produces a logical set-wise 'and' result. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/True.pm0000644000175100017510000000371412130724241016315 0ustar adamadampackage Aspect::Pointcut::True; use strict; use Aspect::Pointcut (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut'; ###################################################################### # Weaving Methods # The true pointcut is a run-time only pointcut sub curry_weave { return; } # The true pointcut contains no state and doesn't need to be curried. # Simply return it as-is and reuse it everywhere. sub curry_runtime { return $_[0]; } ###################################################################### # Runtime Methods sub compile_runtime { $_[0]->[0]; } ###################################################################### # Optional XS Acceleration BEGIN { local $@; eval <<'END_PERL'; use Class::XSAccessor::Array 1.08 { replace => 1, getters => { 'compile_runtime' => 0, }, }; END_PERL } 1; __END__ =pod =head1 NAME Aspect::Pointcut::True - Pointcut that allows arbitrary Perl code =head1 SYNOPSIS use Aspect; # High-level creation my $pointcut1 = true { rand() > 0.5 }; # Manual creation my $pointcut2 = Aspect::Pointcut::True->new( sub { rand() > 0.5 } ); =head1 DESCRIPTION Because L's weaving phase technically occurs at run-time (relative to the overall process) it does not need to be limit itself only to conditions that are fully describable at compile-time. B allows you to take advantage of this to create your own custom run-time pointcut conditions, although for safety and purity reasons you are not permitted to create custom conditions that interact with the L object for the call. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/Throwing.pm0000644000175100017510000000476312130724241017204 0ustar adamadampackage Aspect::Pointcut::Throwing; use strict; use Carp (); use Params::Util (); use Aspect::Pointcut (); use Aspect::Pointcut::Not (); use Aspect::Pointcut::Returning (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut'; ###################################################################### # Constructor sub new { my $class = shift; my $spec = shift; # Handle the any exception case unless ( defined $spec ) { return bless [ $spec, '$Aspect::POINT->{exception}', ], $class; } # Handle a specific die message if ( Params::Util::_STRING($spec) ) { return bless [ $spec, "Params::Util::_INSTANCE(\$Aspect::POINT->{exception}, '$spec')", ], $class; } # Handle a specific exception class if ( Params::Util::_REGEX($spec) ) { my $regex = "/$spec/"; $regex =~ s|^/\(\?([xism]*)-[xism]*:(.*)\)/\z|/$2/$1|s; return bless [ $spec, "defined \$Aspect::POINT->{exception} and not ref \$Aspect::POINT->{exception} and \$Aspect::POINT->{exception} =~ $regex", ], $class; } Carp::croak("Invalid throwing pointcut specification"); } ###################################################################### # Weaving Methods # Exception pointcuts always match at weave time and should curry away sub curry_weave { return; } # Throwing pointcuts do not curry. # (But maybe they should, when used with say a before {} block) sub curry_runtime { return $_[0]; } sub compile_runtime { $_[0]->[1]; } ###################################################################### # Optional XS Acceleration BEGIN { local $@; eval <<'END_PERL'; use Class::XSAccessor::Array 1.08 { replace => 1, getters => { 'compile_runtime' => 1, }, }; END_PERL } 1; __END__ =pod =head1 NAME Aspect::Pointcut::Throwing - Exception typing pointcut use Aspect; # Catch a Foo::Exception object exception after { $_->return_value(1) } throwing 'Foo::Exception'; =head1 DESCRIPTION The B pointcut is used to match situations in which an after() advice block wishes to intercept the throwing of a specific exception string or object. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/Returning.pm0000644000175100017510000000230612130724241017347 0ustar adamadampackage Aspect::Pointcut::Returning; use strict; use Carp (); use Aspect::Pointcut (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut'; ###################################################################### # Weaving Methods # Exception pointcuts always match at weave time and should curry away sub curry_weave { return; } # Exception-related pointcuts do not curry. sub curry_runtime { return $_[0]; } sub compile_runtime { 'defined $Aspect::POINT->{exception} and not ref $Aspect::POINT->{exception} and $Aspect::POINT->{exception} eq ""'; } 1; __END__ =pod =head1 NAME Aspect::Pointcut::Returning - Function returning without exception use Aspect; # Don't trap Foo::Exception object exceptions after { $_->return_value(1) } call 'Foo::bar' & returning; =head1 DESCRIPTION The B pointcut is used to match situations in which C advice should B run when the function is throwing an exception. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/Or.pm0000644000175100017510000001261512130724241015756 0ustar adamadampackage Aspect::Pointcut::Or; use strict; use Aspect::Pointcut::Logic (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut::Logic'; ###################################################################### # Constructor sub new { my $class = shift; my @parts = @_; # Validate the pointcut subexpressions foreach my $part ( @parts ) { next if Params::Util::_INSTANCE($part, 'Aspect::Pointcut'); Carp::croak("Attempted to apply pointcut logic to non-pointcut '$part'"); } # Collapse nested or statements at constructor time so we don't have # to do so multiple times later on during currying. while ( scalar grep { $_->isa('Aspect::Pointcut::Or') } @parts ) { @parts = map { $_->isa('Aspect::Pointcut::Or') ? @$_ : $_ } @parts; } $class->SUPER::new(@parts); } ###################################################################### # Weaving Methods sub compile_weave { my $self = shift; my @children = map { $_->compile_weave } @$self; # Collapse string conditions together, # and further collapse code conditions together. my @string = (); my @code = (); foreach my $child ( @children ) { # Short-cut if we contain any purely runtime pointcuts unless ( ref $child ) { return 1 if $child eq 1; push @string, $child; next; } if ( @string ) { my $group = join ' or ', map { "( $_ )" } @string; push @code, eval "sub () { $group }"; @string = (); } push @code, $child; } if ( @string ) { my $group = join ' or ', map { "( $_ )" } @string; unless ( @code ) { # This is the only thing we have return $group; } push @code, eval "sub () { $group }"; } # Join the groups return sub { foreach my $child ( @code ) { return 0 unless $child->(); } return 1; }; } sub compile_runtime { my $self = shift; my @children = map { $_->compile_runtime } @$self; # Collapse string conditions together, # and further collapse code conditions together. my @string = (); my @code = (); foreach my $child ( @children ) { # Short-cut if we contain any purely runtime pointcuts unless ( ref $child ) { return 1 if $child eq 1; push @string, $child; next; } if ( @string ) { my $group = join ' or ', map { "( $_ )" } @string; push @code, eval "sub () { $group }"; @string = (); } push @code, $child; } if ( @string ) { my $group = join ' or ', map { "( $_ )" } @string; unless ( @code ) { # This is the only thing we have return $group; } push @code, eval "sub () { $group }"; } # Join the groups return sub { foreach my $child ( @code ) { return 0 unless $child->(); } return 1; }; } sub match_contains { my $self = shift; my $count = $self->isa($_[0]) ? 1 : 0; foreach my $child ( @$self ) { $count += $child->match_contains($_[0]); } return $count; } sub match_runtime { my $self = shift; foreach my $child ( @$self ) { return 1 if $child->match_runtime; } return 0; } sub curry_weave { my $self = shift; my @list = @$self; # Curry down our children. Any null element always matches, and # therefore in an OR scenario the entire expression always matches. my @or = (); foreach my $child ( @list ) { my $curried = $child->curry_weave or return; push @or, $curried; } # If none are left, curry us away to nothing return unless @or; # If only one remains, curry us away to just that child return $list[0] if @or == 1; # Create our clone to hold the curried subset return ref($self)->new(@or); } sub curry_runtime { my $self = shift; my @list = @$self; # Should we strip out the call pointcuts my $strip = shift; unless ( defined $strip ) { # Are there any elements that MUST exist at run-time? if ( $self->match_runtime ) { # If we have any nested logic that themselves contain # call pointcuts, we can't strip. $strip = not scalar grep { $_->isa('Aspect::Pointcut::Logic') and $_->match_contains('Aspect::Pointcut::Call') } @list; } else { # Nothing at runtime, so we can strip $strip = 1; } } # Curry down our children @list = grep { defined $_ } map { $_->isa('Aspect::Pointcut::Call') ? $strip ? $_->curry_runtime($strip) : $_ : $_->curry_runtime($strip) } @list; # If none are left, curry us away to nothing return unless @list; # If only one remains, curry us away to just that child return $list[0] if @list == 1; # Create our clone to hold the curried subset return ref($self)->new( @list ); } 1; __END__ =pod =head1 NAME Aspect::Pointcut::Or - Logical 'or' pointcut =head1 SYNOPSIS use Aspect; # High-level creation my $pointcut1 = call 'one' | call 'two' | call 'three'; # Manual creation my $pointcut2 = Aspect::Pointcut::Or->new( Aspect::Pointcut::Call->new('one'), Aspect::Pointcut::Call->new('two'), Aspect::Pointcut::Call->new('three'), ); =head1 DESCRIPTION B is a logical condition, which is used to create higher-order conditions from smaller parts. It takes two or more conditions, and applies appropriate logic during the various calculations that produces a logical set-wise 'and' result. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/Call.pm0000644000175100017510000001036712130724241016253 0ustar adamadampackage Aspect::Pointcut::Call; use strict; use Carp (); use Params::Util (); use Aspect::Pointcut (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut'; use constant ORIGINAL => 0; use constant COMPILE_CODE => 1; use constant RUNTIME_CODE => 2; use constant COMPILE_EVAL => 3; use constant RUNTIME_EVAL => 4; ###################################################################### # Constructor Methods # The constructor stores three values. # $self->[0] is the original specification provided to the constructor # $self->[1] is a function form of the condition that has a sub name passed # in and returns true if matching or false if not. # $self->[2] is a function form of the condition that has the sub name set as # the topic variable. # $self->[3] is a function form of the condition that has the join point object # set as the topic variable. # $self->[4] is either a string Perl fragment that can be eval'ed with $_ set # as the sub name, or a function that can be called with $_ set as # the sub name. # $self->[5] is either a string Perl fragment that can be eval'ed with $_ set # as the join point variable, or a function that can be called with # $_ set as the join point variable. # All of 1-5 return true of the condition matches, or false if not. sub new { my $class = shift; my $spec = shift; if ( Params::Util::_STRING($spec) ) { my $string = '"' . quotemeta($spec) . '"'; return bless [ $spec, eval "sub () { \$_[0] eq $string }", eval "sub () { \$_ eq $string }", eval "sub () { \$Aspect::POINT->{sub_name} eq $string }", "\$_ eq $string", "\$Aspect::POINT->{sub_name} eq $string", ], $class; } if ( Params::Util::_CODELIKE($spec) ) { return bless [ $spec, $spec, sub { $spec->($_) }, sub { $spec->($Aspect::POINT->{sub_name}) }, sub { $spec->($_) }, sub { $spec->($Aspect::POINT->{sub_name}) }, ], $class; } if ( Params::Util::_REGEX($spec) ) { # Special case serialisation of regexs # In Perl 5.13.6 the format of a serialised regex changed # incompatibly. Worse, the optimisation trick that worked # before no longer works after, as there are now modifiers # that are ONLY value inside and can't be moved to the end. # So we first serialise to a form that will be valid code # under the new system, and then do the replace that will # only match (and only be valid) under the old system. my $regex = "/$spec/"; $regex =~ s|^/\(\?([xism]*)-[xism]*:(.*)\)/\z|/$2/$1|s; return bless [ $spec, eval "sub () { \$_[0] =~ $regex }", eval "sub () { $regex }", eval "sub () { \$Aspect::POINT->{sub_name} =~ $regex }", $regex, "\$Aspect::POINT->{sub_name} =~ $regex", ], $class; } Carp::croak("Invalid function call specification"); } ###################################################################### # Weaving Methods sub match_runtime { return 0; } # Call pointcuts are the primary thing used at weave time sub curry_weave { return $_[0]; } # Call pointcuts curry away to null, because they are the basis # for which methods to hook in the first place. Any method called # at run-time has already been checked. sub curry_runtime { return; } # Compiled string form of the pointcut sub compile_weave { $_[0]->[4]; } # Compiled string form of the pointcut sub compile_runtime { $_[0]->[5]; } ###################################################################### # Optional XS Acceleration BEGIN { local $@; eval <<'END_PERL'; use Class::XSAccessor::Array 1.08 { replace => 1, getters => { 'compile_weave' => 4, 'compile_runtime' => 5, }, }; END_PERL } 1; __END__ =pod =head1 NAME Aspect::Pointcut::Call - Call pointcut =head1 SYNOPSIS use Aspect; # High-level creation my $pointcut1 = call 'one'; # Manual creation my $pointcut2 = Aspect::Pointcut::Call->new('one'); =head1 DESCRIPTION None yet. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/Logic.pm0000644000175100017510000000212312130724241016424 0ustar adamadampackage Aspect::Pointcut::Logic; # A base class for logic pointcuts use strict; use Carp (); use Params::Util (); use Aspect::Pointcut (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut'; sub match_runtime { return 0; } 1; __END__ =pod =head1 NAME Aspect::Pointcut::Logic - Pointcut logic role =head1 DESCRIPTION A typical real world L object tree will contain a variety of different conditions. To combine these together a family of logic pointcuts are used. All of these can be identified by calling C<-Eisa('Aspect::Pointcut::Logic')> on them. This role is used primarily by the optimiser during the execution of various strategies, and does not have a significant use directly. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/And.pm0000644000175100017510000001323512130724241016077 0ustar adamadampackage Aspect::Pointcut::And; use strict; use Aspect::Pointcut::Logic (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut::Logic'; ###################################################################### # Constructor sub new { my $class = shift; my @parts = @_; # Validate the pointcut subexpressions foreach my $part ( @parts ) { next if Params::Util::_INSTANCE($part, 'Aspect::Pointcut'); Carp::croak("Attempted to apply pointcut logic to non-pointcut '$part'"); } # Collapse nested and statements at constructor time so we don't have # to do so multiple times later on during currying. while ( scalar grep { $_->isa('Aspect::Pointcut::And') } @parts ) { @parts = map { $_->isa('Aspect::Pointcut::And') ? @$_ : $_ } @parts; } $class->SUPER::new(@parts); } ###################################################################### # Weaving Methods sub compile_weave { my $self = shift; # Handle special cases my @children = grep { ref $_ or $_ ne 1 } map { $_->compile_weave } @$self; unless ( @children ) { # Potential bug, but why would we legitimately be empty return 1; } if ( @children == 1 ) { return $children[0]; } # Collapse string conditions together, # and further collapse code conditions together. my @string = (); my @code = (); foreach my $child ( @children ) { unless ( ref $child ) { push @string, $child; next; } if ( @string ) { my $group = join ' and ', map { "( $_ )" } @string; push @code, eval "sub () { $group }"; @string = (); } push @code, $child; } if ( @string ) { my $group = join ' and ', map { "( $_ )" } @string; unless ( @code ) { # This is the only thing we have return $group; } push @code, eval "sub () { $group }"; } # Join the groups return sub { foreach my $child ( @code ) { return 0 unless $child->(); } return 1; }; } sub compile_runtime { my $self = shift; # Handle special cases my @children = grep { ref $_ or $_ ne 1 } map { $_->compile_runtime } @$self; unless ( @children ) { # Potential bug, but why would we legitimately be empty return 1; } if ( @children == 1 ) { return $children[0]; } # Collapse string conditions together, # and further collapse code conditions together. my @string = (); my @code = (); foreach my $child ( @children ) { unless ( ref $child ) { push @string, $child; next; } if ( @string ) { my $group = join ' and ', map { "( $_ )" } @string; push @code, eval "sub () { $group }"; @string = (); } push @code, $child; } if ( @string ) { my $group = join ' and ', map { "( $_ )" } @string; unless ( @code ) { # This is the only thing we have return $group; } push @code, eval "sub () { $group }"; } # Join the groups return sub { foreach my $child ( @code ) { return 0 unless $child->(); } return 1; }; } sub match_contains { my $self = shift; my $type = shift; my $count = $self->isa($type) ? 1 : 0; foreach my $child ( @$self ) { $count += $child->match_contains($type); } return $count; } sub match_runtime { my $self = shift; foreach my $child ( @$self ) { return 1 if $child->match_runtime; } return 0; } sub curry_weave { my $self = shift; my @list = @$self; # Curry down our children. Anything that is not relevant at weave # time is considered to always match, but curries to null. # In an AND scenario, any "always" match can be savely removed. @list = grep { defined $_ } map { $_->curry_weave } @list; # If none are left, curry us away to nothing return unless @list; # If only one remains, curry us away to just that child return $list[0] if @list == 1; # Create our clone to hold the curried subset return ref($self)->new( @list ); } sub curry_runtime { my $self = shift; my @list = @$self; # Should we strip out the call pointcuts my $strip = shift; unless ( defined $strip ) { # Are there any elements that MUST exist at run-time? if ( $self->match_runtime ) { # If we have any nested logic that themselves contain # call pointcuts, we can't strip. $strip = not scalar grep { $_->isa('Aspect::Pointcut::Logic') and $_->match_contains('Aspect::Pointcut::Call') } @list; } else { # Nothing at runtime, so we can strip $strip = 1; } } # Curry down our children @list = grep { defined $_ } map { $_->isa('Aspect::Pointcut::Call') ? $strip ? $_->curry_runtime($strip) : $_ : $_->curry_runtime($strip) } @list; # If none are left, curry us away to nothing return unless @list; # If only one remains, curry us away to just that child return $list[0] if @list == 1; # Create our clone to hold the curried subset return ref($self)->new( @list ); } 1; __END__ =pod =head1 NAME Aspect::Pointcut::And - Logical 'and' pointcut =head1 SYNOPSIS use Aspect; # High-level creation my $pointcut1 = call 'one' & call 'two' & call 'three'; # Manual creation my $pointcut2 = Aspect::Pointcut::And->new( Aspect::Pointcut::Call->new('one'), Aspect::Pointcut::Call->new('two'), Aspect::Pointcut::Call->new('three'), ); =head1 DESCRIPTION B is a logical condition, which is used to create higher-order conditions from smaller parts. It takes two or more conditions, and applies appropriate logic during the various calculations that produces a logical set-wise 'and' result. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/Wantarray.pm0000644000175100017510000000407412130724241017346 0ustar adamadampackage Aspect::Pointcut::Wantarray; use strict; use Carp (); use Aspect::Pointcut (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut'; use constant VOID => 1; use constant SCALAR => 2; use constant LIST => 3; ###################################################################### # Constructor Methods sub new { return bless [ LIST, '$Aspect::POINT->{wantarray}', ], $_[0] if $_[1]; return bless [ SCALAR, 'defined $Aspect::POINT->{wantarray} and not $Aspect::POINT->{wantarray}', ], $_[0] if defined $_[1]; return bless [ VOID, 'not defined $Aspect::POINT->{wantarray}', ], $_[0]; } ###################################################################### # Weaving Methods # This is a run-time only pointcut of no value at weave time sub curry_weave { return; } # For wantarray pointcuts we keep the original sub curry_runtime { return $_[0]; } sub compile_runtime { $_[0]->[1]; } ###################################################################### # Optional XS Acceleration BEGIN { local $@; eval <<'END_PERL'; use Class::XSAccessor::Array 1.08 { replace => 1, getters => { 'compile_runtime' => 1, }, }; END_PERL } 1; __END__ =pod =head1 NAME Aspect::Pointcut::Wantarray - A pointcut for the run-time wantarray context =head1 SYNOPSIS use Aspect; # High-level creation my $pointcut1 = wantlist | wantscalar | wantvoid; # Manual creation my $pointcut2 = Padre::Pointcut::Or->new( Padre::Pointcut::Wantarray->new( 1 ), # List Padre::Pointcut::Wantarray->new( 0 ), # Scalar Padre::Pointcut::Wantarray->new( undef ), # Void ); =head1 DESCRIPTION The C pointcut allows the creation of aspects that only trap calls made in a particular calling context (list, scalar or void). =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Pointcut/Highest.pm0000644000175100017510000000406512130724241016771 0ustar adamadampackage Aspect::Pointcut::Highest; use strict; use Carp (); use Scalar::Util (); use Params::Util (); use Aspect::Guard (); use Aspect::Pointcut (); our $VERSION = '1.04'; our @ISA = 'Aspect::Pointcut'; ###################################################################### # Constructor Methods sub new { bless [ ], $_[0]; } ###################################################################### # Weaving Methods # The highest pointcut is a run-time only pointcut sub curry_weave { return; } # Call pointcuts curry away to null, because they are the basis # for which methods to hook in the first place. Any method called # at run-time has already been checked. sub curry_runtime { bless [ 0 ], $_[0]; } ###################################################################### # Runtime Methods sub compile_runtime { my $depth = 0; return sub { $_->{highest} = Aspect::Guard->new( sub { $depth-- } ); return ! $depth++; }; } 1; __END__ =pod =head1 NAME Aspect::Pointcut::Highest - Pointcut for preventing recursive matching =head1 SYNOPSIS use Aspect; # High-level creation my $pointcut1 = highest; # Manual creation my $pointcut2 = Aspect::Pointcut::Highest->new; =head1 DESCRIPTION For aspects including timers and other L-based advice, recursion can be significant problem. The C pointcut solves this problem by matching only on the highest invocation of a function. If the function is called again recursively within the first call, at any depth, the deeper calls will be not match and the advice will not be executed. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Legacy.pm0000644000175100017510000000630712130724241014776 0ustar adamadampackage Aspect::Legacy; =pod =head1 NAME Aspect::Legacy - Legacy Compatibility for Aspect.pm =head1 DESCRIPTION B implements emulated support for the L module as it existed in various forms prior to the 1.00 release in 2010. This includes both full legacy support for the original Ran Eilam release series ending in release 0.12, and for code written against the 0.16 to 0.99 development release series. In it's default usage, it is intended as a drop-in upgrade for any old Aspect-oriented code broken by changes in the second-generation (version 0.90 or later) implementation created during 2010. To upgrade our old code, simple change C to C and it should continue to function as normal. =cut use strict; use Aspect (); use Exporter (); our $VERSION = '1.04'; our @ISA = 'Exporter'; our @EXPORT = qw( aspect before after call cflow ); our $INSTALLED = 0; # Install deprecated functionality *Aspect::after_throwing = *Aspect::Legacy::after_throwing; *Aspect::after_returning = *Aspect::Legacy::after_returning; *Aspect::Point::params = *Aspect::Legacy::params; *Aspect::Point::params_ref = *Aspect::Legacy::params_ref; *Aspect::Point::append_param = *Aspect::Legacy::append_param; *Aspect::Point::append_params = *Aspect::Legacy::append_params; # Namespace aliasing to old names *Aspect::if_true = *Aspect::true; *Aspect::Point::short_sub_name = *Aspect::Point::short_name; *Aspect::Point::run_original = *Aspect::Point::proceed; *Aspect::Modular::params = *Aspect::Modular::args; # Copy original functions into this namespace so they can be exported *Aspect::Legacy::call = *Aspect::call; *Aspect::Legacy::cflow = *Aspect::cflow; *Aspect::Legacy::before = *Aspect::before; *Aspect::Legacy::after = *Aspect::Legacy::after_returning; *Aspect::Legacy::aspect = *Aspect::aspect; ###################################################################### # Deprecated Functionality # Aspect::advice sub advice { my $type = shift; if ( $type eq 'before' ) { return before(@_); } else { return after(@_); } } # Aspect::after_returning sub after_returning (&$) { Aspect::Advice::After->new( lexical => defined wantarray, code => $_[0], pointcut => Aspect::Pointcut::And->new( Aspect::Pointcut::Returning->new, $_[1], ), ); } # Aspect::after_throwing sub after_throwing (&$) { Aspect::Advice::After->new( lexical => defined wantarray, code => $_[0], pointcut => Aspect::Pointcut::And->new( Aspect::Pointcut::Throwing->new, $_[1], ), ); } # Aspect::Point::params_ref sub params_ref { $_[0]->{args}; } # Aspect::Point::params sub params { $_[0]->{args} = [ @_[1..$#_] ] if @_ > 1; return CORE::wantarray ? @{$_[0]->{args}} : $_[0]->{args}; } # Aspect::Point::append_param sub append_param { my $self = shift; $self->args( $self->args, @_ ); } # Aspect::Point::append_params sub append_params { my $self = shift; $self->args( $self->args, @_ ); } =pod =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Advice.pm0000644000175100017510000000746412130724241014772 0ustar adamadampackage Aspect::Advice; use strict; use Carp (); our $VERSION = '1.04'; sub new { my $class = shift; my $self = bless { @_, installed => 0, }, $class; # Validate the advice and pointcut combination my $error = $self->_validate; Carp::croak($error) if defined $error; # Install and save the lexical hook $self->{hook} = $self->_install; return $self; } sub code { $_[0]->{code}; } sub pointcut { $_[0]->{pointcut}; } sub lexical { $_[0]->{lexical}; } sub installed { $_[0]->{installed}; } sub DESTROY { $_[0]->{hook}->() if $_[0]->{hook}; } ###################################################################### # Installation Internals sub _install { my $class = ref $_[0] || $_[0]; die("Method '_install' is not implemented by class '$class'"); } sub _validate { my $self = shift; # The use of more than one highest rule in a pointcut is not supported if ( $self->pointcut->match_contains('Aspect::Pointcut::Highest') > 1 ) { return "Multiple highest pointcut use is not yet supported"; } return; } ###################################################################### # Optional XS Acceleration BEGIN { local $@; eval <<'END_PERL'; use Class::XSAccessor 1.08 { replace => 1, getters => { 'code' => 'code', 'pointcut' => 'pointcut', 'lexical' => 'lexical', }, }; END_PERL } 1; __END__ =pod =head1 NAME Aspect::Advice - Change how Perl code is run at a pointcut =head1 SYNOPSIS # Trace calls to all functions in all MyAccount classes use Aspect; before { print 'Called: '. $_->sub_name; } call qw/^MyAccount::/; # Repeat using the pure object-oriented interface use Aspect::Advice::Before (); use Aspect::Pointcut::Call (); my $advice = Aspect::Advice::Before->new( pointcut => Aspect::Pointcut::Call->new( qr/^MyAccount::/ ), code => sub { print 'called: '. $_->sub_name; }, ); =head1 DESCRIPTION An "advice" in AOP lingo is composed of a condition (known as a L) and some code that will run when that pointcut is true. This code is run before, after, or around the target pointcut depending on the particular advice type declaration used. You do not normally create advice using the constructor. By Cing L, you get five advice declaration subroutines imported. C is used to indicate code that should run prior to the function being called. See L for more information. C is used to indicate code that should run following the function being called, regardless of whether it returns normally or throws an exception. See L for more information. C is used to take deeper control of the call and gives you your own lexical scope between the caller and callee, with a specific C call required in your code to execute the target function. See L for more information. When the advice code is called, it is provided with an L object which describes the context of the call to the target function, and allows you to change it. This parameter is provided both via the topic variable C<$_> (since version 0.90) and additionally as the first parameter to the advice code (which may be deprecated at some point in the future). If you are creating C objects directly via the OO interface, you should never use this class directly but instead use the class of the particular type of advice you want to create. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Hook.pm0000644000175100017510000000170112130724241014463 0ustar adamadampackage Aspect::Hook; use strict; our $VERSION = '1.04'; 1; __END__ =pod =head1 NAME Aspect::Hook - Holding area for internal generated code =head1 DESCRIPTION During the weaving process L needs do a large amount of code generation and it is important that this generated code is kept away from the target packages to prevent accidental collisions and other pollution. To prevent this, all of the generated code is produced in a dedicated and isolated namespace. B is the namespace in which this happens. Beyond this purpose, this class services no other purpose. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Library.pm0000644000175100017510000000171112130724241015170 0ustar adamadampackage Aspect::Library; use strict; our $VERSION = '1.04'; 1; __END__ =pod =head1 NAME Aspect::Library - Base class for all reusable aspects =head1 DESCRIPTION B provides a base class for all reusable aspects, regardless of implementation. It was created as part of the L namespace reorganisation. It provides no functionality, and only acts as a method for identifying L libraries. The original first generation of libraries are implemented via the L class and are deeply tied to it. For the second generation API this lower level base class is provided to provide a mechanism for identifying all reusable library aspects, from either the L API or independently. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Point/0000755000175100017510000000000012130724444014324 5ustar adamadamAspect-1.04/lib/Aspect/Point/Static.pm0000644000175100017510000000216612130724241016111 0ustar adamadampackage Aspect::Point::Static; use strict; use Carp (); use Aspect::Point (); our $VERSION = '1.04'; our @ISA = 'Aspect::Point'; ###################################################################### # Error on anything this doesn't support sub return_value { Carp::croak("Cannot call return_value on static part of a join point"); } sub AUTOLOAD { my $self = shift; my $key = our $AUTOLOAD; $key =~ s/^.*:://; Carp::croak("Cannot call $key on static part of join point"); } 1; __END__ =pod =head1 NAME Aspect::Point::Static - The Join Point context for join point static parts =head1 DESCRIPTION This class implements the "static part" join point object, normally encounted during (and stored by) the C pointcut declarator. It implements the subset of L methods relating to the join point in general and not relating to the specific call to the join point. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Point/Functions.pm0000644000175100017510000000735712130724241016641 0ustar adamadampackage Aspect::Point::Functions; =pod =head1 NAME Aspect::Point::Functions - Allow point context methods to be called as functions =head1 SYNOPSIS use Aspect::Point::Functions; # This code is equivalent to the SYNOPSIS for Aspect::Point my $advice_code = sub { print type; # The advice type ('before') print pointcut; # The matching pointcut ($pointcut) print enclosing; # Access cflow pointcut advice context print sub_name; # The full package_name::sub_name print package_name; # The package name ('Person') print short_name; # The sub name (a get or set method) print self; # 1st parameter to the matching sub print (args)[1]; # 2nd parameter to the matching sub original->( x => 3 ); # Call matched sub independently return_value(4) # Set the return value }; =head1 DESCRIPTION In the AspectJ toolkit for Java which L is inspired by, the join point context information is retrieved through certain keywords. In L this initially proved too difficult to achieve without heavy source code rewriting, and so an alternative approach was taken using a topic object and methods. This B package attempts to implement the original function/keyword style of call. It is considered unsupported at this time. =cut use strict; use Exporter (); use Aspect::Point (); our $VERSION = '1.04'; our @ISA = 'Exporter'; our @EXPORT = qw{ type pointcut original sub_name package_name short_name self wantarray args exception return_value enclosing topic proceed }; sub type () { $_->{type}; } sub pointcut () { $_->{pointcut}; } sub original () { $_->{original}; } sub sub_name () { $_->{sub_name}; } sub package_name () { my $name = $_->{sub_name}; return '' unless $name =~ /::/; $name =~ s/::[^:]+$//; return $name; } sub short_name () { my $name = $_->{sub_name}; return $name unless $name =~ /::/; $name =~ /::([^:]+)$/; return $1; } sub self () { $_->{args}->[0]; } sub wantarray () { $_->{wantarray}; } sub args { if ( defined CORE::wantarray ) { return @{$_->{args}}; } else { @{$_->{args}} = @_; } } sub exception (;$) { unless ( $_->{type} eq 'after' ) { Carp::croak("Cannot call exception in $_->{exception} advice"); } return $_->{exception} if defined CORE::wantarray(); $_->{exception} = $_[0]; } sub return_value (;@) { # Handle usage in getter form if ( defined CORE::wantarray() ) { # Let the inherent magic of Perl do the work between the # list and scalar context calls to return_value return @{$_->{return_value} || []} if $_->{wantarray}; return $_->{return_value} if defined $_->{wantarray}; return; } # We've been provided a return value $_->{exception} = ''; $_->{return_value} = $_->{wantarray} ? [ @_ ] : pop; } sub enclosing () { $_[0]->{enclosing}; } sub topic () { Carp::croak("The join point method topic in reserved"); } sub proceed () { my $self = $_; unless ( $self->{type} eq 'around' ) { Carp::croak("Cannot call proceed in $self->{type} advice"); } local $_ = ${$self->{topic}}; if ( $self->{wantarray} ) { $self->return_value( Sub::Uplevel::uplevel( 2, $self->{original}, @{$self->{args}}, ) ); } elsif ( defined $self->{wantarray} ) { $self->return_value( scalar Sub::Uplevel::uplevel( 2, $self->{original}, @{$self->{args}}, ) ); } else { Sub::Uplevel::uplevel( 2, $self->{original}, @{$self->{args}}, ); } ${$self->{topic}} = $_; return; } 1; =pod =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2011 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Point.pm0000644000175100017510000003650312130724241014664 0ustar adamadampackage Aspect::Point; =pod =head1 NAME Aspect::Point - The Join Point context =head1 SYNOPSIS # An anonymous function suitable for use as advice code # across all advice types (as it uses no limited access methods) my $advice_code = sub { print $_->type; # The advice type ('before') print $_->pointcut; # The matching pointcut ($pointcut) print $_->enclosing; # Access cflow pointcut advice context print $_->sub_name; # The full package_name::sub_name print $_->package_name; # The package name ('Person') print $_->short_name; # The sub name (a get or set method) print $_->self; # 1st parameter to the matching sub print ($_->args)[1]; # 2nd parameter to the matching sub $_->original->( x => 3 ); # Call matched sub independently $_->return_value(4) # Set the return value }; =head1 DESCRIPTION Advice code is called when the advice pointcut is matched. In this code, there is often a need to access information about the join point context of the advice. Information like: What is the actual sub name matched? What are the parameters in this call that we matched? Sometimes you want to change the context for the matched sub, such as appending a parameter or even stopping the matched sub from being called at all. You do all these things through the C, which is an object that isa L. It is the only parameter provided to the advice code. It provides all the information required about the match context, and allows you to change the behavior of the matched sub. Note: Modifying parameters through the context in the code of an I advice, will have no effect, since the matched sub has already been called. In a future release this will be fixed so that the context for each advice type only responds to the methods relevant to that context, with the rest throwing an exception. =head2 Cflows If the pointcut of an advice is composed of at least one C the advice code may require not only the context of the advice, but the join point context of the cflows as well. This is required if you want to find out, for example, what the name of the sub that matched a cflow. In the synopsis example above, which method from C started the chain of calls that eventually reached the get/set on C? You can access cflow context in the synopsis above, by calling: $point->enclosing You get it from the main advice join point by calling a method named after the context key used in the cflow spec (which is "enclosing" if a custom name was not provided, in line with AspectJ terminology). In the synopsis pointcut definition, the cflow part was equivalent to: cflow enclosing => qr/^Company::/ ^^^^^^^^^ An L will be created for the cflow, and you can access it using the C method. =head1 EXAMPLES Print parameters to matched sub: before { print join ',', $_->args; } $pointcut; Append a parameter: before { $_->args( $_->args, 'extra parameter' ); } $pointcut; Don't proceed to matched sub, return 4 instead: before { shift->return_value(4); } $pointcut; Call matched sub again and again until it returns something defined: after { my $point = shift; my $return = $point->return_value; while ( not defined $return ) { $return = $point->original($point->params); } $point->return_value($return); } $pointcut; Print the name of the C object that started the chain of calls that eventually reached the get/set on C: before { print shift->enclosing->self->name; } $pointcut; =head1 METHODS =cut use strict; use Carp (); use Sub::Uplevel (); use Aspect::Point::Static (); our $VERSION = '1.04'; ###################################################################### # Aspect::Point Methods # sub new { # my $class = shift; # bless { @_ }, $class; # } =pod =head2 type The C method is a convenience provided in the situation something has a L method and wants to know the advice declarator it is made for. Returns C<"before"> in L advice, C<"after"> in L advice, or C<"around"> in L advice. =cut sub type { $_[0]->{type}; } =pod =head2 pointcut my $pointcut = $_->pointcut; The C method provides access to the original join point specification (as a tree of L objects) that the current join point matched against. Please note that the pointcut returned is the full and complete pointcut tree, due to the heavy optimisation used on the actual pointcut code when it is run there is no way at the time of advice execution to indicate which specific conditions in the pointcut tree matched and which did not. Returns an object which is a sub-class of L. =cut sub pointcut { $_[0]->{pointcut}; } =pod =head2 original $_->original->( 1, 2, 3 ); In a pointcut, the C method returns a C reference to the original function before it was hooked by the L weaving process. Calls made to the function are unprotected, parameters and calling context will not be replicated into the function, return params and exception will not be caught. =cut sub original { $_[0]->{original}; } =pod =head2 sub_name # Prints "Full::Function::name" before { print $_->sub_name . "\n"; } call 'Full::Function::name'; The C method returns a string with the full resolved function name at the join point the advice code is running at. =cut sub sub_name { $_[0]->{sub_name}; } =pod =head2 package_name # Prints "Just::Package" before { print $_->package_name . "\n"; } call 'Just::Package::name'; The C parameter is a convenience wrapper around the C method. Where C will return the fully resolved function name, the C method will return just the namespace of the package of the join point. =cut sub package_name { my $name = $_[0]->{sub_name}; return '' unless $name =~ /::/; $name =~ s/::[^:]+$//; return $name; } =pod =head2 short_name # Prints "name" before { print $_->short_name . "\n"; } call 'Just::Package::name'; The C parameter is a convenience wrapper around the C method. Where C will return the fully resolved function name, the C method will return just the name of the function. =cut sub short_name { my $name = $_[0]->{sub_name}; return $name unless $name =~ /::/; $name =~ /::([^:]+)$/; return $1; } =pod =head2 args # Add a parameter to the function call $_->args( $_->args, 'more' ); The C method allows you to get or set the list of parameters to a function. It is the method equivalent of manipulating the C<@_> array. It uses a slightly unusual calling convention based on list context, but does so in a way that allows your advice code to read very naturally. To summarise the situation, the three uses of the C method are listed below, along with their C<@_> equivalents. # Get the parameters as a list my @list = $_->args; # my $list = @_; # Get the number of parameters my $count = $_->args; # my $count = @_; # Set the parameters $_->args( 1, 2, 3 ); # @_ = ( 1, 2, 3 ); As you can see from the above example, when C is called in list context it returns the list of parameters. When it is called in scalar context, it returns the number of parameters. And when it is called in void context, it sets the parameters to the passed values. Although this is somewhat unconventional, it does allow the most common existing uses of the older C method to be changed directly to the new C method (such as the first example above). And unlike the original, you can legally call C in such a way as to set the function parameters to be an empty list (which you could not do with the older C method). # Set the function parameters to a null list $_->args(); =cut sub args { if ( defined CORE::wantarray ) { return @{$_[0]->{args}}; } else { @{$_[0]->{args}} = @_[1..$#_]; } } =pod =head2 self after { $_->self->save; } My::Foo::set; The C method is a convenience provided for when you are writing advice that will be working with object-oriented Perl code. It returns the first parameter to the method (which should be object), which you can then call methods on. The result is advice code that is much more natural to read, as you can see in the above example where we implement an auto-save feature on the class C, writing the contents to disk every time a value is set without error. At present the C method is implemented fairly naively, if used outside of object-oriented code it will still return something (including C in the case where there were no parameters to the join point function). =cut sub self { $_[0]->{args}->[0]; } =pod =head2 wantarray # Return differently depending on the calling context if ( $_->wantarray ) { $_->return_value(5); } else { $_->return_value(1, 2, 3, 4, 5); } The C method returns the L context of the call to the function for the current join point. As with the core Perl C function, returns true if the function is being called in list context, false if the function is being called in scalar context, or C if the function is being called in void context. B Prior to L 0.98 the wantarray context of the call to the join point was available not only via the C method, but the advice code itself was called in matching wantarray context to the function call, allowing you to use plain C in the advice code as well. As all the other information about the join point was available through methods, having this one piece of metadata available different was becoming an oddity. The C context of the join point is now B available by the C method. =cut sub wantarray { $_[0]->{wantarray}; } =pod =head2 exception unless ( $_->exception ) { $_->exception('Kaboom'); } The C method is used to get the current die message or exception object, or to set the die message or exception object. =cut sub exception { unless ( $_[0]->{type} eq 'after' ) { Carp::croak("Cannot call exception in $_[0]->{exception} advice"); } return $_[0]->{exception} if defined CORE::wantarray(); $_[0]->{exception} = $_[1]; } =pod =head2 return_value # Add an extra value to the returned list $_->return_value( $_->return_value, 'thing' ); The C method is used to get or set the return value for the join point function, in a similar way to the normal Perl C keyword. As with the C method, the C method is sensitive to the context in which it is called. When called in list context, the C method returns the join point return value as a list. If the join point is called in scalar context, this will be a single-element list containing the scalar return value. If the join point is called in void context, this will be a null list. When called in scalar context, the C method returns the join point return value as a scalar. If the join point is called in list context, this will be the number of vales in the return list. If the join point is called in void context, this will be C When called in void context, the C method sets the return value for the join point using semantics identical to the C keyword. Because of this change in behavior based on the context in which C is called, you should generally always set C in it's own statement to prevent accidentally calling it in non-void context. # Return null (equivalent to "return;") $_->return_value; In advice types that can be triggered by an exception, or need to determine whether to continue to the join point function, setting a return value via C is seen as implicitly indicating that any exception should be suppressed, or that we do B want to continue to the join point function. When you call the C method this does NOT trigger an immediate C equivalent in the advice code, the lines after C will continue to be executed as normal (to provide an opportunity for cleanup operations to be done and so on). If you use C inside an if/else structure you will still need to do an explicit C if you wish to break out of the advice code. Thus, if you wish to break out of the advice code as well as return with an alternative value, you should do the following. return $_->return_value('value'); This usage of C appears to be contrary to the above instruction that setting the return value should always be done on a standalone line to guarentee void context. However, in Perl the context of the current function is inherited by a function called with return in the manner shown above. Thus the usage of C in this way alone is guarenteed to also set the return value rather than fetch it. =cut sub return_value { my $self = shift; my $want = $self->{wantarray}; # Handle usage in getter form if ( defined CORE::wantarray() ) { # Let the inherent magic of Perl do the work between the # list and scalar context calls to return_value return @{$self->{return_value} || []} if $want; return $self->{return_value} if defined $want; return; } # We've been provided a return value $self->{exception} = ''; $self->{return_value} = $want ? [ @_ ] : pop; } sub proceed { my $self = shift; unless ( $self->{type} eq 'around' ) { Carp::croak("Cannot call proceed in $self->{type} advice"); } local $_ = ${$self->{topic}}; if ( $self->{wantarray} ) { $self->return_value( Sub::Uplevel::uplevel( 2, $self->{original}, @{$self->{args}}, ) ); } elsif ( defined $self->{wantarray} ) { $self->return_value( scalar Sub::Uplevel::uplevel( 2, $self->{original}, @{$self->{args}}, ) ); } else { Sub::Uplevel::uplevel( 2, $self->{original}, @{$self->{args}}, ); } ${$self->{topic}} = $_; return; } sub enclosing { $_[0]->{enclosing}; } sub topic { Carp::croak("The join point method topic in reserved"); } sub AUTOLOAD { my $self = shift; my $key = our $AUTOLOAD; $key =~ s/^.*:://; Carp::croak "Key does not exist: [$key]" unless exists $self->{$key}; return $self->{$key}; } # Improves performance by not having to send DESTROY calls # through AUTOLOAD, and not having to check for DESTROY in AUTOLOAD. sub DESTROY () { } ###################################################################### # Optional XS Acceleration BEGIN { local $@; eval <<'END_PERL'; use Class::XSAccessor 1.08 { replace => 1, getters => { 'type' => 'type', 'pointcut' => 'pointcut', 'original' => 'original', 'sub_name' => 'sub_name', 'wantarray' => 'wantarray', 'enclosing' => 'enclosing', }, }; END_PERL } 1; =pod =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Marcel GrEnauer Emarcel@cpan.orgE Ran Eilam Eeilara@cpan.orgE =head1 COPYRIGHT Copyright 2001 by Marcel GrEnauer Some parts copyright 2009 - 2013 Adam Kennedy. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Aspect-1.04/lib/Aspect/Modular.pm0000644000175100017510000000666012130724241015177 0ustar adamadampackage Aspect::Modular; use strict; use Aspect::Library (); our $VERSION = '1.04'; our @ISA = 'Aspect::Library'; sub new { my $class = shift; my $self = bless { @_ }, $class; # Generate the appropriate advice $self->{advice} = [ $self->get_advice( $self->args ) ]; # Warn if the aspect is supposed to be permanent, # but the advice isn't created as permanent. if ( $self->lexical ) { if ( grep { not $_->lexical } @{$self->{advice}} ) { warn("$class creates lexical advice for global aspects"); } } else { if ( grep { $_->lexical } @{$self->{advice}} ) { warn("$class creates global advice for lexical aspects"); } } return $self; } sub args { @{$_[0]->{args}}; } sub lexical { $_[0]->{lexical}; } sub get_advice { my $class = ref $_[0] || $_[0]; die("Method 'get_advice' is not implemented by class '$class'"); } ###################################################################### # Optional XS Acceleration BEGIN { local $@; eval <<'END_PERL'; use Class::XSAccessor 1.08 { replace => 1, getters => { 'lexical' => 'lexical', }, }; END_PERL } 1; __END__ =pod =head1 NAME Aspect::Modular - First generation base class for reusable aspects =head1 SYNOPSIS # Subclassing to create a reusable aspect package Aspect::Library::ConstructorTracer; use strict; use base 'Aspect::Modular'; use Aspect::Advice::After (); sub get_advice { my $self = shift; my $pointcut = shift; return Aspect::Advice::After->new( lexical => $self->lexical, pointcut => $pointcut, code => sub { print 'Created object: ' . shift->return_value . "\n"; }, ); } # Using the new aspect package main; use Aspect; # Print message when constructing new Person aspect ConstructorTracer => call 'Person::new'; =head1 DESCRIPTION All reusable aspect inherit from this class. Such aspects are created in user code, using the C sub exported by L. You call C with the class name of the reusable aspect (it must exist in the package C), and any parameters (pointcuts, class names, code to run, etc.) the specific aspect may require. The L aspect, for example, expects 2 pointcut specs for the wormhole source and target, while the L aspect expects a pointcut object, to select the subs to be profiled. You create a reusable aspect by subclassing this class, and providing one I