From: Moritz Bunkus Date: Fri, 12 Oct 2007 11:10:21 +0000 (+0000) Subject: Umstrukturierung des Verzeichnisses "modules": Das Unterverzeichnis "override" enthäl... X-Git-Tag: release-2.6.0beta1~470 X-Git-Url: http://wagnertech.de/git?a=commitdiff_plain;h=b179b8df8426376f1592c7fdc3e693ed564c2fc3;p=kivitendo-erp.git Umstrukturierung des Verzeichnisses "modules": Das Unterverzeichnis "override" enthält Modle, die Lx-Office vor den im System installierten Modulen lädt (z.B. YAML). Module in "fallback" werden hingegen nur geladen, wenn im System kein passendes Modul gefunden wurde. --- diff --git a/am.pl b/am.pl index 2d1605253..ac0a98a58 100755 --- a/am.pl +++ b/am.pl @@ -31,8 +31,8 @@ ####################################################################### BEGIN { - unshift @INC, "modules/YAML"; # Use our own version of YAML. - push @INC, "modules"; # Only use our own versions of modules if there's no system version. + unshift @INC, "modules/override"; # Use our own versions of various modules (e.g. YAML). + push @INC, "modules/fallback"; # Only use our own versions of modules if there's no system version. } # setup defaults, DO NOT CHANGE diff --git a/login.pl b/login.pl index a01fc10f8..354949b57 100755 --- a/login.pl +++ b/login.pl @@ -31,8 +31,8 @@ ####################################################################### BEGIN { - unshift @INC, "modules/YAML"; # Use our own version of YAML. - push @INC, "modules"; # Only use our own versions of modules if there's no system version. + unshift @INC, "modules/override"; # Use our own versions of various modules (e.g. YAML). + push @INC, "modules/fallback"; # Only use our own versions of modules if there's no system version. } # setup defaults, DO NOT CHANGE diff --git a/modules/CGI/.htaccess b/modules/CGI/.htaccess deleted file mode 100644 index 0a9a0473a..000000000 --- a/modules/CGI/.htaccess +++ /dev/null @@ -1,2 +0,0 @@ -Order Allow,Deny -Deny from all diff --git a/modules/CGI/Ajax.pm b/modules/CGI/Ajax.pm deleted file mode 100644 index 41e9c3342..000000000 --- a/modules/CGI/Ajax.pm +++ /dev/null @@ -1,1215 +0,0 @@ -package CGI::Ajax; -use strict; -use Data::Dumper; -use base qw(Class::Accessor); -use overload '""' => 'show_javascript'; # for building web pages, so - # you can just say: print $pjx -BEGIN { - use vars qw ($VERSION @ISA @METHODS); - @METHODS = qw(url_list coderef_list DEBUG JSDEBUG html - js_encode_function cgi_header_extra); - - CGI::Ajax->mk_accessors( @METHODS ); - - $VERSION = .697; -} - -########################################### main pod documentation begin ## - -=head1 NAME - -CGI::Ajax - a perl-specific system for writing Asynchronous web -applications - -=head1 SYNOPSIS - - use strict; - use CGI; # or any other CGI:: form handler/decoder - use CGI::Ajax; - - my $cgi = new CGI; - my $pjx = new CGI::Ajax( 'exported_func' => \&perl_func ); - - print $pjx->build_html( $cgi, \&Show_HTML); - - sub perl_func { - my $input = shift; - # do something with $input - my $output = $input . " was the input!"; - return( $output ); - } - - sub Show_HTML { - my $html = < - - Enter something: - -
-
- - - EOHTML - return $html; - } - -I - -=head1 DESCRIPTION - -CGI::Ajax is an object-oriented module that provides a unique -mechanism for using perl code asynchronously from javascript- -enhanced HTML pages. CGI::Ajax unburdens the user from having to -write extensive javascript, except for associating an exported -method with a document-defined event (such as onClick, onKeyUp, -etc). CGI::Ajax also mixes well with HTML containing more complex -javascript. - -CGI::Ajax supports methods that return single results or multiple -results to the web page, and supports returning values to multiple -DIV elements on the HTML page. - -Using CGI::Ajax, the URL for the HTTP GET/POST request is -automatically generated based on HTML layout and events, and the -page is then dynamically updated with the output from the perl -function. Additionally, CGI::Ajax supports mapping URL's to a -CGI::Ajax function name, so you can separate your code processing -over multiple scripts. - -Other than using the Class::Accessor module to generate CGI::Ajax' -accessor methods, CGI::Ajax is completely self-contained - it -does not require you to install a larger package or a full Content -Management System, etc. - -We have added I for other CGI handler/decoder modules, -like L or L, but we can't test these -since we run mod_perl2 only here. CGI::Ajax checks to see if a -header() method is available to the CGI object, and then uses it. -If method() isn't available, it creates it's own minimal header. - -A primary goal of CGI::Ajax is to keep the module streamlined and -maximally flexible. We are trying to keep the generated javascript -code to a minimum, but still provide users with a variety of -methods for deploying CGI::Ajax. And VERY little user javascript. - -=head1 EXAMPLES - -The CGI::Ajax module allows a Perl subroutine to be called -asynchronously, when triggered from a javascript event on the -HTML page. To do this, the subroutine must be I, -usually done during: - - my $pjx = new CGI::Ajax( 'JSFUNC' => \&PERLFUNC ); - -This maps a perl subroutine (PERLFUNC) to an automatically -generated Javascript function (JSFUNC). Next you setup a trigger this -function when an event occurs (e.g. "onClick"): - - onClick="JSFUNC(['source1','source2'], ['dest1','dest2']);" - -where 'source1', 'dest1', 'source2', 'dest2' are the DIV ids of -HTML elements in your page... - - - -
-
- -L sends the values from source1 and source2 to your -Perl subroutine and returns the results to dest1 and dest2. - -=head2 4 Usage Methods - -=over 4 - -=item 1 Standard CGI::Ajax example - -Start by defining a perl subroutine that you want available from -javascript. In this case we'll define a subrouting that determines -whether or not an input is odd, even, or not a number (NaN): - - use strict; - use CGI::Ajax; - use CGI; - - - sub evenodd_func { - my $input = shift; - - # see if input is defined - if ( not defined $input ) { - return("input not defined or NaN"); - } - - # see if value is a number (*thanks Randall!*) - if ( $input !~ /\A\d+\z/ ) { - return("input is NaN"); - } - - # got a number, so mod by 2 - $input % 2 == 0 ? return("EVEN") : return("ODD"); - } - -Alternatively, we could have used coderefs to associate an -exported name... - - my $evenodd_func = sub { - # exactly the same as in the above subroutine - }; - -Next we define a function to generate the web page - this can -be done many different ways, and can also be defined as an -anonymous sub. The only requirement is that the sub send back -the html of the page. You can do this via a string containing the -html, or from a coderef that returns the html, or from a function -(as shown here)... - - sub Show_HTML { - my $html = < - CGI::Ajax Example - - - Enter a number:  - -
-
-
-
- - -EOT - return $html; - } - -The exported Perl subrouting is triggered using the C -event handler of the input HTML element. The subroutine takes one -value from the form, the input element B<'val1'>, and returns the -the result to an HTML div element with an id of B<'resultdiv'>. -Sending in the input id in an array format is required to support -multiple inputs, and similarly, to output multiple the results, -you can use an array for the output divs, but this isn't mandatory - -as will be explained in the B usage. - -Now create a CGI object and a CGI::Ajax object, associating a reference -to our subroutine with the name we want available to javascript. - - my $cgi = new CGI(); - my $pjx = new CGI::Ajax( 'evenodd' => \&evenodd_func ); - -And if we used a coderef, it would look like this... - - my $pjx = new CGI::Ajax( 'evenodd' => $evenodd_func ); - -Now we're ready to print the output page; we send in the cgi -object and the HTML-generating function. - - print $pjx->build_html($cgi,\&Show_HTML); - -CGI::Ajax has support for passing in extra HTML header information -to the CGI object. This can be accomplished by adding a third -argument to the build_html() call. The argument needs to be a -hashref containing Key=>value pairs that CGI objects understand: - - print $pjx->build_html($cgi,\&Show_HTML, - {-charset=>'UTF-8, -expires=>'-1d'}); - -See L for more header() method options. - -That's it for the CGI::Ajax standard method. Let's look at -something more advanced. - -=item 2 Advanced CGI::Ajax example - -Let's say we wanted to have a perl subroutine process multiple -values from the HTML page, and similarly return multiple values -back to distinct divs on the page. This is easy to do, and -requires no changes to the perl code - you just create it as you -would any perl subroutine that works with multiple input values -and returns multiple values. The significant change happens in -the event handler javascript in the HTML... - - onClick="exported_func(['input1','input2'],['result1','result2']);" - -Here we associate our javascript function ("exported_func") with -two HTML element ids ('input1','input2'), and also send in two -HTML element ids to place the results in ('result1','result2'). - -=item 3 Sending Perl Subroutine Output to a Javascript function - -Occassionally, you might want to have a custom javascript function -process the returned information from your Perl subroutine. -This is possible, and the only requierment is that you change -your event handler code... - - onClick="exported_func(['input1'],[js_process_func]);" - -In this scenario, C is a javascript function you -write to take the returned value from your Perl subroutine and -process the results. I Beware that with this usage, B. If the exported Perl subroutine returns, e.g. 2 -values, then C would need to process the input -by working through an array, or using the javascript Function -C object. - - function js_process_func() { - var input1 = arguments[0] - var input2 = arguments[1]; - // do something and return results, or set HTML divs using - // innerHTML - document.getElementById('outputdiv').innerHTML = input1; - } - -=item 4 URL/Outside Script CGI::Ajax example - -There are times when you may want a different script to -return content to your page. This could be because you have -an existing script already written to perform a particular -task, or you want to distribute a part of your application to another -script. This can be accomplished in L by using a URL in -place of a locally-defined Perl subroutine. In this usage, -you alter you creation of the L object to link an -exported javascript function name to a local URL instead of -a coderef or a subroutine. - - my $url = 'scripts/other_script.pl'; - my $pjx = new CGI::Ajax( 'external' => $url ); - -This will work as before in terms of how it is called from you -event handler: - - onClick="external(['input1','input2'],['resultdiv']);" - -The other_script.pl will get the values via a CGI object and -accessing the 'args' key. The values of the B<'args'> key will -be an array of everything that was sent into the script. - - my @input = $cgi->params('args'); - $input[0]; # contains first argument - $input[1]; # contains second argument, etc... - -This is good, but what if you need to send in arguments to the -other script which are directly from the calling Perl script, -i.e. you want a calling Perl script's variable to be sent, not -the value from an HTML element on the page? This is possible -using the following syntax: - - onClick="exported_func(['args__$input1','args__$input2'], - ['resultdiv']);" - -Similary, if the external script required a constant as input -(e.g. C, you would use this syntax: - - onClick="exported_func(['args__42'],['resultdiv']);" - -In both of the above examples, the result from the external -script would get placed into the I element on our -(the calling script's) page. - -If you are sending more than one argument from an external perl -script back to a javascript function, you will need to split the -string (AJAX applications communicate in strings only) on something. -Internally, we use '__pjx__', and this string is checked for. If -found, L will automatically split it. However, if you -don't want to use '__pjx__', you can do it yourself: - -For example, from your Perl script, you would... - - return("A|B"); # join with "|" - -and then in the javascript function you would have something like... - - process_func() { - var arr = arguments[0].split("|"); - // arr[0] eq 'A' - // arr[1] eq 'B' - } - -In order to rename parameters, in case the outside script needs -specifically-named parameters and not CGI::Ajax' I<'args'> default -parameter name, change your event handler associated with an HTML -event like this - - onClick="exported_func(['myname__$input1','myparam__$input2'], - ['resultdiv']);" - -The URL generated would look like this... - -C - -You would then retrieve the input in the outside script with this... - - my $p1 = $cgi->params('myname'); - my $p1 = $cgi->params('myparam'); - -Finally, what if we need to get a value from our HTML page and we -want to send that value to an outside script but the outside script -requires a named parameter different from I<'args'>? You can -accomplish this with L using the getVal() javascript -method (which returns an array, thus the C notation): - - onClick="exported_func(['myparam__' + getVal('div_id')[0]], - ['resultdiv']);" - -This will get the value of our HTML element with and -I of I, and submit it to the url attached to -I. So if our exported handler referred to a URI -called I'; - return $rv; -} - -## new -sub new { - my ($class) = shift; - my $self = bless ({}, ref ($class) || $class); -# $self->SUPER::new(); - $self->JSDEBUG(0); # turn javascript debugging off (if on, - # extra info will be added to the web page output - # if set to 1, then the core js will get - # compressed, but the user-defined functions will - # not be compressed. If set to 2 (or anything - # greater than 1 or 0), then none of the - # javascript will get compressed. - # - $self->DEBUG(0); # turn debugging off (if on, check web logs) - - #accessorized attributes - $self->coderef_list({}); - $self->url_list({}); - #$self->html(""); - #$self->cgi(); - #$self->cgi_header_extra(""); # set cgi_header_extra to an empty string - - # setup a default endcoding; if you need support for international - # charsets, use 'escape' instead of encodeURIComponent. Due to the - # number of browser problems users report about scripts with a default of - # encodeURIComponent, we are setting the default to 'escape' - $self->js_encode_function('escape'); - - if ( @_ < 2 ) { - die "incorrect usage: must have fn=>code pairs in new\n"; - } - - while ( @_ ) { - my($function_name,$code) = splice( @_, 0, 2 ); - if ( ref( $code ) eq "CODE" ) { - if ( $self->DEBUG() ) { - print STDERR "name = $function_name, code = $code\n"; - } - # add the name/code to hash - $self->coderef_list()->{ $function_name } = $code; - } elsif ( ref($code) ) { - die "Unsuported code block/url\n"; - } else { - if ( $self->DEBUG() ) { - print STDERR "Setting function $function_name to url $code\n"; - } - # if it's a url, it is added here - $self->url_list()->{ $function_name } = $code; - } - } - return ($self); -} - -###################################################### -## METHODS - private ## -###################################################### - -# sub cgiobj(), cgi() -# -# Purpose: accessor method to associate a CGI object with our -# CGI::Ajax object -# Arguments: a CGI object -# Returns: CGI::Ajax objects cgi object -# Called By: originating cgi script, or build_html() -# -sub cgiobj { - my $self = shift; - # see if any values were sent in... - if ( @_ ) { - my $cgi = shift; - # add support for other CGI::* modules This requires that your web server - # be configured properly. I can't test anything but a mod_perl2 - # setup, so this prevents me from testing CGI::Lite,CGI::Simple, etc. - if ( ref($cgi) =~ /CGI.*/ ) { - if ( $self->DEBUG() ) { - print STDERR "cgiobj() received a CGI-like object ($cgi)\n"; - } - $self->{'cgi'} = $cgi; - } else { - die "CGI::Ajax -- Can't set internal CGI object to a non-CGI object ($cgi)\n"; - } - } - # return the object - return( $self->{'cgi'} ); -} - -sub cgi { - my $self = shift; - if ( @_ ) { - return( $self->cgiobj( @_ ) ); - } else { - return( $self->cgiobj() ); - } -} - -## # sub cgi_header_extra -## # -## # Purpose: accessor method to associate CGI header information -## # with the CGI::Ajax object -## # Arguments: a hashref with key=>value pairs that get handed off to -## # the CGI object's header() method -## # Returns: hashref of extra cgi header params -## # Called By: originating cgi script, or build_html() -## -## sub cgi_header_extra { -## my $self = shift; -## if ( @_ ) { -## $self->{'cgi_header_extra'} = shift; -## } -## return( $self->{'cgi_header_extra'} ); -## } - -# sub create_js_setRequestHeader -# -# Purpose: create text of the header for the javascript side, -# xmlhttprequest call -# Arguments: none -# Returns: text of header to pass to xmlhttpreq call so it will -# match whatever was setup for the main web-page -# Called By: originating cgi script, or build_html() -# - -sub create_js_setRequestHeader { - my $self = shift; - my $cgi_header_extra = $self->cgi_header_extra(); - my $js_header_string = q{r.setRequestHeader("}; - #$js_header_string .= $self->cgi()->header( $cgi_header_extra ); - $js_header_string .= $self->cgi()->header(); - $js_header_string .= q{");}; - #if ( ref $cgi_header_extra eq "HASH" ) { - # foreach my $k ( keys(%$cgi_header_extra) ) { - # $js_header_string .= $self->cgi()->header($cgi_headers) - # } - #} else { - #print STDERR $self->cgi()->header($cgi_headers) ; - - if ( $self->DEBUG() ) { - print STDERR "js_header_string is (", $js_header_string, ")\n"; - } - - return($js_header_string); -} - -# sub show_common_js() -# -# Purpose: create text of the javascript needed to interface with -# the perl functions -# Arguments: none -# Returns: text of common javascript subroutine, 'do_http_request' -# Called By: originating cgi script, or build_html() -# - -sub show_common_js { - my $self = shift; - my $encodefn = $self->js_encode_function(); - my $decodefn = $encodefn; - $decodefn =~ s/^(en)/de/; - $decodefn =~ s/^(esc)/unesc/; - #my $request_header_str = $self->create_js_setRequestHeader(); - my $request_header_str = ""; - my $rv = <
";
-    for( var i=0; i < ajax.length; i++ ) {
-      tmp += '' +
-      decodeURI(ajax[i].url) + ' 
';
-    }
-    document.getElementById('pjxdebugrequest').innerHTML = tmp + "
"; -} - -EOT - - if ( $self->JSDEBUG() <= 1 ) { - $rv = $self->compress_js($rv); - } - - return($rv); -} - -# sub compress_js() -# -# Purpose: searches the javascript for newlines and spaces and -# removes them (if a newline) or shrinks them to a single (if -# space). -# Arguments: javascript to compress -# Returns: compressed js string -# Called By: show_common_js(), -# - -sub compress_js { - my($self,$js) = @_; - return if not defined $js; - return if $js eq ""; - $js =~ s/\n//g; # drop newlines - $js =~ s/\s+/ /g; # replace 1+ spaces with just one space - return $js; -} - - -# sub insert_js_in_head() -# -# Purpose: searches the html value in the CGI::Ajax object and inserts -# the ajax javascript code in the section, -# or if no such section exists, then it creates it. If -# JSDEBUG is set, then an extra div will be added and the -# url wil be desplayed as a link -# Arguments: none -# Returns: none -# Called By: build_html() -# - -sub insert_js_in_head{ - my $self = shift; - my $mhtml = $self->html(); - my $newhtml; - my @shtml; - my $js = $self->show_javascript(); - - if ( $self->JSDEBUG() ) { - my $showurl=qq!

!; - # find the terminal so we can insert just before it - my @splith = $mhtml =~ /(.*)(<\s*\/\s*body[^>]*>?)(.*)/is; - $mhtml = $splith[0].$showurl.$splith[1].$splith[2]; - } - - # see if we can match on - @shtml= $mhtml =~ /(.*)(<\s*head[^>]*>?)(.*)/is; - if ( @shtml ) { - # yes, there's already a , so let's insert inside it, - # at the beginning - $newhtml = $shtml[0].$shtml[1].$js.$shtml[2]; - } elsif( @shtml= $mhtml =~ /(.*)(<\s*html[^>]*>?)(.*)/is){ - # there's no , so look for the tag, and insert out - # javascript inside that tag - $newhtml = $shtml[0].$shtml[1].$js.$shtml[2]; - } else { - $newhtml .= ""; - $newhtml .= $js; - $newhtml .= ""; - $newhtml .= "No head/html tags, nowhere to insert. Returning javascript anyway
"; - $newhtml .= ""; - } - $self->html($newhtml); - return; -} - -# sub handle_request() -# -# Purpose: makes sure a fname function name was set in the CGI -# object, and then tries to eval the function with -# parameters sent in on args -# Arguments: none -# Returns: the result of the perl subroutine, as text; if multiple -# arguments are sent back from the defined, exported perl -# method, then join then with a connector (__pjx__). -# Called By: build_html() -# - -sub handle_request { - my ($self) = shift; - - my $result; # $result takes the output of the function, if it's an - # array split on __pjx__ - my @other = (); # array for catching extra parameters - - # we need to access "fname" in the form from the web page, so make - # sure there is a CGI object defined - return undef unless defined $self->cgi(); - - my $rv = ""; - if ( $self->cgi()->can('header') ) { - $rv = $self->cgi()->header( $self->cgi_header_extra() ); - } else { - # don't have an object with a "header()" method, so just create - # a mimimal one - $rv = "Content-Type: text/html;"; - # TODO: - $rv .= $self->cgi_header_extra(); - $rv .= "\n\n"; - } - - # get the name of the function - my $func_name = $self->cgi()->param("fname"); - - # check if the function name was created - if ( defined $self->coderef_list()->{$func_name} ) { - my $code = $self->coderef_list()->{$func_name}; - - # eval the code from the coderef, and append the output to $rv - if ( ref($code) eq "CODE" ) { - eval { ($result, @other) = $code->( $self->cgi()->param("args") ) }; - - if ($@) { - # see if the eval caused and error and report it - # Should we be more severe and die? - if ( $self->DEBUG() ) { - print STDERR "Problem with code: $@\n"; - } - } - - if( @other ) { - $rv .= join( "__pjx__", ($result, @other) ); - if ( $self->DEBUG() ) { - print STDERR "rv = $rv\n"; - } - } else { - if ( defined $result ) { - $rv .= $result; - } - } - - } # end if ref = CODE - } else { - # # problems with the URL, return a CGI rrror - print STDERR "POSSIBLE SECURITY INCIDENT! Browser from ", $self->cgi()->remote_addr(); - print STDERR "\trequested URL: ", $self->cgi()->url(); - print STDERR "\tfname request: ", $self->cgi()->param('fname'); - print STDERR " -- returning Bad Request status 400\n"; - if ( $self->cgi()->can('header') ) { - return($self->cgi()->header( -status=>'400' )); - } else { - # don't have an object with a "header()" method, so just create - # a mimimal one with 400 error - $rv = "Status: 400\nContent-Type: text/html;\n\n"; - } - } - return $rv; -} - - -# sub make_function() -# -# Purpose: creates the javascript wrapper for the underlying perl -# subroutine -# Arguments: CGI object from web form, and the name of the perl -# function to export to javascript, or a url if the -# function name refers to another cgi script -# Returns: text of the javascript-wrapped perl subroutine -# Called By: show_javascript; called once for each registered perl -# subroutine -# - -sub make_function { - my ($self, $func_name ) = @_; - return("") if not defined $func_name; - return("") if $func_name eq ""; - my $rv = ""; - my $script = $0 || $ENV{SCRIPT_FILENAME}; - $script =~ s/.*[\/|\\](.+)$/$1/; - my $outside_url = $self->url_list()->{ $func_name }; - my $url = defined $outside_url ? $outside_url : $script; - if ($url =~ /\?/) { $url.='&'; } else {$url.='?'} - $url = "'$url'"; - my $jsdebug = ""; - if ( $self->JSDEBUG()) { - $jsdebug = "jsdebug()"; - } - - #create the javascript text - $rv .= <JSDEBUG() ) { - $rv = $self->compress_js($rv); - } - return $rv; -} - -=item register() - - Purpose: adds a function name and a code ref to the global coderef - hash, after the original object was created - Arguments: function name, code reference - Returns: none - Called By: originating web script - -=cut - -sub register { - my ( $self, $fn, $coderef ) = @_; - # coderef_list() is a Class::Accessor function - # url_list() is a Class::Accessor function - if ( ref( $coderef ) eq "CODE" ) { - $self->coderef_list()->{$fn} = $coderef; - } elsif ( ref($coderef) ) { - die "Unsupported code/url type - error\n"; - } else { - $self->url_list()->{$fn} = $coderef; - } -} - -=item JSDEBUG() - - Purpose: Show the AJAX URL that is being generated, and stop - compression of the generated javascript, both of which can aid - during debugging. If set to 1, then the core js will get - compressed, but the user-defined functions will not be - compressed. If set to 2 (or anything greater than 1 or 0), - then none of the javascript will get compressed. - - Arguments: JSDEBUG(0); # turn javascript debugging off - JSDEBUG(1); # turn javascript debugging on, some javascript compression - JSDEBUG(2); # turn javascript debugging on, no javascript compresstion - Returns: prints a link to the url that is being generated automatically by - the Ajax object. this is VERY useful for seeing what - CGI::Ajax is doing. Following the link, will show a page - with the output that the page is generating. - - Called By: $pjx->JSDEBUG(1) # where $pjx is a CGI::Ajax object; - -=item DEBUG() - - Purpose: Show debugging information in web server logs - Arguments: DEBUG(0); # turn debugging off (default) - DEBUG(1); # turn debugging on - Returns: prints debugging information to the web server logs using - STDERR - Called By: $pjx->DEBUG(1) # where $pjx is a CGI::Ajax object; - -=back - -=head1 BUGS - -Follow any bugs at our homepage.... - - http://www.perljax.us - -=head1 SUPPORT - -Check out the news/discussion/bugs lists at our homepage: - - http://www.perljax.us - -=head1 AUTHORS - - Brian C. Thomas Brent Pedersen - CPAN ID: BCT - bct.x42@gmail.com bpederse@gmail.com - -=head1 A NOTE ABOUT THE MODULE NAME - -This module was initiated using the name "Perljax", but then -registered with CPAN under the WWW group "CGI::", and so became -"CGI::Perljax". Upon further deliberation, we decided to change it's -name to L. - -=head1 COPYRIGHT - -This program is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -The full text of the license can be found in the -LICENSE file included with this module. - -=head1 SEE ALSO - -L -L -L - -=cut - -1; -__END__ diff --git a/modules/CGI/LICENSE b/modules/CGI/LICENSE deleted file mode 100644 index 9d0305b3f..000000000 --- a/modules/CGI/LICENSE +++ /dev/null @@ -1,383 +0,0 @@ -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" - ---------------------------------------------------------------------------- - -The General Public License (GPL) -Version 2, June 1991 - -Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, -Cambridge, MA 02139, 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 Library 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. Aggregation of this Package with a commercial distribution is always permitted -provided that the use of this Package is embedded; that is, when no overt attempt -is made to make this Package's interfaces visible to the end user of the -commercial distribution. Such use shall not be construed as a distribution of -this Package. - -9. The name of the Copyright Holder may not be used to endorse or promote -products derived from this software without specific prior written permission. - -10. 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 - - diff --git a/modules/CGI/README b/modules/CGI/README deleted file mode 100644 index 1af8860c6..000000000 --- a/modules/CGI/README +++ /dev/null @@ -1,41 +0,0 @@ -pod2text CGI::Perljax.pm > README - -CGI::Perljax - -Perljax - a perl-specific system for writing AJAX- or -DHTML-based web applications. - - -Perljax provides a unique mechanism for using perl code -asynchronously from javascript using AJAX to access user-written -perl functions/methods. Perljax unburdens the user from having to -write any javascript, except for having to associate an exported -method with a document-defined event (such as onClick, onKeyUp, -etc). Only in the more advanced implementations of a exported perl -method would a user need to write custom javascript. Perljax supports -methods that return single results, or multiple results to the web -page. No other projects that we know of are like Perljax for the -following reasons: 1. Perljax is targeted specifically for perl -development. 2. Perljax shields the user from having to write any -javascript at all (unless they want to). 3. The URL for the HTTP GET -request is automatically generated based on HTML layout and events, -and the page is then dynamically updated. 4. Perljax is not part -of a Content Management System, or some other larger project. - - -INSTALL - -perl Makefile.PL -make -make test -make install - -*If you are on a windows box you should use 'nmake' rather than 'make'. - -Installation will place Perljax into the system perl @INC path, but it -is important that you make sure mod_perl uses this path (which is -mod_perl's default behavior, and also assuming you use mod_perl, and -not just run perl as a CGI). - -Example scripts are provided in the source script directory, and can -also be seen on the project's website, http://www.perljax.us. diff --git a/modules/YAML/README b/modules/YAML/README deleted file mode 100644 index 0fbb2fd09..000000000 --- a/modules/YAML/README +++ /dev/null @@ -1,611 +0,0 @@ -NAME - YAML - YAML Ain't Markup Language (tm) - -SYNOPSIS - use YAML; - - # Load a YAML stream of 3 YAML documents into Perl data structures. - my ($hashref, $arrayref, $string) = Load(<<'...'); - --- - name: ingy - age: old - weight: heavy - # I should comment that I also like pink, but don't tell anybody. - favorite colors: - - red - - green - - blue - --- - - Clark Evans - - Oren Ben-Kiki - - Ingy döt Net - --- > - You probably think YAML stands for "Yet Another Markup Language". It - ain't! YAML is really a data serialization language. But if you want - to think of it as a markup, that's OK with me. A lot of people try - to use XML as a serialization format. - - "YAML" is catchy and fun to say. Try it. "YAML, YAML, YAML!!!" - ... - - # Dump the Perl data structures back into YAML. - print Dump($string, $arrayref, $hashref); - - # YAML::Dump is used the same way you'd use Data::Dumper::Dumper - use Data::Dumper; - print Dumper($string, $arrayref, $hashref); - -DESCRIPTION - The YAML.pm module implements a YAML Loader and Dumper based on the YAML - 1.0 specification. - - YAML is a generic data serialization language that is optimized for - human readability. It can be used to express the data structures of most - modern programming languages. (Including Perl!!!) - - For information on the YAML syntax, please refer to the YAML - specification. - -WHY YAML IS COOL - YAML is readable for people. - It makes clear sense out of complex data structures. You should find - that YAML is an exceptional data dumping tool. Structure is shown - through indentation, YAML supports recursive data, and hash keys are - sorted by default. In addition, YAML supports several styles of - scalar formatting for different types of data. - - YAML is editable. - YAML was designed from the ground up to be an excellent syntax for - configuration files. Almost all programs need configuration files, - so why invent a new syntax for each one? And why subject users to - the complexities of XML or native Perl code? - - YAML is multilingual. - Yes, YAML supports Unicode. But I'm actually referring to - programming languages. YAML was designed to meet the serialization - needs of Perl, Python, Ruby, Tcl, PHP, Javascript and Java. It was - also designed to be interoperable between those languages. That - means YAML serializations produced by Perl can be processed by - Python. - - YAML is taint safe. - Using modules like Data::Dumper for serialization is fine as long as - you can be sure that nobody can tamper with your data files or - transmissions. That's because you need to use Perl's "eval()" - built-in to deserialize the data. Somebody could add a snippet of - Perl to erase your files. - - YAML's parser does not need to eval anything. - - YAML is full featured. - YAML can accurately serialize all of the common Perl data structures - and deserialize them again without losing data relationships. - Although it is not 100% perfect (no serializer is or can be - perfect), it fares as well as the popular current modules: - Data::Dumper, Storable, XML::Dumper and Data::Denter. - - YAML.pm also has the ability to handle code (subroutine) references - and typeglobs. (Still experimental) These features are not found in - Perl's other serialization modules. - - YAML is extensible. - The YAML language has been designed to be flexible enough to solve - it's own problems. The markup itself has 3 basic construct which - resemble Perl's hash, array and scalar. By default, these map to - their Perl equivalents. But each YAML node also supports a tagging - mechanism (type system) which can cause that node to be interpreted - in a completely different manner. That's how YAML can support object - serialization and oddball structures like Perl's typeglob. - -YAML IMPLEMENTATIONS IN PERL - This module, YAML.pm, is really just the interface module for YAML - modules written in Perl. The basic interface for YAML consists of two - functions: "Dump" and "Load". The real work is done by the modules - YAML::Dumper and YAML::Loader. - - Different YAML module distributions can be created by subclassing - YAML.pm and YAML::Loader and YAML::Dumper. For example, YAML-Simple - consists of YAML::Simple YAML::Dumper::Simple and YAML::Loader::Simple. - - Why would there be more than one implementation of YAML? Well, despite - YAML's offering of being a simple data format, YAML is actually very - deep and complex. Implementing the entirety of the YAML specification is - a daunting task. - - For this reason I am currently working on 3 different YAML - implementations. - - YAML - The main YAML distribution will keeping evolving to support the - entire YAML specification in pure Perl. This may not be the fastest - or most stable module though. Currently, YAML.pm has lots of known - bugs. It is mostly a great tool for dumping Perl data structures to - a readable form. - - YAML::Lite - The point of YAML::Lite is to strip YAML down to the 90% that people - use most and offer that in a small, fast, stable, pure Perl form. - YAML::Lite will simply die when it is asked to do something it - can't. - - YAML::Syck - "libsyck" is the C based YAML processing library used by the Ruby - programming language (and also Python, PHP and Pugs). YAML::Syck is - the Perl binding to "libsyck". It should be very fast, but may have - problems of its own. It will also require C compilation. - - NOTE: Audrey Tang has actually completed this module and it works - great and is 10 times faster than YAML.pm. - - In the future, there will likely be even more YAML modules. Remember, - people other than Ingy are allowed to write YAML modules! - -FUNCTIONAL USAGE - YAML is completely OO under the hood. Still it exports a few useful top - level functions so that it is dead simple to use. These functions just - do the OO stuff for you. If you want direct access to the OO API see the - documentation for YAML::Dumper and YAML::Loader. - - Exported Functions - The following functions are exported by YAML.pm by default. The reason - they are exported is so that YAML works much like Data::Dumper. If you - don't want functions to be imported, just use YAML with an empty import - list: - - use YAML (); - - Dump(list-of-Perl-data-structures) - Turn Perl data into YAML. This function works very much like - Data::Dumper::Dumper(). It takes a list of Perl data strucures and - dumps them into a serialized form. It returns a string containing - the YAML stream. The structures can be references or plain scalars. - - Load(string-containing-a-YAML-stream) - Turn YAML into Perl data. This is the opposite of Dump. Just like - Storable's thaw() function or the eval() function in relation to - Data::Dumper. It parses a string containing a valid YAML stream into - a list of Perl data structures. - - Exportable Functions - These functions are not exported by default but you can request them in - an import list like this: - - use YAML qw'freeze thaw Bless'; - - freeze() and thaw() - Aliases to Dump() and Load() for Storable fans. This will also allow - YAML.pm to be plugged directly into modules like POE.pm, that use - the freeze/thaw API for internal serialization. - - DumpFile(filepath, list) - Writes the YAML stream to a file instead of just returning a string. - - LoadFile(filepath) - Reads the YAML stream from a file instead of a string. - - Bless(perl-node, [yaml-node | class-name]) - Associate a normal Perl node, with a yaml node. A yaml node is an - object tied to the YAML::Node class. The second argument is either a - yaml node that you've already created or a class (package) name that - supports a yaml_dump() function. A yaml_dump() function should take - a perl node and return a yaml node. If no second argument is - provided, Bless will create a yaml node. This node is not returned, - but can be retrieved with the Blessed() function. - - Here's an example of how to use Bless. Say you have a hash - containing three keys, but you only want to dump two of them. - Furthermore the keys must be dumped in a certain order. Here's how - you do that: - - use YAML qw(Dump Bless); - $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; - print Dump $hash; - Bless($hash)->keys(['banana', 'apple']); - print Dump $hash; - - produces: - - --- - apple: good - banana: bad - cauliflower: ugly - --- - banana: bad - apple: good - - Bless returns the tied part of a yaml-node, so that you can call the - YAML::Node methods. This is the same thing that YAML::Node::ynode() - returns. So another way to do the above example is: - - use YAML qw(Dump Bless); - use YAML::Node; - $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; - print Dump $hash; - Bless($hash); - $ynode = ynode(Blessed($hash)); - $ynode->keys(['banana', 'apple']); - print Dump $hash; - - Note that Blessing a Perl data structure does not change it anyway. - The extra information is stored separately and looked up by the - Blessed node's memory address. - - Blessed(perl-node) - Returns the yaml node that a particular perl node is associated with - (see above). Returns undef if the node is not (YAML) Blessed. - -GLOBAL OPTIONS - YAML options are set using a group of global variables in the YAML - namespace. This is similar to how Data::Dumper works. - - For example, to change the indentation width, do something like: - - local $YAML::Indent = 3; - - The current options are: - - DumperClass - You can override which module/class YAML uses for Dumping data. - - LoaderClass - You can override which module/class YAML uses for Loading data. - - Indent - This is the number of space characters to use for each indentation - level when doing a Dump(). The default is 2. - - By the way, YAML can use any number of characters for indentation at - any level. So if you are editing YAML by hand feel free to do it - anyway that looks pleasing to you; just be consistent for a given - level. - - SortKeys - Default is 1. (true) - - Tells YAML.pm whether or not to sort hash keys when storing a - document. - - YAML::Node objects can have their own sort order, which is usually - what you want. To override the YAML::Node order and sort the keys - anyway, set SortKeys to 2. - - Stringify - Default is 0. (false) - - Objects with string overloading should honor the overloading and - dump the stringification of themselves, rather than the actual - object's guts. - - UseHeader - Default is 1. (true) - - This tells YAML.pm whether to use a separator string for a Dump - operation. This only applies to the first document in a stream. - Subsequent documents must have a YAML header by definition. - - UseVersion - Default is 0. (false) - - Tells YAML.pm whether to include the YAML version on the - separator/header. - - --- %YAML:1.0 - - AnchorPrefix - Default is ''. - - Anchor names are normally numeric. YAML.pm simply starts with '1' - and increases by one for each new anchor. This option allows you to - specify a string to be prepended to each anchor number. - - UseCode - Setting the UseCode option is a shortcut to set both the DumpCode - and LoadCode options at once. Setting UseCode to '1' tells YAML.pm - to dump Perl code references as Perl (using B::Deparse) and to load - them back into memory using eval(). The reason this has to be an - option is that using eval() to parse untrusted code is, well, - untrustworthy. - - DumpCode - Determines if and how YAML.pm should serialize Perl code references. - By default YAML.pm will dump code references as dummy placeholders - (much like Data::Dumper). If DumpCode is set to '1' or 'deparse', - code references will be dumped as actual Perl code. - - DumpCode can also be set to a subroutine reference so that you can - write your own serializing routine. YAML.pm passes you the code ref. - You pass back the serialization (as a string) and a format - indicator. The format indicator is a simple string like: 'deparse' - or 'bytecode'. - - LoadCode - LoadCode is the opposite of DumpCode. It tells YAML if and how to - deserialize code references. When set to '1' or 'deparse' it will - use "eval()". Since this is potentially risky, only use this option - if you know where your YAML has been. - - LoadCode can also be set to a subroutine reference so that you can - write your own deserializing routine. YAML.pm passes the - serialization (as a string) and a format indicator. You pass back - the code reference. - - UseBlock - YAML.pm uses heuristics to guess which scalar style is best for a - given node. Sometimes you'll want all multiline scalars to use the - 'block' style. If so, set this option to 1. - - NOTE: YAML's block style is akin to Perl's here-document. - - UseFold - If you want to force YAML to use the 'folded' style for all - multiline scalars, then set $UseFold to 1. - - NOTE: YAML's folded style is akin to the way HTML folds text, except - smarter. - - UseAliases - YAML has an alias mechanism such that any given structure in memory - gets serialized once. Any other references to that structure are - serialized only as alias markers. This is how YAML can serialize - duplicate and recursive structures. - - Sometimes, when you KNOW that your data is nonrecursive in nature, - you may want to serialize such that every node is expressed in full. - (ie as a copy of the original). Setting $YAML::UseAliases to 0 will - allow you to do this. This also may result in faster processing - because the lookup overhead is by bypassed. - - THIS OPTION CAN BE DANGEROUS. *If* your data is recursive, this - option *will* cause Dump() to run in an endless loop, chewing up - your computers memory. You have been warned. - - CompressSeries - Default is 1. - - Compresses the formatting of arrays of hashes: - - - - foo: bar - - - bar: foo - - becomes: - - - foo: bar - - bar: foo - - Since this output is usually more desirable, this option is turned - on by default. - -YAML TERMINOLOGY - YAML is a full featured data serialization language, and thus has its - own terminology. - - It is important to remember that although YAML is heavily influenced by - Perl and Python, it is a language in its own right, not merely just a - representation of Perl structures. - - YAML has three constructs that are conspicuously similar to Perl's hash, - array, and scalar. They are called mapping, sequence, and string - respectively. By default, they do what you would expect. But each - instance may have an explicit or implicit tag (type) that makes it - behave differently. In this manner, YAML can be extended to represent - Perl's Glob or Python's tuple, or Ruby's Bigint. - - stream - A YAML stream is the full sequence of unicode characters that a YAML - parser would read or a YAML emitter would write. A stream may - contain one or more YAML documents separated by YAML headers. - - --- - a: mapping - foo: bar - --- - - a - - sequence - - document - A YAML document is an independent data structure representation - within a stream. It is a top level node. Each document in a YAML - stream must begin with a YAML header line. Actually the header is - optional on the first document. - - --- - This: top level mapping - is: - - a - - YAML - - document - - header - A YAML header is a line that begins a YAML document. It consists of - three dashes, possibly followed by more info. Another purpose of the - header line is that it serves as a place to put top level tag and - anchor information. - - --- !recursive-sequence &001 - - * 001 - - * 001 - - node - A YAML node is the representation of a particular data stucture. - Nodes may contain other nodes. (In Perl terms, nodes are like - scalars. Strings, arrayrefs and hashrefs. But this refers to the - serialized format, not the in-memory structure.) - - tag This is similar to a type. It indicates how a particular YAML node - serialization should be transferred into or out of memory. For - instance a Foo::Bar object would use the tag 'perl/Foo::Bar': - - - !perl/Foo::Bar - foo: 42 - bar: stool - - collection - A collection is the generic term for a YAML data grouping. YAML has - two types of collections: mappings and sequences. (Similar to hashes - and arrays) - - mapping - A mapping is a YAML collection defined by unordered key/value pairs - with unique keys. By default YAML mappings are loaded into Perl - hashes. - - a mapping: - foo: bar - two: times two is 4 - - sequence - A sequence is a YAML collection defined by an ordered list of - elements. By default YAML sequences are loaded into Perl arrays. - - a sequence: - - one bourbon - - one scotch - - one beer - - scalar - A scalar is a YAML node that is a single value. By default YAML - scalars are loaded into Perl scalars. - - a scalar key: a scalar value - - YAML has many styles for representing scalars. This is important - because varying data will have varying formatting requirements to - retain the optimum human readability. - - plain scalar - A plain sclar is unquoted. All plain scalars are automatic - candidates for "implicit tagging". This means that their tag may be - determined automatically by examination. The typical uses for this - are plain alpha strings, integers, real numbers, dates, times and - currency. - - - a plain string - - -42 - - 3.1415 - - 12:34 - - 123 this is an error - - single quoted scalar - This is similar to Perl's use of single quotes. It means no escaping - except for single quotes which are escaped by using two adjacent - single quotes. - - - 'When I say ''\n'' I mean "backslash en"' - - double quoted scalar - This is similar to Perl's use of double quotes. Character escaping - can be used. - - - "This scalar\nhas two lines, and a bell -->\a" - - folded scalar - This is a multiline scalar which begins on the next line. It is - indicated by a single right angle bracket. It is unescaped like the - single quoted scalar. Line folding is also performed. - - - > - This is a multiline scalar which begins on - the next line. It is indicated by a single - carat. It is unescaped like the single - quoted scalar. Line folding is also - performed. - - block scalar - This final multiline form is akin to Perl's here-document except - that (as in all YAML data) scope is indicated by indentation. - Therefore, no ending marker is required. The data is verbatim. No - line folding. - - - | - QTY DESC PRICE TOTAL - --- ---- ----- ----- - 1 Foo Fighters $19.95 $19.95 - 2 Bar Belles $29.95 $59.90 - - parser - A YAML processor has four stages: parse, load, dump, emit. - - A parser parses a YAML stream. YAML.pm's Load() function contains a - parser. - - loader - The other half of the Load() function is a loader. This takes the - information from the parser and loads it into a Perl data structure. - - dumper - The Dump() function consists of a dumper and an emitter. The dumper - walks through each Perl data structure and gives info to the - emitter. - - emitter - The emitter takes info from the dumper and turns it into a YAML - stream. - - NOTE: In YAML.pm the parser/loader and the dumper/emitter code are - currently very closely tied together. In the future they may be - broken into separate stages. - - For more information please refer to the immensely helpful YAML - specification available at . - -ysh - The YAML Shell - The YAML distribution ships with a script called 'ysh', the YAML shell. - ysh provides a simple, interactive way to play with YAML. If you type in - Perl code, it displays the result in YAML. If you type in YAML it turns - it into Perl code. - - To run ysh, (assuming you installed it along with YAML.pm) simply type: - - ysh [options] - - Please read the "ysh" documentation for the full details. There are lots - of options. - -BUGS & DEFICIENCIES - If you find a bug in YAML, please try to recreate it in the YAML Shell - with logging turned on ('ysh -L'). When you have successfully reproduced - the bug, please mail the LOG file to the author (ingy@cpan.org). - - WARNING: This is still *ALPHA* code. Well, most of this code has been - around for years... - - BIGGER WARNING: YAML.pm has been slow in the making, but I am committed - to having top notch YAML tools in the Perl world. The YAML team is close - to finalizing the YAML 1.1 spec. This version of YAML.pm is based off of - a very old pre 1.0 spec. In actuality there isn't a ton of difference, - and this YAML.pm is still fairly useful. Things will get much better in - the future. - -RESOURCES - is the mailing - list. This is where the language is discussed and designed. - - is the official YAML website. - - is the YAML 1.0 specification. - - is the official YAML wiki. - -SEE ALSO - See YAML::Syck. Fast! - -AUTHOR - Ingy döt Net - - is resonsible for YAML.pm. - - The YAML serialization language is the result of years of collaboration - between Oren Ben-Kiki, Clark Evans and Ingy döt Net. Several others - have added help along the way. - -COPYRIGHT - Copyright (c) 2005, 2006. Ingy döt Net. All rights reserved. Copyright - (c) 2001, 2002, 2005. Brian Ingerson. All rights reserved. - - This program is free software; you can redistribute it and/or modify it - under the same terms as Perl itself. - - See - diff --git a/modules/YAML/YAML.pm b/modules/YAML/YAML.pm deleted file mode 100644 index 3b6aad55a..000000000 --- a/modules/YAML/YAML.pm +++ /dev/null @@ -1,787 +0,0 @@ -package YAML; -use strict; use warnings; -use YAML::Base; -use base 'YAML::Base'; -use YAML::Node; # XXX This is a temp fix for Module::Build -use 5.006001; -our $VERSION = '0.62'; -our @EXPORT = qw'Dump Load'; -our @EXPORT_OK = qw'freeze thaw DumpFile LoadFile Bless Blessed'; - -# XXX This VALUE nonsense needs to go. -use constant VALUE => "\x07YAML\x07VALUE\x07"; - -# YAML Object Properties -field dumper_class => 'YAML::Dumper'; -field loader_class => 'YAML::Loader'; -field dumper_object => - -init => '$self->init_action_object("dumper")'; -field loader_object => - -init => '$self->init_action_object("loader")'; - -sub Dump { - my $yaml = YAML->new; - $yaml->dumper_class($YAML::DumperClass) - if $YAML::DumperClass; - return $yaml->dumper_object->dump(@_); -} - -sub Load { - my $yaml = YAML->new; - $yaml->loader_class($YAML::LoaderClass) - if $YAML::LoaderClass; - return $yaml->loader_object->load(@_); -} - -{ - no warnings 'once'; - # freeze/thaw is the API for Storable string serialization. Some - # modules make use of serializing packages on if they use freeze/thaw. - *freeze = \ &Dump; - *thaw = \ &Load; -} - -sub DumpFile { - my $OUT; - my $filename = shift; - if (ref $filename eq 'GLOB') { - $OUT = $filename; - } - else { - my $mode = '>'; - if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) { - ($mode, $filename) = ($1, $2); - } - open $OUT, $mode, $filename - or YAML::Base->die('YAML_DUMP_ERR_FILE_OUTPUT', $filename, $!); - } - local $/ = "\n"; # reset special to "sane" - print $OUT Dump(@_); -} - -sub LoadFile { - my $IN; - my $filename = shift; - if (ref $filename eq 'GLOB') { - $IN = $filename; - } - else { - open $IN, $filename - or YAML::Base->die('YAML_LOAD_ERR_FILE_INPUT', $filename, $!); - } - return Load(do { local $/; <$IN> }); -} - -sub init_action_object { - my $self = shift; - my $object_class = (shift) . '_class'; - my $module_name = $self->$object_class; - eval "require $module_name"; - $self->die("Error in require $module_name - $@") - if $@ and "$@" !~ /Can't locate/; - my $object = $self->$object_class->new; - $object->set_global_options; - return $object; -} - -my $global = {}; -sub Bless { - require YAML::Dumper::Base; - YAML::Dumper::Base::bless($global, @_) -} -sub Blessed { - require YAML::Dumper::Base; - YAML::Dumper::Base::blessed($global, @_) -} -sub global_object { $global } - -1; - -__END__ - -=head1 NAME - -YAML - YAML Ain't Markup Language (tm) - -=head1 SYNOPSIS - - use YAML; - - # Load a YAML stream of 3 YAML documents into Perl data structures. - my ($hashref, $arrayref, $string) = Load(<<'...'); - --- - name: ingy - age: old - weight: heavy - # I should comment that I also like pink, but don't tell anybody. - favorite colors: - - red - - green - - blue - --- - - Clark Evans - - Oren Ben-Kiki - - Ingy döt Net - --- > - You probably think YAML stands for "Yet Another Markup Language". It - ain't! YAML is really a data serialization language. But if you want - to think of it as a markup, that's OK with me. A lot of people try - to use XML as a serialization format. - - "YAML" is catchy and fun to say. Try it. "YAML, YAML, YAML!!!" - ... - - # Dump the Perl data structures back into YAML. - print Dump($string, $arrayref, $hashref); - - # YAML::Dump is used the same way you'd use Data::Dumper::Dumper - use Data::Dumper; - print Dumper($string, $arrayref, $hashref); - -=head1 DESCRIPTION - -The YAML.pm module implements a YAML Loader and Dumper based on the YAML -1.0 specification. L - -YAML is a generic data serialization language that is optimized for -human readability. It can be used to express the data structures of most -modern programming languages. (Including Perl!!!) - -For information on the YAML syntax, please refer to the YAML -specification. - -=head1 WHY YAML IS COOL - -=over 4 - -=item YAML is readable for people. - -It makes clear sense out of complex data structures. You should find -that YAML is an exceptional data dumping tool. Structure is shown -through indentation, YAML supports recursive data, and hash keys are -sorted by default. In addition, YAML supports several styles of scalar -formatting for different types of data. - -=item YAML is editable. - -YAML was designed from the ground up to be an excellent syntax for -configuration files. Almost all programs need configuration files, so -why invent a new syntax for each one? And why subject users to the -complexities of XML or native Perl code? - -=item YAML is multilingual. - -Yes, YAML supports Unicode. But I'm actually referring to programming -languages. YAML was designed to meet the serialization needs of Perl, -Python, Ruby, Tcl, PHP, Javascript and Java. It was also designed to be -interoperable between those languages. That means YAML serializations -produced by Perl can be processed by Python. - -=item YAML is taint safe. - -Using modules like Data::Dumper for serialization is fine as long as you -can be sure that nobody can tamper with your data files or -transmissions. That's because you need to use Perl's C built-in -to deserialize the data. Somebody could add a snippet of Perl to erase -your files. - -YAML's parser does not need to eval anything. - -=item YAML is full featured. - -YAML can accurately serialize all of the common Perl data structures and -deserialize them again without losing data relationships. Although it is -not 100% perfect (no serializer is or can be perfect), it fares as well -as the popular current modules: Data::Dumper, Storable, XML::Dumper and -Data::Denter. - -YAML.pm also has the ability to handle code (subroutine) references and -typeglobs. (Still experimental) These features are not found in Perl's -other serialization modules. - -=item YAML is extensible. - -The YAML language has been designed to be flexible enough to solve it's -own problems. The markup itself has 3 basic construct which resemble -Perl's hash, array and scalar. By default, these map to their Perl -equivalents. But each YAML node also supports a tagging mechanism (type -system) which can cause that node to be interpreted in a completely -different manner. That's how YAML can support object serialization and -oddball structures like Perl's typeglob. - -=back - -=head1 YAML IMPLEMENTATIONS IN PERL - -This module, YAML.pm, is really just the interface module for YAML -modules written in Perl. The basic interface for YAML consists of two -functions: C and C. The real work is done by the modules -YAML::Dumper and YAML::Loader. - -Different YAML module distributions can be created by subclassing -YAML.pm and YAML::Loader and YAML::Dumper. For example, YAML-Simple -consists of YAML::Simple YAML::Dumper::Simple and YAML::Loader::Simple. - -Why would there be more than one implementation of YAML? Well, despite -YAML's offering of being a simple data format, YAML is actually very -deep and complex. Implementing the entirety of the YAML specification is -a daunting task. - -For this reason I am currently working on 3 different YAML implementations. - -=over - -=item YAML - -The main YAML distribution will keeping evolving to support the entire -YAML specification in pure Perl. This may not be the fastest or most -stable module though. Currently, YAML.pm has lots of known bugs. It is -mostly a great tool for dumping Perl data structures to a readable form. - -=item YAML::Lite - -The point of YAML::Lite is to strip YAML down to the 90% that people -use most and offer that in a small, fast, stable, pure Perl form. -YAML::Lite will simply die when it is asked to do something it can't. - -=item YAML::Syck - -C is the C based YAML processing library used by the Ruby -programming language (and also Python, PHP and Pugs). YAML::Syck is the -Perl binding to C. It should be very fast, but may have -problems of its own. It will also require C compilation. - -NOTE: Audrey Tang has actually completed this module and it works great - and is 10 times faster than YAML.pm. - -=back - -In the future, there will likely be even more YAML modules. Remember, -people other than Ingy are allowed to write YAML modules! - -=head1 FUNCTIONAL USAGE - -YAML is completely OO under the hood. Still it exports a few useful top -level functions so that it is dead simple to use. These functions just -do the OO stuff for you. If you want direct access to the OO API see the -documentation for YAML::Dumper and YAML::Loader. - -=head2 Exported Functions - -The following functions are exported by YAML.pm by default. The reason -they are exported is so that YAML works much like Data::Dumper. If you -don't want functions to be imported, just use YAML with an empty -import list: - - use YAML (); - -=over 4 - -=item Dump(list-of-Perl-data-structures) - -Turn Perl data into YAML. This function works very much like -Data::Dumper::Dumper(). It takes a list of Perl data strucures and -dumps them into a serialized form. It returns a string containing the -YAML stream. The structures can be references or plain scalars. - -=item Load(string-containing-a-YAML-stream) - -Turn YAML into Perl data. This is the opposite of Dump. Just like -Storable's thaw() function or the eval() function in relation to -Data::Dumper. It parses a string containing a valid YAML stream into a -list of Perl data structures. - -=back - -=head2 Exportable Functions - -These functions are not exported by default but you can request them in -an import list like this: - - use YAML qw'freeze thaw Bless'; - -=over 4 - -=item freeze() and thaw() - -Aliases to Dump() and Load() for Storable fans. This will also allow -YAML.pm to be plugged directly into modules like POE.pm, that use the -freeze/thaw API for internal serialization. - -=item DumpFile(filepath, list) - -Writes the YAML stream to a file instead of just returning a string. - -=item LoadFile(filepath) - -Reads the YAML stream from a file instead of a string. - -=item Bless(perl-node, [yaml-node | class-name]) - -Associate a normal Perl node, with a yaml node. A yaml node is an object -tied to the YAML::Node class. The second argument is either a yaml node -that you've already created or a class (package) name that supports a -yaml_dump() function. A yaml_dump() function should take a perl node and -return a yaml node. If no second argument is provided, Bless will create -a yaml node. This node is not returned, but can be retrieved with the -Blessed() function. - -Here's an example of how to use Bless. Say you have a hash containing -three keys, but you only want to dump two of them. Furthermore the keys -must be dumped in a certain order. Here's how you do that: - - use YAML qw(Dump Bless); - $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; - print Dump $hash; - Bless($hash)->keys(['banana', 'apple']); - print Dump $hash; - -produces: - - --- - apple: good - banana: bad - cauliflower: ugly - --- - banana: bad - apple: good - -Bless returns the tied part of a yaml-node, so that you can call the -YAML::Node methods. This is the same thing that YAML::Node::ynode() -returns. So another way to do the above example is: - - use YAML qw(Dump Bless); - use YAML::Node; - $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; - print Dump $hash; - Bless($hash); - $ynode = ynode(Blessed($hash)); - $ynode->keys(['banana', 'apple']); - print Dump $hash; - -Note that Blessing a Perl data structure does not change it anyway. The -extra information is stored separately and looked up by the Blessed -node's memory address. - -=item Blessed(perl-node) - -Returns the yaml node that a particular perl node is associated with -(see above). Returns undef if the node is not (YAML) Blessed. - -=back - -=head1 GLOBAL OPTIONS - -YAML options are set using a group of global variables in the YAML -namespace. This is similar to how Data::Dumper works. - -For example, to change the indentation width, do something like: - - local $YAML::Indent = 3; - -The current options are: - -=over 4 - -=item DumperClass - -You can override which module/class YAML uses for Dumping data. - -=item LoaderClass - -You can override which module/class YAML uses for Loading data. - -=item Indent - -This is the number of space characters to use for each indentation level -when doing a Dump(). The default is 2. - -By the way, YAML can use any number of characters for indentation at any -level. So if you are editing YAML by hand feel free to do it anyway that -looks pleasing to you; just be consistent for a given level. - -=item SortKeys - -Default is 1. (true) - -Tells YAML.pm whether or not to sort hash keys when storing a document. - -YAML::Node objects can have their own sort order, which is usually what -you want. To override the YAML::Node order and sort the keys anyway, set -SortKeys to 2. - -=item Stringify - -Default is 0. (false) - -Objects with string overloading should honor the overloading and dump the -stringification of themselves, rather than the actual object's guts. - -=item UseHeader - -Default is 1. (true) - -This tells YAML.pm whether to use a separator string for a Dump -operation. This only applies to the first document in a stream. -Subsequent documents must have a YAML header by definition. - -=item UseVersion - -Default is 0. (false) - -Tells YAML.pm whether to include the YAML version on the -separator/header. - - --- %YAML:1.0 - -=item AnchorPrefix - -Default is ''. - -Anchor names are normally numeric. YAML.pm simply starts with '1' and -increases by one for each new anchor. This option allows you to specify a -string to be prepended to each anchor number. - -=item UseCode - -Setting the UseCode option is a shortcut to set both the DumpCode and -LoadCode options at once. Setting UseCode to '1' tells YAML.pm to dump -Perl code references as Perl (using B::Deparse) and to load them back -into memory using eval(). The reason this has to be an option is that -using eval() to parse untrusted code is, well, untrustworthy. - -=item DumpCode - -Determines if and how YAML.pm should serialize Perl code references. By -default YAML.pm will dump code references as dummy placeholders (much -like Data::Dumper). If DumpCode is set to '1' or 'deparse', code -references will be dumped as actual Perl code. - -DumpCode can also be set to a subroutine reference so that you can -write your own serializing routine. YAML.pm passes you the code ref. You -pass back the serialization (as a string) and a format indicator. The -format indicator is a simple string like: 'deparse' or 'bytecode'. - -=item LoadCode - -LoadCode is the opposite of DumpCode. It tells YAML if and how to -deserialize code references. When set to '1' or 'deparse' it will use -C. Since this is potentially risky, only use this option if you -know where your YAML has been. - -LoadCode can also be set to a subroutine reference so that you can write -your own deserializing routine. YAML.pm passes the serialization (as a -string) and a format indicator. You pass back the code reference. - -=item UseBlock - -YAML.pm uses heuristics to guess which scalar style is best for a given -node. Sometimes you'll want all multiline scalars to use the 'block' -style. If so, set this option to 1. - -NOTE: YAML's block style is akin to Perl's here-document. - -=item UseFold - -If you want to force YAML to use the 'folded' style for all multiline -scalars, then set $UseFold to 1. - -NOTE: YAML's folded style is akin to the way HTML folds text, - except smarter. - -=item UseAliases - -YAML has an alias mechanism such that any given structure in memory gets -serialized once. Any other references to that structure are serialized -only as alias markers. This is how YAML can serialize duplicate and -recursive structures. - -Sometimes, when you KNOW that your data is nonrecursive in nature, you -may want to serialize such that every node is expressed in full. (ie as -a copy of the original). Setting $YAML::UseAliases to 0 will allow you -to do this. This also may result in faster processing because the lookup -overhead is by bypassed. - -THIS OPTION CAN BE DANGEROUS. *If* your data is recursive, this option -*will* cause Dump() to run in an endless loop, chewing up your computers -memory. You have been warned. - -=item CompressSeries - -Default is 1. - -Compresses the formatting of arrays of hashes: - - - - foo: bar - - - bar: foo - -becomes: - - - foo: bar - - bar: foo - -Since this output is usually more desirable, this option is turned on by -default. - -=back - -=head1 YAML TERMINOLOGY - -YAML is a full featured data serialization language, and thus has its -own terminology. - -It is important to remember that although YAML is heavily influenced by -Perl and Python, it is a language in its own right, not merely just a -representation of Perl structures. - -YAML has three constructs that are conspicuously similar to Perl's hash, -array, and scalar. They are called mapping, sequence, and string -respectively. By default, they do what you would expect. But each -instance may have an explicit or implicit tag (type) that makes it -behave differently. In this manner, YAML can be extended to represent -Perl's Glob or Python's tuple, or Ruby's Bigint. - -=over 4 - -=item stream - -A YAML stream is the full sequence of unicode characters that a YAML -parser would read or a YAML emitter would write. A stream may contain -one or more YAML documents separated by YAML headers. - - --- - a: mapping - foo: bar - --- - - a - - sequence - -=item document - -A YAML document is an independent data structure representation within a -stream. It is a top level node. Each document in a YAML stream must -begin with a YAML header line. Actually the header is optional on the -first document. - - --- - This: top level mapping - is: - - a - - YAML - - document - -=item header - -A YAML header is a line that begins a YAML document. It consists of -three dashes, possibly followed by more info. Another purpose of the -header line is that it serves as a place to put top level tag and anchor -information. - - --- !recursive-sequence &001 - - * 001 - - * 001 - -=item node - -A YAML node is the representation of a particular data stucture. Nodes -may contain other nodes. (In Perl terms, nodes are like scalars. -Strings, arrayrefs and hashrefs. But this refers to the serialized -format, not the in-memory structure.) - -=item tag - -This is similar to a type. It indicates how a particular YAML node -serialization should be transferred into or out of memory. For instance -a Foo::Bar object would use the tag 'perl/Foo::Bar': - - - !perl/Foo::Bar - foo: 42 - bar: stool - -=item collection - -A collection is the generic term for a YAML data grouping. YAML has two -types of collections: mappings and sequences. (Similar to hashes and arrays) - -=item mapping - -A mapping is a YAML collection defined by unordered key/value pairs with -unique keys. By default YAML mappings are loaded into Perl hashes. - - a mapping: - foo: bar - two: times two is 4 - -=item sequence - -A sequence is a YAML collection defined by an ordered list of elements. By -default YAML sequences are loaded into Perl arrays. - - a sequence: - - one bourbon - - one scotch - - one beer - -=item scalar - -A scalar is a YAML node that is a single value. By default YAML scalars -are loaded into Perl scalars. - - a scalar key: a scalar value - -YAML has many styles for representing scalars. This is important because -varying data will have varying formatting requirements to retain the -optimum human readability. - -=item plain scalar - -A plain sclar is unquoted. All plain scalars are automatic candidates -for "implicit tagging". This means that their tag may be determined -automatically by examination. The typical uses for this are plain alpha -strings, integers, real numbers, dates, times and currency. - - - a plain string - - -42 - - 3.1415 - - 12:34 - - 123 this is an error - -=item single quoted scalar - -This is similar to Perl's use of single quotes. It means no escaping -except for single quotes which are escaped by using two adjacent -single quotes. - - - 'When I say ''\n'' I mean "backslash en"' - -=item double quoted scalar - -This is similar to Perl's use of double quotes. Character escaping can -be used. - - - "This scalar\nhas two lines, and a bell -->\a" - -=item folded scalar - -This is a multiline scalar which begins on the next line. It is -indicated by a single right angle bracket. It is unescaped like the -single quoted scalar. Line folding is also performed. - - - > - This is a multiline scalar which begins on - the next line. It is indicated by a single - carat. It is unescaped like the single - quoted scalar. Line folding is also - performed. - -=item block scalar - -This final multiline form is akin to Perl's here-document except that -(as in all YAML data) scope is indicated by indentation. Therefore, no -ending marker is required. The data is verbatim. No line folding. - - - | - QTY DESC PRICE TOTAL - --- ---- ----- ----- - 1 Foo Fighters $19.95 $19.95 - 2 Bar Belles $29.95 $59.90 - -=item parser - -A YAML processor has four stages: parse, load, dump, emit. - -A parser parses a YAML stream. YAML.pm's Load() function contains a -parser. - -=item loader - -The other half of the Load() function is a loader. This takes the -information from the parser and loads it into a Perl data structure. - -=item dumper - -The Dump() function consists of a dumper and an emitter. The dumper -walks through each Perl data structure and gives info to the emitter. - -=item emitter - -The emitter takes info from the dumper and turns it into a YAML stream. - -NOTE: -In YAML.pm the parser/loader and the dumper/emitter code are currently -very closely tied together. In the future they may be broken into -separate stages. - -=back - -For more information please refer to the immensely helpful YAML -specification available at L. - -=head1 ysh - The YAML Shell - -The YAML distribution ships with a script called 'ysh', the YAML shell. -ysh provides a simple, interactive way to play with YAML. If you type in -Perl code, it displays the result in YAML. If you type in YAML it turns -it into Perl code. - -To run ysh, (assuming you installed it along with YAML.pm) simply type: - - ysh [options] - -Please read the C documentation for the full details. There are -lots of options. - -=head1 BUGS & DEFICIENCIES - -If you find a bug in YAML, please try to recreate it in the YAML Shell -with logging turned on ('ysh -L'). When you have successfully reproduced -the bug, please mail the LOG file to the author (ingy@cpan.org). - -WARNING: This is still *ALPHA* code. Well, most of this code has been -around for years... - -BIGGER WARNING: YAML.pm has been slow in the making, but I am committed -to having top notch YAML tools in the Perl world. The YAML team is close -to finalizing the YAML 1.1 spec. This version of YAML.pm is based off of -a very old pre 1.0 spec. In actuality there isn't a ton of difference, -and this YAML.pm is still fairly useful. Things will get much better in -the future. - -=head1 RESOURCES - -L is the mailing -list. This is where the language is discussed and designed. - -L is the official YAML website. - -L is the YAML 1.0 specification. - -L is the official YAML wiki. - -=head1 SEE ALSO - -See YAML::Syck. Fast! - -=head1 AUTHOR - -Ingy döt Net - -is resonsible for YAML.pm. - -The YAML serialization language is the result of years of collaboration -between Oren Ben-Kiki, Clark Evans and Ingy döt Net. Several others -have added help along the way. - -=head1 COPYRIGHT - -Copyright (c) 2005, 2006. Ingy döt Net. All rights reserved. -Copyright (c) 2001, 2002, 2005. Brian Ingerson. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/YAML/YAML/Base.pm b/modules/YAML/YAML/Base.pm deleted file mode 100644 index f97f28660..000000000 --- a/modules/YAML/YAML/Base.pm +++ /dev/null @@ -1,200 +0,0 @@ -package YAML::Base; -use strict; use warnings; -use base 'Exporter'; - -our @EXPORT = qw(field XXX); - -sub new { - my $class = shift; - $class = ref($class) || $class; - my $self = bless {}, $class; - while (@_) { - my $method = shift; - $self->$method(shift); - } - return $self; -} - -# Use lexical subs to reduce pollution of private methods by base class. -my ($_new_error, $_info, $_scalar_info, $parse_arguments, $default_as_code); - -sub XXX { - require Data::Dumper; - CORE::die(Data::Dumper::Dumper(@_)); -} - -my %code = ( - sub_start => - "sub {\n", - set_default => - " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", - init => - " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . - " unless \$#_ > 0 or defined \$_[0]->{%s};\n", - return_if_get => - " return \$_[0]->{%s} unless \$#_ > 0;\n", - set => - " \$_[0]->{%s} = \$_[1];\n", - sub_end => - " return \$_[0]->{%s};\n}\n", -); - -sub field { - my $package = caller; - my ($args, @values) = &$parse_arguments( - [ qw(-package -init) ], - @_, - ); - my ($field, $default) = @values; - $package = $args->{-package} if defined $args->{-package}; - return if defined &{"${package}::$field"}; - my $default_string = - ( ref($default) eq 'ARRAY' and not @$default ) - ? '[]' - : (ref($default) eq 'HASH' and not keys %$default ) - ? '{}' - : &$default_as_code($default); - - my $code = $code{sub_start}; - if ($args->{-init}) { - my $fragment = $code{init}; - $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4; - } - $code .= sprintf $code{set_default}, $field, $default_string, $field - if defined $default; - $code .= sprintf $code{return_if_get}, $field; - $code .= sprintf $code{set}, $field; - $code .= sprintf $code{sub_end}, $field; - - my $sub = eval $code; - die $@ if $@; - no strict 'refs'; - *{"${package}::$field"} = $sub; - return $code if defined wantarray; -} - -sub die { - my $self = shift; - my $error = $self->$_new_error(@_); - $error->type('Error'); - Carp::croak($error->format_message); -} - -sub warn { - my $self = shift; - return unless $^W; - my $error = $self->$_new_error(@_); - $error->type('Warning'); - Carp::cluck($error->format_message); -} - -# This code needs to be refactored to be simpler and more precise, and no, -# Scalar::Util doesn't DWIM. -# -# Can't handle: -# * blessed regexp -sub node_info { - my $self = shift; - my $stringify = $_[1] || 0; - my ($class, $type, $id) = - ref($_[0]) - ? $stringify - ? &$_info("$_[0]") - : do { - require overload; - my @info = &$_info(overload::StrVal($_[0])); - if (ref($_[0]) eq 'Regexp') { - @info[0, 1] = (undef, 'REGEXP'); - } - @info; - } - : &$_scalar_info($_[0]); - ($class, $type, $id) = &$_scalar_info("$_[0]") - unless $id; - return wantarray ? ($class, $type, $id) : $id; -} - -#------------------------------------------------------------------------------- -$_info = sub { - return (($_[0]) =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o); -}; - -$_scalar_info = sub { - my $id = 'undef'; - if (defined $_[0]) { - \$_[0] =~ /\((\w+)\)$/o or CORE::die(); - $id = "$1-S"; - } - return (undef, undef, $id); -}; - -$_new_error = sub { - require Carp; - my $self = shift; - require YAML::Error; - - my $code = shift || 'unknown error'; - my $error = YAML::Error->new(code => $code); - $error->line($self->line) if $self->can('line'); - $error->document($self->document) if $self->can('document'); - $error->arguments([@_]); - return $error; -}; - -$parse_arguments = sub { - my $paired_arguments = shift || []; - my ($args, @values) = ({}, ()); - my %pairs = map { ($_, 1) } @$paired_arguments; - while (@_) { - my $elem = shift; - if (defined $elem and defined $pairs{$elem} and @_) { - $args->{$elem} = shift; - } - else { - push @values, $elem; - } - } - return wantarray ? ($args, @values) : $args; -}; - -$default_as_code = sub { - no warnings 'once'; - require Data::Dumper; - local $Data::Dumper::Sortkeys = 1; - my $code = Data::Dumper::Dumper(shift); - $code =~ s/^\$VAR1 = //; - $code =~ s/;$//; - return $code; -}; - -1; - -__END__ - -=head1 NAME - -YAML::Base - Base class for YAML classes - -=head1 SYNOPSIS - - package YAML::Something; - use YAML::Base -base; - -=head1 DESCRIPTION - -YAML::Base is the parent of all YAML classes. - -=head1 AUTHOR - -Ingy döt Net - -=head1 COPYRIGHT - -Copyright (c) 2006. Ingy döt Net. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/YAML/YAML/Dumper.pm b/modules/YAML/YAML/Dumper.pm deleted file mode 100644 index 5521f8c33..000000000 --- a/modules/YAML/YAML/Dumper.pm +++ /dev/null @@ -1,584 +0,0 @@ -package YAML::Dumper; -use strict; use warnings; -use YAML::Base; -use base 'YAML::Dumper::Base'; - -use YAML::Node; -use YAML::Types; - -# Context constants -use constant KEY => 3; -use constant BLESSED => 4; -use constant FROMARRAY => 5; -use constant VALUE => "\x07YAML\x07VALUE\x07"; - -# Common YAML character sets -my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]'; -my $LIT_CHAR = '|'; - -#============================================================================== -# OO version of Dump. YAML->new->dump($foo); -sub dump { - my $self = shift; - $self->stream(''); - $self->document(0); - for my $document (@_) { - $self->{document}++; - $self->transferred({}); - $self->id_refcnt({}); - $self->id_anchor({}); - $self->anchor(1); - $self->level(0); - $self->offset->[0] = 0 - $self->indent_width; - $self->_prewalk($document); - $self->_emit_header($document); - $self->_emit_node($document); - } - return $self->stream; -} - -# Every YAML document in the stream must begin with a YAML header, unless -# there is only a single document and the user requests "no header". -sub _emit_header { - my $self = shift; - my ($node) = @_; - if (not $self->use_header and - $self->document == 1 - ) { - $self->die('YAML_DUMP_ERR_NO_HEADER') - unless ref($node) =~ /^(HASH|ARRAY)$/; - $self->die('YAML_DUMP_ERR_NO_HEADER') - if ref($node) eq 'HASH' and keys(%$node) == 0; - $self->die('YAML_DUMP_ERR_NO_HEADER') - if ref($node) eq 'ARRAY' and @$node == 0; - # XXX Also croak if aliased, blessed, or ynode - $self->headless(1); - return; - } - $self->{stream} .= '---'; -# XXX Consider switching to 1.1 style - if ($self->use_version) { -# $self->{stream} .= " #YAML:1.0"; - } -} - -# Walk the tree to be dumped and keep track of its reference counts. -# This function is where the Dumper does all its work. All type -# transfers happen here. -sub _prewalk { - my $self = shift; - my $stringify = $self->stringify; - my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify); - - # Handle typeglobs - if ($type eq 'GLOB') { - $self->transferred->{$node_id} = - YAML::Type::glob->yaml_dump($_[0]); - $self->_prewalk($self->transferred->{$node_id}); - return; - } - - # Handle regexps - if (ref($_[0]) eq 'Regexp') { - $self->transferred->{$node_id} = - YAML::Type::regexp->yaml_dump($_[0], $class, $self); - return; - } - - # Handle Purity for scalars. - # XXX can't find a use case yet. Might be YAGNI. - if (not ref $_[0]) { - $self->{id_refcnt}{$node_id}++ if $self->purity; - return; - } - - # Make a copy of original - my $value = $_[0]; - ($class, $type, $node_id) = $self->node_info($value, $stringify); - - # Must be a stringified object. - return if (ref($value) and not $type); - - # Look for things already transferred. - if ($self->transferred->{$node_id}) { - (undef, undef, $node_id) = (ref $self->transferred->{$node_id}) - ? $self->node_info($self->transferred->{$node_id}, $stringify) - : $self->node_info(\ $self->transferred->{$node_id}, $stringify); - $self->{id_refcnt}{$node_id}++; - return; - } - - # Handle code refs - if ($type eq 'CODE') { - $self->transferred->{$node_id} = 'placeholder'; - YAML::Type::code->yaml_dump( - $self->dump_code, - $_[0], - $self->transferred->{$node_id} - ); - ($class, $type, $node_id) = - $self->node_info(\ $self->transferred->{$node_id}, $stringify); - $self->{id_refcnt}{$node_id}++; - return; - } - - # Handle blessed things - if (defined $class) { - if ($value->can('yaml_dump')) { - $value = $value->yaml_dump; - } - elsif ($type eq 'SCALAR') { - $self->transferred->{$node_id} = 'placeholder'; - YAML::Type::blessed->yaml_dump - ($_[0], $self->transferred->{$node_id}); - ($class, $type, $node_id) = - $self->node_info(\ $self->transferred->{$node_id}, $stringify); - $self->{id_refcnt}{$node_id}++; - return; - } - else { - $value = YAML::Type::blessed->yaml_dump($value); - } - $self->transferred->{$node_id} = $value; - (undef, $type, $node_id) = $self->node_info($value, $stringify); - } - - # Handle YAML Blessed things - if (defined YAML->global_object()->{blessed_map}{$node_id}) { - $value = YAML->global_object()->{blessed_map}{$node_id}; - $self->transferred->{$node_id} = $value; - ($class, $type, $node_id) = $self->node_info($value, $stringify); - $self->_prewalk($value); - return; - } - - # Handle hard refs - if ($type eq 'REF' or $type eq 'SCALAR') { - $value = YAML::Type::ref->yaml_dump($value); - $self->transferred->{$node_id} = $value; - (undef, $type, $node_id) = $self->node_info($value, $stringify); - } - - # Handle ref-to-glob's - elsif ($type eq 'GLOB') { - my $ref_ynode = $self->transferred->{$node_id} = - YAML::Type::ref->yaml_dump($value); - - my $glob_ynode = $ref_ynode->{&VALUE} = - YAML::Type::glob->yaml_dump($$value); - - (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify); - $self->transferred->{$node_id} = $glob_ynode; - $self->_prewalk($glob_ynode); - return; - } - - # Increment ref count for node - return if ++($self->{id_refcnt}{$node_id}) > 1; - - # Keep on walking - if ($type eq 'HASH') { - $self->_prewalk($value->{$_}) - for keys %{$value}; - return; - } - elsif ($type eq 'ARRAY') { - $self->_prewalk($_) - for @{$value}; - return; - } - - # Unknown type. Need to know about it. - $self->warn(<<"..."); -YAML::Dumper can't handle dumping this type of data. -Please report this to the author. - -id: $node_id -type: $type -class: $class -value: $value - -... - - return; -} - -# Every data element and sub data element is a node. -# Everything emitted goes through this function. -sub _emit_node { - my $self = shift; - my ($type, $node_id); - my $ref = ref($_[0]); - if ($ref and $ref ne 'Regexp') { - (undef, $type, $node_id) = $self->node_info($_[0], $self->stringify); - } - else { - $type = $ref || 'SCALAR'; - (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify); - } - - my ($ynode, $tag) = ('') x 2; - my ($value, $context) = (@_, 0); - - if (defined $self->transferred->{$node_id}) { - $value = $self->transferred->{$node_id}; - $ynode = ynode($value); - if (ref $value) { - $tag = defined $ynode ? $ynode->tag->short : ''; - (undef, $type, $node_id) = - $self->node_info($value, $self->stringify); - } - else { - $ynode = ynode($self->transferred->{$node_id}); - $tag = defined $ynode ? $ynode->tag->short : ''; - $type = 'SCALAR'; - (undef, undef, $node_id) = - $self->node_info( - \ $self->transferred->{$node_id}, - $self->stringify - ); - } - } - elsif ($ynode = ynode($value)) { - $tag = $ynode->tag->short; - } - - if ($self->use_aliases) { - $self->{id_refcnt}{$node_id} ||= 0; - if ($self->{id_refcnt}{$node_id} > 1) { - if (defined $self->{id_anchor}{$node_id}) { - $self->{stream} .= ' *' . $self->{id_anchor}{$node_id} . "\n"; - return; - } - my $anchor = $self->anchor_prefix . $self->{anchor}++; - $self->{stream} .= ' &' . $anchor; - $self->{id_anchor}{$node_id} = $anchor; - } - } - - return $self->_emit_str("$value") # Stringified object - if ref($value) and not $type; - return $self->_emit_scalar($value, $tag) - if $type eq 'SCALAR' and $tag; - return $self->_emit_str($value) - if $type eq 'SCALAR'; - return $self->_emit_mapping($value, $tag, $node_id, $context) - if $type eq 'HASH'; - return $self->_emit_sequence($value, $tag) - if $type eq 'ARRAY'; - $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type); - return $self->_emit_str("$value"); -} - -# A YAML mapping is akin to a Perl hash. -sub _emit_mapping { - my $self = shift; - my ($value, $tag, $node_id, $context) = @_; - $self->{stream} .= " !$tag" if $tag; - - # Sometimes 'keys' fails. Like on a bad tie implementation. - my $empty_hash = not(eval {keys %$value}); - $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@; - return ($self->{stream} .= " {}\n") if $empty_hash; - - # If CompressSeries is on (default) and legal is this context, then - # use it and make the indent level be 2 for this node. - if ($context == FROMARRAY and - $self->compress_series and - not (defined $self->{id_anchor}{$node_id} or $tag or $empty_hash) - ) { - $self->{stream} .= ' '; - $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2; - } - else { - $context = 0; - $self->{stream} .= "\n" - unless $self->headless && not($self->headless(0)); - $self->offset->[$self->level+1] = - $self->offset->[$self->level] + $self->indent_width; - } - - $self->{level}++; - my @keys; - if ($self->sort_keys == 1) { - if (ynode($value)) { - @keys = keys %$value; - } - else { - @keys = sort keys %$value; - } - } - elsif ($self->sort_keys == 2) { - @keys = sort keys %$value; - } - # XXX This is hackish but sometimes handy. Not sure whether to leave it in. - elsif (ref($self->sort_keys) eq 'ARRAY') { - my $i = 1; - my %order = map { ($_, $i++) } @{$self->sort_keys}; - @keys = sort { - (defined $order{$a} and defined $order{$b}) - ? ($order{$a} <=> $order{$b}) - : ($a cmp $b); - } keys %$value; - } - else { - @keys = keys %$value; - } - # Force the YAML::VALUE ('=') key to sort last. - if (exists $value->{&VALUE}) { - for (my $i = 0; $i < @keys; $i++) { - if ($keys[$i] eq &VALUE) { - splice(@keys, $i, 1); - push @keys, &VALUE; - last; - } - } - } - - for my $key (@keys) { - $self->_emit_key($key, $context); - $context = 0; - $self->{stream} .= ':'; - $self->_emit_node($value->{$key}); - } - $self->{level}--; -} - -# A YAML series is akin to a Perl array. -sub _emit_sequence { - my $self = shift; - my ($value, $tag) = @_; - $self->{stream} .= " !$tag" if $tag; - - return ($self->{stream} .= " []\n") if @$value == 0; - - $self->{stream} .= "\n" - unless $self->headless && not($self->headless(0)); - - # XXX Really crufty feature. Better implemented by ynodes. - if ($self->inline_series and - @$value <= $self->inline_series and - not (scalar grep {ref or /\n/} @$value) - ) { - $self->{stream} =~ s/\n\Z/ /; - $self->{stream} .= '['; - for (my $i = 0; $i < @$value; $i++) { - $self->_emit_str($value->[$i], KEY); - last if $i == $#{$value}; - $self->{stream} .= ', '; - } - $self->{stream} .= "]\n"; - return; - } - - $self->offset->[$self->level + 1] = - $self->offset->[$self->level] + $self->indent_width; - $self->{level}++; - for my $val (@$value) { - $self->{stream} .= ' ' x $self->offset->[$self->level]; - $self->{stream} .= '-'; - $self->_emit_node($val, FROMARRAY); - } - $self->{level}--; -} - -# Emit a mapping key -sub _emit_key { - my $self = shift; - my ($value, $context) = @_; - $self->{stream} .= ' ' x $self->offset->[$self->level] - unless $context == FROMARRAY; - $self->_emit_str($value, KEY); -} - -# Emit a blessed SCALAR -sub _emit_scalar { - my $self = shift; - my ($value, $tag) = @_; - $self->{stream} .= " !$tag"; - $self->_emit_str($value, BLESSED); -} - -sub _emit { - my $self = shift; - $self->{stream} .= join '', @_; -} - -# Emit a string value. YAML has many scalar styles. This routine attempts to -# guess the best style for the text. -sub _emit_str { - my $self = shift; - my $type = $_[1] || 0; - - # Use heuristics to find the best scalar emission style. - $self->offset->[$self->level + 1] = - $self->offset->[$self->level] + $self->indent_width; - $self->{level}++; - - my $sf = $type == KEY ? '' : ' '; - my $sb = $type == KEY ? '? ' : ' '; - my $ef = $type == KEY ? '' : "\n"; - my $eb = "\n"; - - while (1) { - $self->_emit($sf), - $self->_emit_plain($_[0]), - $self->_emit($ef), last - if not defined $_[0]; - $self->_emit($sf, '=', $ef), last - if $_[0] eq VALUE; - $self->_emit($sf), - $self->_emit_double($_[0]), - $self->_emit($ef), last - if $_[0] =~ /$ESCAPE_CHAR/; - if ($_[0] =~ /\n/) { - $self->_emit($sb), - $self->_emit_block($LIT_CHAR, $_[0]), - $self->_emit($eb), last - if $self->use_block; - Carp::cluck "[YAML] \$UseFold is no longer supported" - if $self->use_fold; - $self->_emit($sf), - $self->_emit_double($_[0]), - $self->_emit($ef), last - if length $_[0] <= 30; - $self->_emit($sf), - $self->_emit_double($_[0]), - $self->_emit($ef), last - if $_[0] !~ /\n\s*\S/; - $self->_emit($sb), - $self->_emit_block($LIT_CHAR, $_[0]), - $self->_emit($eb), last; - } - $self->_emit($sf), - $self->_emit_plain($_[0]), - $self->_emit($ef), last - if $self->is_valid_plain($_[0]); - $self->_emit($sf), - $self->_emit_double($_[0]), - $self->_emit($ef), last - if $_[0] =~ /'/; - $self->_emit($sf), - $self->_emit_single($_[0]), - $self->_emit($ef); - last; - } - - $self->{level}--; - - return; -} - -# Check whether or not a scalar should be emitted as an plain scalar. -sub is_valid_plain { - my $self = shift; - return 0 unless length $_[0]; - # refer to YAML::Loader::parse_inline_simple() - return 0 if $_[0] =~ /^[\s\{\[\~\`\'\"\!\@\#\>\|\%\&\?\*\^]/; - return 0 if $_[0] =~ /[\{\[\]\},]/; - return 0 if $_[0] =~ /[:\-\?]\s/; - return 0 if $_[0] =~ /\s#/; - return 0 if $_[0] =~ /\:(\s|$)/; - return 0 if $_[0] =~ /[\s\|\>]$/; - return 1; -} - -sub _emit_block { - my $self = shift; - my ($indicator, $value) = @_; - $self->{stream} .= $indicator; - $value =~ /(\n*)\Z/; - my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-'; - $value = '~' if not defined $value; - $self->{stream} .= $chomp; - $self->{stream} .= $self->indent_width if $value =~ /^\s/; - $self->{stream} .= $self->indent($value); -} - -# Plain means that the scalar is unquoted. -sub _emit_plain { - my $self = shift; - $self->{stream} .= defined $_[0] ? $_[0] : '~'; -} - -# Double quoting is for single lined escaped strings. -sub _emit_double { - my $self = shift; - (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g; - $self->{stream} .= qq{"$escaped"}; -} - -# Single quoting is for single lined unescaped strings. -sub _emit_single { - my $self = shift; - my $item = shift; - $item =~ s{'}{''}g; - $self->{stream} .= "'$item'"; -} - -#============================================================================== -# Utility subroutines. -#============================================================================== - -# Indent a scalar to the current indentation level. -sub indent { - my $self = shift; - my ($text) = @_; - return $text unless length $text; - $text =~ s/\n\Z//; - my $indent = ' ' x $self->offset->[$self->level]; - $text =~ s/^/$indent/gm; - $text = "\n$text"; - return $text; -} - -# Escapes for unprintable characters -my @escapes = qw(\z \x01 \x02 \x03 \x04 \x05 \x06 \a - \x08 \t \n \v \f \r \x0e \x0f - \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17 - \x18 \x19 \x1a \e \x1c \x1d \x1e \x1f - ); - -# Escape the unprintable characters -sub escape { - my $self = shift; - my ($text) = @_; - $text =~ s/\\/\\\\/g; - $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge; - return $text; -} - -1; - -__END__ - -=head1 NAME - -YAML::Dumper - YAML class for dumping Perl objects to YAML - -=head1 SYNOPSIS - - use YAML::Dumper; - my $dumper = YAML::Dumper->new; - $dumper->indent_width(4); - print $dumper->dump({foo => 'bar'}); - -=head1 DESCRIPTION - -YAML::Dumper is the module that YAML.pm used to serialize Perl objects to -YAML. It is fully object oriented and usable on its own. - -=head1 AUTHOR - -Ingy döt Net - -=head1 COPYRIGHT - -Copyright (c) 2006. Ingy döt Net. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/YAML/YAML/Dumper/Base.pm b/modules/YAML/YAML/Dumper/Base.pm deleted file mode 100644 index 8e4de0c87..000000000 --- a/modules/YAML/YAML/Dumper/Base.pm +++ /dev/null @@ -1,137 +0,0 @@ -package YAML::Dumper::Base; -use strict; use warnings; -use YAML::Base; use base 'YAML::Base'; -use YAML::Node; - -# YAML Dumping options -field spec_version => '1.0'; -field indent_width => 2; -field use_header => 1; -field use_version => 0; -field sort_keys => 1; -field anchor_prefix => ''; -field dump_code => 0; -field use_block => 0; -field use_fold => 0; -field compress_series => 1; -field inline_series => 0; -field use_aliases => 1; -field purity => 0; -field stringify => 0; - -# Properties -field stream => ''; -field document => 0; -field transferred => {}; -field id_refcnt => {}; -field id_anchor => {}; -field anchor => 1; -field level => 0; -field offset => []; -field headless => 0; -field blessed_map => {}; - -# Global Options are an idea taken from Data::Dumper. Really they are just -# sugar on top of real OO properties. They make the simple Dump/Load API -# easy to configure. -sub set_global_options { - my $self = shift; - $self->spec_version($YAML::SpecVersion) - if defined $YAML::SpecVersion; - $self->indent_width($YAML::Indent) - if defined $YAML::Indent; - $self->use_header($YAML::UseHeader) - if defined $YAML::UseHeader; - $self->use_version($YAML::UseVersion) - if defined $YAML::UseVersion; - $self->sort_keys($YAML::SortKeys) - if defined $YAML::SortKeys; - $self->anchor_prefix($YAML::AnchorPrefix) - if defined $YAML::AnchorPrefix; - $self->dump_code($YAML::DumpCode || $YAML::UseCode) - if defined $YAML::DumpCode or defined $YAML::UseCode; - $self->use_block($YAML::UseBlock) - if defined $YAML::UseBlock; - $self->use_fold($YAML::UseFold) - if defined $YAML::UseFold; - $self->compress_series($YAML::CompressSeries) - if defined $YAML::CompressSeries; - $self->inline_series($YAML::InlineSeries) - if defined $YAML::InlineSeries; - $self->use_aliases($YAML::UseAliases) - if defined $YAML::UseAliases; - $self->purity($YAML::Purity) - if defined $YAML::Purity; - $self->stringify($YAML::Stringify) - if defined $YAML::Stringify; -} - -sub dump { - my $self = shift; - $self->die('dump() not implemented in this class.'); -} - -sub blessed { - my $self = shift; - my ($ref) = @_; - $ref = \$_[0] unless ref $ref; - my (undef, undef, $node_id) = YAML::Base->node_info($ref); - $self->{blessed_map}->{$node_id}; -} - -sub bless { - my $self = shift; - my ($ref, $blessing) = @_; - my $ynode; - $ref = \$_[0] unless ref $ref; - my (undef, undef, $node_id) = YAML::Base->node_info($ref); - if (not defined $blessing) { - $ynode = YAML::Node->new($ref); - } - elsif (ref $blessing) { - $self->die() unless ynode($blessing); - $ynode = $blessing; - } - else { - no strict 'refs'; - my $transfer = $blessing . "::yaml_dump"; - $self->die() unless defined &{$transfer}; - $ynode = &{$transfer}($ref); - $self->die() unless ynode($ynode); - } - $self->{blessed_map}->{$node_id} = $ynode; - my $object = ynode($ynode) or $self->die(); - return $object; -} - -1; - -__END__ - -=head1 NAME - -YAML::Dumper::Base - Base class for YAML Dumper classes - -=head1 SYNOPSIS - - package YAML::Dumper::Something; - use YAML::Dumper::Base -base; - -=head1 DESCRIPTION - -YAML::Dumper::Base is a base class for creating YAML dumper classes. - -=head1 AUTHOR - -Ingy döt Net - -=head1 COPYRIGHT - -Copyright (c) 2006. Ingy döt Net. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/YAML/YAML/Error.pm b/modules/YAML/YAML/Error.pm deleted file mode 100644 index 23b9c5ca5..000000000 --- a/modules/YAML/YAML/Error.pm +++ /dev/null @@ -1,220 +0,0 @@ -package YAML::Error; -use strict; use warnings; -use YAML::Base; use base 'YAML::Base'; - -field 'code'; -field 'type' => 'Error'; -field 'line'; -field 'document'; -field 'arguments' => []; - -my ($error_messages, %line_adjust); - -sub format_message { - my $self = shift; - my $output = 'YAML ' . $self->type . ': '; - my $code = $self->code; - if ($error_messages->{$code}) { - $code = sprintf($error_messages->{$code}, @{$self->arguments}); - } - $output .= $code . "\n"; - - $output .= ' Code: ' . $self->code . "\n" - if defined $self->code; - $output .= ' Line: ' . $self->line . "\n" - if defined $self->line; - $output .= ' Document: ' . $self->document . "\n" - if defined $self->document; - return $output; -} - -sub error_messages { - $error_messages; -} - -%$error_messages = map {s/^\s+//;$_} split "\n", <<'...'; -YAML_PARSE_ERR_BAD_CHARS - Invalid characters in stream. This parser only supports printable ASCII -YAML_PARSE_ERR_NO_FINAL_NEWLINE - Stream does not end with newline character -YAML_PARSE_ERR_BAD_MAJOR_VERSION - Can't parse a %s document with a 1.0 parser -YAML_PARSE_WARN_BAD_MINOR_VERSION - Parsing a %s document with a 1.0 parser -YAML_PARSE_WARN_MULTIPLE_DIRECTIVES - '%s directive used more than once' -YAML_PARSE_ERR_TEXT_AFTER_INDICATOR - No text allowed after indicator -YAML_PARSE_ERR_NO_ANCHOR - No anchor for alias '*%s' -YAML_PARSE_ERR_NO_SEPARATOR - Expected separator '---' -YAML_PARSE_ERR_SINGLE_LINE - Couldn't parse single line value -YAML_PARSE_ERR_BAD_ANCHOR - Invalid anchor -YAML_DUMP_ERR_INVALID_INDENT - Invalid Indent width specified: '%s' -YAML_LOAD_USAGE - usage: YAML::Load($yaml_stream_scalar) -YAML_PARSE_ERR_BAD_NODE - Can't parse node -YAML_PARSE_ERR_BAD_EXPLICIT - Unsupported explicit transfer: '%s' -YAML_DUMP_USAGE_DUMPCODE - Invalid value for DumpCode: '%s' -YAML_LOAD_ERR_FILE_INPUT - Couldn't open %s for input:\n%s -YAML_DUMP_ERR_FILE_CONCATENATE - Can't concatenate to YAML file %s -YAML_DUMP_ERR_FILE_OUTPUT - Couldn't open %s for output:\n%s -YAML_DUMP_ERR_NO_HEADER - With UseHeader=0, the node must be a plain hash or array -YAML_DUMP_WARN_BAD_NODE_TYPE - Can't perform serialization for node type: '%s' -YAML_EMIT_WARN_KEYS - Encountered a problem with 'keys':\n%s -YAML_DUMP_WARN_DEPARSE_FAILED - Deparse failed for CODE reference -YAML_DUMP_WARN_CODE_DUMMY - Emitting dummy subroutine for CODE reference -YAML_PARSE_ERR_MANY_EXPLICIT - More than one explicit transfer -YAML_PARSE_ERR_MANY_IMPLICIT - More than one implicit request -YAML_PARSE_ERR_MANY_ANCHOR - More than one anchor -YAML_PARSE_ERR_ANCHOR_ALIAS - Can't define both an anchor and an alias -YAML_PARSE_ERR_BAD_ALIAS - Invalid alias -YAML_PARSE_ERR_MANY_ALIAS - More than one alias -YAML_LOAD_ERR_NO_CONVERT - Can't convert implicit '%s' node to explicit '%s' node -YAML_LOAD_ERR_NO_DEFAULT_VALUE - No default value for '%s' explicit transfer -YAML_LOAD_ERR_NON_EMPTY_STRING - Only the empty string can be converted to a '%s' -YAML_LOAD_ERR_BAD_MAP_TO_SEQ - Can't transfer map as sequence. Non numeric key '%s' encountered. -YAML_DUMP_ERR_BAD_GLOB - '%s' is an invalid value for Perl glob -YAML_DUMP_ERR_BAD_REGEXP - '%s' is an invalid value for Perl Regexp -YAML_LOAD_ERR_BAD_MAP_ELEMENT - Invalid element in map -YAML_LOAD_WARN_DUPLICATE_KEY - Duplicate map key found. Ignoring. -YAML_LOAD_ERR_BAD_SEQ_ELEMENT - Invalid element in sequence -YAML_PARSE_ERR_INLINE_MAP - Can't parse inline map -YAML_PARSE_ERR_INLINE_SEQUENCE - Can't parse inline sequence -YAML_PARSE_ERR_BAD_DOUBLE - Can't parse double quoted string -YAML_PARSE_ERR_BAD_SINGLE - Can't parse single quoted string -YAML_PARSE_ERR_BAD_INLINE_IMPLICIT - Can't parse inline implicit value '%s' -YAML_PARSE_ERR_BAD_IMPLICIT - Unrecognized implicit value '%s' -YAML_PARSE_ERR_INDENTATION - Error. Invalid indentation level -YAML_PARSE_ERR_INCONSISTENT_INDENTATION - Inconsistent indentation level -YAML_LOAD_WARN_UNRESOLVED_ALIAS - Can't resolve alias *%s -YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP - No 'REGEXP' element for Perl regexp -YAML_LOAD_WARN_BAD_REGEXP_ELEM - Unknown element '%s' in Perl regexp -YAML_LOAD_WARN_GLOB_NAME - No 'NAME' element for Perl glob -YAML_LOAD_WARN_PARSE_CODE - Couldn't parse Perl code scalar: %s -YAML_LOAD_WARN_CODE_DEPARSE - Won't parse Perl code unless $YAML::LoadCode is set -YAML_EMIT_ERR_BAD_LEVEL - Internal Error: Bad level detected -YAML_PARSE_WARN_AMBIGUOUS_TAB - Amibiguous tab converted to spaces -YAML_LOAD_WARN_BAD_GLOB_ELEM - Unknown element '%s' in Perl glob -YAML_PARSE_ERR_ZERO_INDENT - Can't use zero as an indentation width -YAML_LOAD_WARN_GLOB_IO - Can't load an IO filehandle. Yet!!! -... - -%line_adjust = map {($_, 1)} - qw(YAML_PARSE_ERR_BAD_MAJOR_VERSION - YAML_PARSE_WARN_BAD_MINOR_VERSION - YAML_PARSE_ERR_TEXT_AFTER_INDICATOR - YAML_PARSE_ERR_NO_ANCHOR - YAML_PARSE_ERR_MANY_EXPLICIT - YAML_PARSE_ERR_MANY_IMPLICIT - YAML_PARSE_ERR_MANY_ANCHOR - YAML_PARSE_ERR_ANCHOR_ALIAS - YAML_PARSE_ERR_BAD_ALIAS - YAML_PARSE_ERR_MANY_ALIAS - YAML_LOAD_ERR_NO_CONVERT - YAML_LOAD_ERR_NO_DEFAULT_VALUE - YAML_LOAD_ERR_NON_EMPTY_STRING - YAML_LOAD_ERR_BAD_MAP_TO_SEQ - YAML_LOAD_ERR_BAD_STR_TO_INT - YAML_LOAD_ERR_BAD_STR_TO_DATE - YAML_LOAD_ERR_BAD_STR_TO_TIME - YAML_LOAD_WARN_DUPLICATE_KEY - YAML_PARSE_ERR_INLINE_MAP - YAML_PARSE_ERR_INLINE_SEQUENCE - YAML_PARSE_ERR_BAD_DOUBLE - YAML_PARSE_ERR_BAD_SINGLE - YAML_PARSE_ERR_BAD_INLINE_IMPLICIT - YAML_PARSE_ERR_BAD_IMPLICIT - YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP - YAML_LOAD_WARN_BAD_REGEXP_ELEM - YAML_LOAD_WARN_REGEXP_CREATE - YAML_LOAD_WARN_GLOB_NAME - YAML_LOAD_WARN_PARSE_CODE - YAML_LOAD_WARN_CODE_DEPARSE - YAML_LOAD_WARN_BAD_GLOB_ELEM - YAML_PARSE_ERR_ZERO_INDENT - ); - -package YAML::Warning; -use base 'YAML::Error'; - -1; - -__END__ - -=head1 NAME - -YAML::Error - Error formatting class for YAML modules - -=head1 SYNOPSIS - - $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias); - $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); - -=head1 DESCRIPTION - -This module provides a C and a C facility. - -=head1 AUTHOR - -Ingy döt Net - -=head1 COPYRIGHT - -Copyright (c) 2006. Ingy döt Net. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/YAML/YAML/Loader.pm b/modules/YAML/YAML/Loader.pm deleted file mode 100644 index 969867d90..000000000 --- a/modules/YAML/YAML/Loader.pm +++ /dev/null @@ -1,766 +0,0 @@ -package YAML::Loader; -use strict; use warnings; -use YAML::Base; -use base 'YAML::Loader::Base'; -use YAML::Types; - -# Context constants -use constant LEAF => 1; -use constant COLLECTION => 2; -use constant VALUE => "\x07YAML\x07VALUE\x07"; -use constant COMMENT => "\x07YAML\x07COMMENT\x07"; - -# Common YAML character sets -my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]'; -my $FOLD_CHAR = '>'; -my $LIT_CHAR = '|'; -my $LIT_CHAR_RX = "\\$LIT_CHAR"; - -sub load { - my $self = shift; - $self->stream($_[0] || ''); - return $self->_parse(); -} - -# Top level function for parsing. Parse each document in order and -# handle processing for YAML headers. -sub _parse { - my $self = shift; - my (%directives, $preface); - $self->{stream} =~ s|\015\012|\012|g; - $self->{stream} =~ s|\015|\012|g; - $self->line(0); - $self->die('YAML_PARSE_ERR_BAD_CHARS') - if $self->stream =~ /$ESCAPE_CHAR/; - $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE') - if length($self->stream) and - $self->{stream} !~ s/(.)\n\Z/$1/s; - $self->lines([split /\x0a/, $self->stream, -1]); - $self->line(1); - # Throw away any comments or blanks before the header (or start of - # content for headerless streams) - $self->_parse_throwaway_comments(); - $self->document(0); - $self->documents([]); - # Add an "assumed" header if there is no header and the stream is - # not empty (after initial throwaways). - if (not $self->eos) { - if ($self->lines->[0] !~ /^---(\s|$)/) { - unshift @{$self->lines}, '---'; - $self->{line}--; - } - } - - # Main Loop. Parse out all the top level nodes and return them. - while (not $self->eos) { - $self->anchor2node({}); - $self->{document}++; - $self->done(0); - $self->level(0); - $self->offset->[0] = -1; - - if ($self->lines->[0] =~ /^---\s*(.*)$/) { - my @words = split /\s+/, $1; - %directives = (); - while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) { - my ($key, $value) = ($1, $2); - shift(@words); - if (defined $directives{$key}) { - $self->warn('YAML_PARSE_WARN_MULTIPLE_DIRECTIVES', - $key, $self->document); - next; - } - $directives{$key} = $value; - } - $self->preface(join ' ', @words); - } - else { - $self->die('YAML_PARSE_ERR_NO_SEPARATOR'); - } - - if (not $self->done) { - $self->_parse_next_line(COLLECTION); - } - if ($self->done) { - $self->{indent} = -1; - $self->content(''); - } - - $directives{YAML} ||= '1.0'; - $directives{TAB} ||= 'NONE'; - ($self->{major_version}, $self->{minor_version}) = - split /\./, $directives{YAML}, 2; - $self->die('YAML_PARSE_ERR_BAD_MAJOR_VERSION', $directives{YAML}) - if $self->major_version ne '1'; - $self->warn('YAML_PARSE_WARN_BAD_MINOR_VERSION', $directives{YAML}) - if $self->minor_version ne '0'; - $self->die('Unrecognized TAB policy') - unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/; - - push @{$self->documents}, $self->_parse_node(); - } - return wantarray ? @{$self->documents} : $self->documents->[-1]; -} - -# This function is the dispatcher for parsing each node. Every node -# recurses back through here. (Inlines are an exception as they have -# their own sub-parser.) -sub _parse_node { - my $self = shift; - my $preface = $self->preface; - $self->preface(''); - my ($node, $type, $indicator, $escape, $chomp) = ('') x 5; - my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5; - ($anchor, $alias, $explicit, $implicit, $preface) = - $self->_parse_qualifiers($preface); - if ($anchor) { - $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node'; - } - $self->inline(''); - while (length $preface) { - my $line = $self->line - 1; - if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) { - $indicator = $1; - $chomp = $2 if defined($2); - } - else { - $self->die('YAML_PARSE_ERR_TEXT_AFTER_INDICATOR') if $indicator; - $self->inline($preface); - $preface = ''; - } - } - if ($alias) { - $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias) - unless defined $self->anchor2node->{$alias}; - if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') { - $node = $self->anchor2node->{$alias}; - } - else { - $node = do {my $sv = "*$alias"}; - push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; - } - } - elsif (length $self->inline) { - $node = $self->_parse_inline(1, $implicit, $explicit); - if (length $self->inline) { - $self->die('YAML_PARSE_ERR_SINGLE_LINE'); - } - } - elsif ($indicator eq $LIT_CHAR) { - $self->{level}++; - $node = $self->_parse_block($chomp); - $node = $self->_parse_implicit($node) if $implicit; - $self->{level}--; - } - elsif ($indicator eq $FOLD_CHAR) { - $self->{level}++; - $node = $self->_parse_unfold($chomp); - $node = $self->_parse_implicit($node) if $implicit; - $self->{level}--; - } - else { - $self->{level}++; - $self->offset->[$self->level] ||= 0; - if ($self->indent == $self->offset->[$self->level]) { - if ($self->content =~ /^-( |$)/) { - $node = $self->_parse_seq($anchor); - } - elsif ($self->content =~ /(^\?|\:( |$))/) { - $node = $self->_parse_mapping($anchor); - } - elsif ($preface =~ /^\s*$/) { - $node = $self->_parse_implicit(''); - } - else { - $self->die('YAML_PARSE_ERR_BAD_NODE'); - } - } - else { - $node = undef; - } - $self->{level}--; - } - $#{$self->offset} = $self->level; - - if ($explicit) { - if ($class) { - if (not ref $node) { - my $copy = $node; - undef $node; - $node = \$copy; - } - CORE::bless $node, $class; - } - else { - $node = $self->_parse_explicit($node, $explicit); - } - } - if ($anchor) { - if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') { - # XXX Can't remember what this code actually does - for my $ref (@{$self->anchor2node->{$anchor}}) { - ${$ref->[0]} = $node; - $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS', - $anchor, $ref->[1]); - } - } - $self->anchor2node->{$anchor} = $node; - } - return $node; -} - -# Preprocess the qualifiers that may be attached to any node. -sub _parse_qualifiers { - my $self = shift; - my ($preface) = @_; - my ($anchor, $alias, $explicit, $implicit, $token) = ('') x 5; - $self->inline(''); - while ($preface =~ /^[&*!]/) { - my $line = $self->line - 1; - if ($preface =~ s/^\!(\S+)\s*//) { - $self->die('YAML_PARSE_ERR_MANY_EXPLICIT') if $explicit; - $explicit = $1; - } - elsif ($preface =~ s/^\!\s*//) { - $self->die('YAML_PARSE_ERR_MANY_IMPLICIT') if $implicit; - $implicit = 1; - } - elsif ($preface =~ s/^\&([^ ,:]+)\s*//) { - $token = $1; - $self->die('YAML_PARSE_ERR_BAD_ANCHOR') - unless $token =~ /^[a-zA-Z0-9]+$/; - $self->die('YAML_PARSE_ERR_MANY_ANCHOR') if $anchor; - $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $alias; - $anchor = $token; - } - elsif ($preface =~ s/^\*([^ ,:]+)\s*//) { - $token = $1; - $self->die('YAML_PARSE_ERR_BAD_ALIAS') - unless $token =~ /^[a-zA-Z0-9]+$/; - $self->die('YAML_PARSE_ERR_MANY_ALIAS') if $alias; - $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $anchor; - $alias = $token; - } - } - return ($anchor, $alias, $explicit, $implicit, $preface); -} - -# Morph a node to it's explicit type -sub _parse_explicit { - my $self = shift; - my ($node, $explicit) = @_; - my ($type, $class); - if ($explicit =~ /^\!perl\/(hash|array|scalar)\:(\w(\w|\:\:)*)?$/) { - ($type, $class) = (($1 || ''), ($2 || '')); - if (ref $node) { - return CORE::bless $node, $class; - } - else { - return CORE::bless \$node, $class; - } - } - if ($explicit =~ - /^\!?perl\/(undef|glob|regexp|code|ref)\:(\w(\w|\:\:)*)?$/) { - ($type, $class) = (($1 || ''), ($2 || '')); - my $type_class = "YAML::Type::$type"; - no strict 'refs'; - if ($type_class->can('yaml_load')) { - return $type_class->yaml_load($node, $class, $self); - } - else { - $self->die('YAML_LOAD_ERR_NO_CONVERT', 'XXX', $explicit); - } - } - # This !perl/@Foo and !perl/$Foo are deprecated but still parsed - elsif ($YAML::TagClass->{$explicit} || - $explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$} - ) { - $class = $YAML::TagClass->{$explicit} || $2; - if ($class->can('yaml_load')) { - require YAML::Node; - return $class->yaml_load(YAML::Node->new($node, $explicit)); - } - else { - if (ref $node) { - return CORE::bless $node, $class; - } - else { - return CORE::bless \$node, $class; - } - } - } - elsif (ref $node) { - require YAML::Node; - return YAML::Node->new($node, $explicit); - } - else { - # XXX This is likely wrong. Failing test: - # --- !unknown 'scalar value' - return $node; - } -} - -# Parse a YAML mapping into a Perl hash -sub _parse_mapping { - my $self = shift; - my ($anchor) = @_; - my $mapping = {}; - $self->anchor2node->{$anchor} = $mapping; - my $key; - while (not $self->done and $self->indent == $self->offset->[$self->level]) { - # If structured key: - if ($self->{content} =~ s/^\?\s*//) { - $self->preface($self->content); - $self->_parse_next_line(COLLECTION); - $key = $self->_parse_node(); - $key = "$key"; - } - # If "default" key (equals sign) - elsif ($self->{content} =~ s/^\=\s*//) { - $key = VALUE; - } - # If "comment" key (slash slash) - elsif ($self->{content} =~ s/^\=\s*//) { - $key = COMMENT; - } - # Regular scalar key: - else { - $self->inline($self->content); - $key = $self->_parse_inline(); - $key = "$key"; - $self->content($self->inline); - $self->inline(''); - } - - unless ($self->{content} =~ s/^:\s*//) { - $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT'); - } - $self->preface($self->content); - my $line = $self->line; - $self->_parse_next_line(COLLECTION); - my $value = $self->_parse_node(); - if (exists $mapping->{$key}) { - $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); - } - else { - $mapping->{$key} = $value; - } - } - return $mapping; -} - -# Parse a YAML sequence into a Perl array -sub _parse_seq { - my $self = shift; - my ($anchor) = @_; - my $seq = []; - $self->anchor2node->{$anchor} = $seq; - while (not $self->done and $self->indent == $self->offset->[$self->level]) { - if ($self->content =~ /^-(?: (.*))?$/) { - $self->preface(defined($1) ? $1 : ''); - } - else { - $self->die('YAML_LOAD_ERR_BAD_SEQ_ELEMENT'); - } - if ($self->preface =~ /^(\s*)(\w.*\:(?: |$).*)$/) { - $self->indent($self->offset->[$self->level] + 2 + length($1)); - $self->content($2); - $self->level($self->level + 1); - $self->offset->[$self->level] = $self->indent; - $self->preface(''); - push @$seq, $self->_parse_mapping(''); - $self->{level}--; - $#{$self->offset} = $self->level; - } - else { - $self->_parse_next_line(COLLECTION); - push @$seq, $self->_parse_node(); - } - } - return $seq; -} - -# Parse an inline value. Since YAML supports inline collections, this is -# the top level of a sub parsing. -sub _parse_inline { - my $self = shift; - my ($top, $top_implicit, $top_explicit) = (@_, '', '', ''); - $self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump - my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5; - ($anchor, $alias, $explicit, $implicit, $self->{inline}) = - $self->_parse_qualifiers($self->inline); - if ($anchor) { - $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node'; - } - $implicit ||= $top_implicit; - $explicit ||= $top_explicit; - ($top_implicit, $top_explicit) = ('', ''); - if ($alias) { - $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias) - unless defined $self->anchor2node->{$alias}; - if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') { - $node = $self->anchor2node->{$alias}; - } - else { - $node = do {my $sv = "*$alias"}; - push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; - } - } - elsif ($self->inline =~ /^\{/) { - $node = $self->_parse_inline_mapping($anchor); - } - elsif ($self->inline =~ /^\[/) { - $node = $self->_parse_inline_seq($anchor); - } - elsif ($self->inline =~ /^"/) { - $node = $self->_parse_inline_double_quoted(); - $node = $self->_unescape($node); - $node = $self->_parse_implicit($node) if $implicit; - } - elsif ($self->inline =~ /^'/) { - $node = $self->_parse_inline_single_quoted(); - $node = $self->_parse_implicit($node) if $implicit; - } - else { - if ($top) { - $node = $self->inline; - $self->inline(''); - } - else { - $node = $self->_parse_inline_simple(); - } - $node = $self->_parse_implicit($node) unless $explicit; - } - if ($explicit) { - $node = $self->_parse_explicit($node, $explicit); - } - if ($anchor) { - if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') { - for my $ref (@{$self->anchor2node->{$anchor}}) { - ${$ref->[0]} = $node; - $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS', - $anchor, $ref->[1]); - } - } - $self->anchor2node->{$anchor} = $node; - } - return $node; -} - -# Parse the inline YAML mapping into a Perl hash -sub _parse_inline_mapping { - my $self = shift; - my ($anchor) = @_; - my $node = {}; - $self->anchor2node->{$anchor} = $node; - - $self->die('YAML_PARSE_ERR_INLINE_MAP') - unless $self->{inline} =~ s/^\{\s*//; - while (not $self->{inline} =~ s/^\s*\}//) { - my $key = $self->_parse_inline(); - $self->die('YAML_PARSE_ERR_INLINE_MAP') - unless $self->{inline} =~ s/^\: \s*//; - my $value = $self->_parse_inline(); - if (exists $node->{$key}) { - $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); - } - else { - $node->{$key} = $value; - } - next if $self->inline =~ /^\s*\}/; - $self->die('YAML_PARSE_ERR_INLINE_MAP') - unless $self->{inline} =~ s/^\,\s*//; - } - return $node; -} - -# Parse the inline YAML sequence into a Perl array -sub _parse_inline_seq { - my $self = shift; - my ($anchor) = @_; - my $node = []; - $self->anchor2node->{$anchor} = $node; - - $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE') - unless $self->{inline} =~ s/^\[\s*//; - while (not $self->{inline} =~ s/^\s*\]//) { - my $value = $self->_parse_inline(); - push @$node, $value; - next if $self->inline =~ /^\s*\]/; - $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE') - unless $self->{inline} =~ s/^\,\s*//; - } - return $node; -} - -# Parse the inline double quoted string. -sub _parse_inline_double_quoted { - my $self = shift; - my $node; - if ($self->inline =~ /^"((?:\\"|[^"])*)"\s*(.*)$/) { - $node = $1; - $self->inline($2); - $node =~ s/\\"/"/g; - } - else { - $self->die('YAML_PARSE_ERR_BAD_DOUBLE'); - } - return $node; -} - - -# Parse the inline single quoted string. -sub _parse_inline_single_quoted { - my $self = shift; - my $node; - if ($self->inline =~ /^'((?:''|[^'])*)'\s*(.*)$/) { - $node = $1; - $self->inline($2); - $node =~ s/''/'/g; - } - else { - $self->die('YAML_PARSE_ERR_BAD_SINGLE'); - } - return $node; -} - -# Parse the inline unquoted string and do implicit typing. -sub _parse_inline_simple { - my $self = shift; - my $value; - if ($self->inline =~ /^(|[^!@#%^&*].*?)(?=[\[\]\{\},]|, |: |- |:\s*$|$)/) { - $value = $1; - substr($self->{inline}, 0, length($1)) = ''; - } - else { - $self->die('YAML_PARSE_ERR_BAD_INLINE_IMPLICIT', $value); - } - return $value; -} - -sub _parse_implicit { - my $self = shift; - my ($value) = @_; - $value =~ s/\s*$//; - return $value if $value eq ''; - return undef if $value =~ /^~$/; - return $value - unless $value =~ /^[\@\`\^]/ or - $value =~ /^[\-\?]\s/; - $self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value); -} - -# Unfold a YAML multiline scalar into a single string. -sub _parse_unfold { - my $self = shift; - my ($chomp) = @_; - my $node = ''; - my $space = 0; - while (not $self->done and $self->indent == $self->offset->[$self->level]) { - $node .= $self->content. "\n"; - $self->_parse_next_line(LEAF); - } - $node =~ s/^(\S.*)\n(?=\S)/$1 /gm; - $node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm; - $node =~ s/\n*\Z// unless $chomp eq '+'; - $node .= "\n" unless $chomp; - return $node; -} - -# Parse a YAML block style scalar. This is like a Perl here-document. -sub _parse_block { - my $self = shift; - my ($chomp) = @_; - my $node = ''; - while (not $self->done and $self->indent == $self->offset->[$self->level]) { - $node .= $self->content . "\n"; - $self->_parse_next_line(LEAF); - } - return $node if '+' eq $chomp; - $node =~ s/\n*\Z/\n/; - $node =~ s/\n\Z// if $chomp eq '-'; - return $node; -} - -# Handle Perl style '#' comments. Comments must be at the same indentation -# level as the collection line following them. -sub _parse_throwaway_comments { - my $self = shift; - while (@{$self->lines} and - $self->lines->[0] =~ m{^\s*(\#|$)} - ) { - shift @{$self->lines}; - $self->{line}++; - } - $self->eos($self->{done} = not @{$self->lines}); -} - -# This is the routine that controls what line is being parsed. It gets called -# once for each line in the YAML stream. -# -# This routine must: -# 1) Skip past the current line -# 2) Determine the indentation offset for a new level -# 3) Find the next _content_ line -# A) Skip over any throwaways (Comments/blanks) -# B) Set $self->indent, $self->content, $self->line -# 4) Expand tabs appropriately -sub _parse_next_line { - my $self = shift; - my ($type) = @_; - my $level = $self->level; - my $offset = $self->offset->[$level]; - $self->die('YAML_EMIT_ERR_BAD_LEVEL') unless defined $offset; - shift @{$self->lines}; - $self->eos($self->{done} = not @{$self->lines}); - return if $self->eos; - $self->{line}++; - - # Determine the offset for a new leaf node - if ($self->preface =~ - qr/(?:^|\s)(?:$FOLD_CHAR|$LIT_CHAR_RX)(?:-|\+)?(\d*)\s*$/ - ) { - $self->die('YAML_PARSE_ERR_ZERO_INDENT') - if length($1) and $1 == 0; - $type = LEAF; - if (length($1)) { - $self->offset->[$level + 1] = $offset + $1; - } - else { - # First get rid of any comments. - while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) { - $self->lines->[0] =~ /^( *)/ or die; - last unless length($1) <= $offset; - shift @{$self->lines}; - $self->{line}++; - } - $self->eos($self->{done} = not @{$self->lines}); - return if $self->eos; - if ($self->lines->[0] =~ /^( *)\S/ and length($1) > $offset) { - $self->offset->[$level+1] = length($1); - } - else { - $self->offset->[$level+1] = $offset + 1; - } - } - $offset = $self->offset->[++$level]; - } - # Determine the offset for a new collection level - elsif ($type == COLLECTION and - $self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) { - $self->_parse_throwaway_comments(); - if ($self->eos) { - $self->offset->[$level+1] = $offset + 1; - return; - } - else { - $self->lines->[0] =~ /^( *)\S/ or die; - if (length($1) > $offset) { - $self->offset->[$level+1] = length($1); - } - else { - $self->offset->[$level+1] = $offset + 1; - } - } - $offset = $self->offset->[++$level]; - } - - if ($type == LEAF) { - while (@{$self->lines} and - $self->lines->[0] =~ m{^( *)(\#)} and - length($1) < $offset - ) { - shift @{$self->lines}; - $self->{line}++; - } - $self->eos($self->{done} = not @{$self->lines}); - } - else { - $self->_parse_throwaway_comments(); - } - return if $self->eos; - - if ($self->lines->[0] =~ /^---(\s|$)/) { - $self->done(1); - return; - } - if ($type == LEAF and - $self->lines->[0] =~ /^ {$offset}(.*)$/ - ) { - $self->indent($offset); - $self->content($1); - } - elsif ($self->lines->[0] =~ /^\s*$/) { - $self->indent($offset); - $self->content(''); - } - else { - $self->lines->[0] =~ /^( *)(\S.*)$/; - while ($self->offset->[$level] > length($1)) { - $level--; - } - $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION') - if $self->offset->[$level] != length($1); - $self->indent(length($1)); - $self->content($2); - } - $self->die('YAML_PARSE_ERR_INDENTATION') - if $self->indent - $offset > 1; -} - -#============================================================================== -# Utility subroutines. -#============================================================================== - -# Printable characters for escapes -my %unescapes = - ( - z => "\x00", a => "\x07", t => "\x09", - n => "\x0a", v => "\x0b", f => "\x0c", - r => "\x0d", e => "\x1b", '\\' => '\\', - ); - -# Transform all the backslash style escape characters to their literal meaning -sub _unescape { - my $self = shift; - my ($node) = @_; - $node =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/ - (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex; - return $node; -} - -1; - -__END__ - -=head1 NAME - -YAML::Loader - YAML class for loading Perl objects to YAML - -=head1 SYNOPSIS - - use YAML::Loader; - my $loader = YAML::Loader->new; - my $hash = $loader->load(<<'...'); - foo: bar - ... - -=head1 DESCRIPTION - -YAML::Loader is the module that YAML.pm used to deserialize YAML to Perl -objects. It is fully object oriented and usable on its own. - -=head1 AUTHOR - -Ingy döt Net - -=head1 COPYRIGHT - -Copyright (c) 2006. Ingy döt Net. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/YAML/YAML/Loader/Base.pm b/modules/YAML/YAML/Loader/Base.pm deleted file mode 100644 index 4d5b02dd0..000000000 --- a/modules/YAML/YAML/Loader/Base.pm +++ /dev/null @@ -1,64 +0,0 @@ -package YAML::Loader::Base; -use strict; use warnings; -use YAML::Base; use base 'YAML::Base'; - -field load_code => 0; - -field stream => ''; -field document => 0; -field line => 0; -field documents => []; -field lines => []; -field eos => 0; -field done => 0; -field anchor2node => {}; -field level => 0; -field offset => []; -field preface => ''; -field content => ''; -field indent => 0; -field major_version => 0; -field minor_version => 0; -field inline => ''; - -sub set_global_options { - my $self = shift; - $self->load_code($YAML::LoadCode || $YAML::UseCode) - if defined $YAML::LoadCode or defined $YAML::UseCode; -} - -sub load { - die 'load() not implemented in this class.'; -} - -1; - -__END__ - -=head1 NAME - -YAML::Loader::Base - Base class for YAML Loader classes - -=head1 SYNOPSIS - - package YAML::Loader::Something; - use YAML::Loader::Base -base; - -=head1 DESCRIPTION - -YAML::Loader::Base is a base class for creating YAML loader classes. - -=head1 AUTHOR - -Ingy döt Net - -=head1 COPYRIGHT - -Copyright (c) 2006. Ingy döt Net. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/YAML/YAML/Marshall.pm b/modules/YAML/YAML/Marshall.pm deleted file mode 100644 index 5985ecea8..000000000 --- a/modules/YAML/YAML/Marshall.pm +++ /dev/null @@ -1,77 +0,0 @@ -package YAML::Marshall; -use strict; use warnings; -use YAML::Node(); - -sub import { - my $class = shift; - no strict 'refs'; - my $package = caller; - unless (grep { $_ eq $class} @{$package . '::ISA'}) { - push @{$package . '::ISA'}, $class; - } - - my $tag = shift; - if ($tag) { - no warnings 'once'; - $YAML::TagClass->{$tag} = $package; - ${$package . "::YamlTag"} = $tag; - } -} - -sub yaml_dump { - my $self = shift; - no strict 'refs'; - my $tag = ${ref($self) . "::YamlTag"} || 'perl/' . ref($self); - $self->yaml_node($self, $tag); -} - -sub yaml_load { - my ($class, $node) = @_; - if (my $ynode = $class->yaml_ynode($node)) { - $node = $ynode->{NODE}; - } - bless $node, $class; -} - -sub yaml_node { - shift; - YAML::Node->new(@_); -} - -sub yaml_ynode { - shift; - YAML::Node::ynode(@_); -} - -1; - -__END__ - -=head1 NAME - -YAML::Marshall - YAML marshalling class you can mixin to your classes - -=head1 SYNOPSIS - - package Bar; - use Foo -base; - use YAML::Marshall -mixin; - -=head1 DESCRIPTION - -For classes that want to handle their own YAML serialization. - -=head1 AUTHOR - -Ingy döt Net - -=head1 COPYRIGHT - -Copyright (c) 2006. Ingy döt Net. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/YAML/YAML/Node.pm b/modules/YAML/YAML/Node.pm deleted file mode 100644 index 69affcf67..000000000 --- a/modules/YAML/YAML/Node.pm +++ /dev/null @@ -1,296 +0,0 @@ -package YAML::Node; -use strict; use warnings; -use YAML::Base; use base 'YAML::Base'; -use YAML::Tag; - -our @EXPORT = qw(ynode); - -sub ynode { - my $self; - if (ref($_[0]) eq 'HASH') { - $self = tied(%{$_[0]}); - } - elsif (ref($_[0]) eq 'ARRAY') { - $self = tied(@{$_[0]}); - } - else { - $self = tied($_[0]); - } - return (ref($self) =~ /^yaml_/) ? $self : undef; -} - -sub new { - my ($class, $node, $tag) = @_; - my $self; - $self->{NODE} = $node; - my (undef, $type) = $class->node_info($node); - $self->{KIND} = (not defined $type) ? 'scalar' : - ($type eq 'ARRAY') ? 'sequence' : - ($type eq 'HASH') ? 'mapping' : - $class->die("Can't create YAML::Node from '$type'"); - tag($self, ($tag || '')); - if ($self->{KIND} eq 'scalar') { - yaml_scalar->new($self, $_[1]); - return \ $_[1]; - } - my $package = "yaml_" . $self->{KIND}; - $package->new($self) -} - -sub node { $_->{NODE} } -sub kind { $_->{KIND} } -sub tag { - my ($self, $value) = @_; - if (defined $value) { - $self->{TAG} = YAML::Tag->new($value); - return $self; - } - else { - return $self->{TAG}; - } -} -sub keys { - my ($self, $value) = @_; - if (defined $value) { - $self->{KEYS} = $value; - return $self; - } - else { - return $self->{KEYS}; - } -} - -#============================================================================== -package yaml_scalar; -@yaml_scalar::ISA = qw(YAML::Node); - -sub new { - my ($class, $self) = @_; - tie $_[2], $class, $self; -} - -sub TIESCALAR { - my ($class, $self) = @_; - bless $self, $class; - $self -} - -sub FETCH { - my ($self) = @_; - $self->{NODE} -} - -sub STORE { - my ($self, $value) = @_; - $self->{NODE} = $value -} - -#============================================================================== -package yaml_sequence; -@yaml_sequence::ISA = qw(YAML::Node); - -sub new { - my ($class, $self) = @_; - my $new; - tie @$new, $class, $self; - $new -} - -sub TIEARRAY { - my ($class, $self) = @_; - bless $self, $class -} - -sub FETCHSIZE { - my ($self) = @_; - scalar @{$self->{NODE}}; -} - -sub FETCH { - my ($self, $index) = @_; - $self->{NODE}[$index] -} - -sub STORE { - my ($self, $index, $value) = @_; - $self->{NODE}[$index] = $value -} - -sub undone { - die "Not implemented yet"; # XXX -} - -*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = -*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = -*undone; # XXX Must implement before release - -#============================================================================== -package yaml_mapping; -@yaml_mapping::ISA = qw(YAML::Node); - -sub new { - my ($class, $self) = @_; - @{$self->{KEYS}} = sort keys %{$self->{NODE}}; - my $new; - tie %$new, $class, $self; - $new -} - -sub TIEHASH { - my ($class, $self) = @_; - bless $self, $class -} - -sub FETCH { - my ($self, $key) = @_; - if (exists $self->{NODE}{$key}) { - return (grep {$_ eq $key} @{$self->{KEYS}}) - ? $self->{NODE}{$key} : undef; - } - return $self->{HASH}{$key}; -} - -sub STORE { - my ($self, $key, $value) = @_; - if (exists $self->{NODE}{$key}) { - $self->{NODE}{$key} = $value; - } - elsif (exists $self->{HASH}{$key}) { - $self->{HASH}{$key} = $value; - } - else { - if (not grep {$_ eq $key} @{$self->{KEYS}}) { - push(@{$self->{KEYS}}, $key); - } - $self->{HASH}{$key} = $value; - } - $value -} - -sub DELETE { - my ($self, $key) = @_; - my $return; - if (exists $self->{NODE}{$key}) { - $return = $self->{NODE}{$key}; - } - elsif (exists $self->{HASH}{$key}) { - $return = delete $self->{NODE}{$key}; - } - for (my $i = 0; $i < @{$self->{KEYS}}; $i++) { - if ($self->{KEYS}[$i] eq $key) { - splice(@{$self->{KEYS}}, $i, 1); - } - } - return $return; -} - -sub CLEAR { - my ($self) = @_; - @{$self->{KEYS}} = (); - %{$self->{HASH}} = (); -} - -sub FIRSTKEY { - my ($self) = @_; - $self->{ITER} = 0; - $self->{KEYS}[0] -} - -sub NEXTKEY { - my ($self) = @_; - $self->{KEYS}[++$self->{ITER}] -} - -sub EXISTS { - my ($self, $key) = @_; - exists $self->{NODE}{$key} -} - -1; - -__END__ - -=head1 NAME - -YAML::Node - A generic data node that encapsulates YAML information - -=head1 SYNOPSIS - - use YAML; - use YAML::Node; - - my $ynode = YAML::Node->new({}, 'ingerson.com/fruit'); - %$ynode = qw(orange orange apple red grape green); - print Dump $ynode; - -yields: - - --- !ingerson.com/fruit - orange: orange - apple: red - grape: green - -=head1 DESCRIPTION - -A generic node in YAML is similar to a plain hash, array, or scalar node -in Perl except that it must also keep track of its type. The type is a -URI called the YAML type tag. - -YAML::Node is a class for generating and manipulating these containers. -A YAML node (or ynode) is a tied hash, array or scalar. In most ways it -behaves just like the plain thing. But you can assign and retrieve and -YAML type tag URI to it. For the hash flavor, you can also assign the -order that the keys will be retrieved in. By default a ynode will offer -its keys in the same order that they were assigned. - -YAML::Node has a class method call new() that will return a ynode. You -pass it a regular node and an optional type tag. After that you can -use it like a normal Perl node, but when you YAML::Dump it, the magical -properties will be honored. - -This is how you can control the sort order of hash keys during a YAML -serialization. By default, YAML sorts keys alphabetically. But notice -in the above example that the keys were Dumped in the same order they -were assigned. - -YAML::Node exports a function called ynode(). This function returns the tied object so that you can call special methods on it like ->keys(). - -keys() works like this: - - use YAML; - use YAML::Node; - - %$node = qw(orange orange apple red grape green); - $ynode = YAML::Node->new($node); - ynode($ynode)->keys(['grape', 'apple']); - print Dump $ynode; - -produces: - - --- - grape: green - apple: red - -It tells the ynode which keys and what order to use. - -ynodes will play a very important role in how programs use YAML. They -are the foundation of how a Perl class can marshall the Loading and -Dumping of its objects. - -The upcoming versions of YAML.pm will have much more information on this. - -=head1 AUTHOR - -Ingy döt Net - -=head1 COPYRIGHT - -Copyright (c) 2006. Ingy döt Net. All rights reserved. -Copyright (c) 2002. Brian Ingerson. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/YAML/YAML/Tag.pm b/modules/YAML/YAML/Tag.pm deleted file mode 100644 index a6826fd94..000000000 --- a/modules/YAML/YAML/Tag.pm +++ /dev/null @@ -1,48 +0,0 @@ -package YAML::Tag; -use strict; use warnings; - -use overload '""' => sub { ${$_[0]} }; - -sub new { - my ($class, $self) = @_; - bless \$self, $class -} - -sub short { - ${$_[0]} -} - -sub canonical { - ${$_[0]} -} - -1; - -__END__ - -=head1 NAME - -YAML::Tag - Tag URI object class for YAML - -=head1 SYNOPSIS - - use YAML::Tag; - -=head1 DESCRIPTION - -Used by YAML::Node. - -=head1 AUTHOR - -Ingy döt Net - -=head1 COPYRIGHT - -Copyright (c) 2006. Ingy döt Net. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/YAML/YAML/Types.pm b/modules/YAML/YAML/Types.pm deleted file mode 100644 index 4d737baee..000000000 --- a/modules/YAML/YAML/Types.pm +++ /dev/null @@ -1,262 +0,0 @@ -package YAML::Types; -use strict; use warnings; -use YAML::Base; use base 'YAML::Base'; -use YAML::Node; - -# XXX These classes and their APIs could still use some refactoring, -# but at least they work for now. -#------------------------------------------------------------------------------- -package YAML::Type::blessed; -use YAML::Base; # XXX -sub yaml_dump { - my $self = shift; - my ($value) = @_; - my ($class, $type) = YAML::Base->node_info($value); - no strict 'refs'; - my $kind = lc($type) . ':'; - my $tag = ${$class . '::ClassTag'} || - "!perl/$kind$class"; - if ($type eq 'REF') { - YAML::Node->new( - {(&YAML::VALUE, ${$_[0]})}, $tag - ); - } - elsif ($type eq 'SCALAR') { - $_[1] = $$value; - YAML::Node->new($_[1], $tag); - } else { - YAML::Node->new($value, $tag); - } -} - -#------------------------------------------------------------------------------- -package YAML::Type::undef; -sub yaml_dump { - my $self = shift; -} - -sub yaml_load { - my $self = shift; -} - -#------------------------------------------------------------------------------- -package YAML::Type::glob; -sub yaml_dump { - my $self = shift; - my $ynode = YAML::Node->new({}, '!perl/glob:'); - for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) { - my $value = *{$_[0]}{$type}; - $value = $$value if $type eq 'SCALAR'; - if (defined $value) { - if ($type eq 'IO') { - my @stats = qw(device inode mode links uid gid rdev size - atime mtime ctime blksize blocks); - undef $value; - $value->{stat} = YAML::Node->new({}); - map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]}); - $value->{fileno} = fileno(*{$_[0]}); - { - local $^W; - $value->{tell} = tell(*{$_[0]}); - } - } - $ynode->{$type} = $value; - } - } - return $ynode; -} - -sub yaml_load { - my $self = shift; - my ($node, $class, $loader) = @_; - my ($name, $package); - if (defined $node->{NAME}) { - $name = $node->{NAME}; - delete $node->{NAME}; - } - else { - $loader->warn('YAML_LOAD_WARN_GLOB_NAME'); - return undef; - } - if (defined $node->{PACKAGE}) { - $package = $node->{PACKAGE}; - delete $node->{PACKAGE}; - } - else { - $package = 'main'; - } - no strict 'refs'; - if (exists $node->{SCALAR}) { - *{"${package}::$name"} = \$node->{SCALAR}; - delete $node->{SCALAR}; - } - for my $elem (qw(ARRAY HASH CODE IO)) { - if (exists $node->{$elem}) { - if ($elem eq 'IO') { - $loader->warn('YAML_LOAD_WARN_GLOB_IO'); - delete $node->{IO}; - next; - } - *{"${package}::$name"} = $node->{$elem}; - delete $node->{$elem}; - } - } - for my $elem (sort keys %$node) { - $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem); - } - return *{"${package}::$name"}; -} - -#------------------------------------------------------------------------------- -package YAML::Type::code; -my $dummy_warned = 0; -my $default = '{ "DUMMY" }'; -sub yaml_dump { - my $self = shift; - my $code; - my ($dumpflag, $value) = @_; - my ($class, $type) = YAML::Base->node_info($value); - $class ||= ''; - my $tag = "!perl/code:$class"; - if (not $dumpflag) { - $code = $default; - } - else { - bless $value, "CODE" if $class; - eval { use B::Deparse }; - return if $@; - my $deparse = B::Deparse->new(); - eval { - local $^W = 0; - $code = $deparse->coderef2text($value); - }; - if ($@) { - warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W; - $code = $default; - } - bless $value, $class if $class; - chomp $code; - $code .= "\n"; - } - $_[2] = $code; - YAML::Node->new($_[2], $tag); -} - -sub yaml_load { - my $self = shift; - my ($node, $class, $loader) = @_; - if ($loader->load_code) { - my $code = eval "package main; sub $node"; - if ($@) { - $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@); - return sub {}; - } - else { - CORE::bless $code, $class if $class; - return $code; - } - } - else { - return sub {}; - } -} - -#------------------------------------------------------------------------------- -package YAML::Type::ref; -sub yaml_dump { - my $self = shift; - YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref:') -} - -sub yaml_load { - my $self = shift; - my ($node, $class, $loader) = @_; - $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr') - unless exists $node->{&YAML::VALUE}; - return \$node->{&YAML::VALUE}; -} - -#------------------------------------------------------------------------------- -package YAML::Type::regexp; -# XXX Be sure to handle blessed regexps (if possible) -sub yaml_dump { - my $self = shift; - my ($node, $class, $dumper) = @_; - my ($regexp, $modifiers); - if ("$node" =~ /^\(\?(\w*)(?:\-\w+)?\:(.*)\)$/) { - $regexp = $2; - $modifiers = $1 || ''; - } - else { - $dumper->die('YAML_DUMP_ERR_BAD_REGEXP', $node); - } - my $tag = '!perl/regexp:'; - $tag .= $class if $class; - my $ynode = YAML::Node->new({}, $tag); - $ynode->{REGEXP} = $regexp; - $ynode->{MODIFIERS} = $modifiers if $modifiers; - return $ynode; -} - -sub yaml_load { - my $self = shift; - my ($node, $class, $loader) = @_; - my ($regexp, $modifiers); - if (defined $node->{REGEXP}) { - $regexp = $node->{REGEXP}; - delete $node->{REGEXP}; - } - else { - $loader->warn('YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP'); - return undef; - } - if (defined $node->{MODIFIERS}) { - $modifiers = $node->{MODIFIERS}; - delete $node->{MODIFIERS}; - } - else { - $modifiers = ''; - } - for my $elem (sort keys %$node) { - $loader->warn('YAML_LOAD_WARN_BAD_REGEXP_ELEM', $elem); - } - my $qr = $regexp; - $qr = "(?$modifiers:$qr)"; - return qr{$qr}; -} - -1; - -__END__ - -=head1 NAME - -YAML::Transfer - Marshall Perl internal data types to/from YAML - -=head1 SYNOPSIS - - $::foo = 42; - print YAML::Dump(*::foo); - - print YAML::Dump(qr{match me}); - -=head1 DESCRIPTION - -This module has the helper classes for transferring objects, -subroutines, references, globs, regexps and file handles to and -from YAML. - -=head1 AUTHOR - -Ingy döt Net - -=head1 COPYRIGHT - -Copyright (c) 2006. Ingy döt Net. All rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -See L - -=cut diff --git a/modules/fallback/CGI/.htaccess b/modules/fallback/CGI/.htaccess new file mode 100644 index 000000000..0a9a0473a --- /dev/null +++ b/modules/fallback/CGI/.htaccess @@ -0,0 +1,2 @@ +Order Allow,Deny +Deny from all diff --git a/modules/fallback/CGI/Ajax.pm b/modules/fallback/CGI/Ajax.pm new file mode 100644 index 000000000..41e9c3342 --- /dev/null +++ b/modules/fallback/CGI/Ajax.pm @@ -0,0 +1,1215 @@ +package CGI::Ajax; +use strict; +use Data::Dumper; +use base qw(Class::Accessor); +use overload '""' => 'show_javascript'; # for building web pages, so + # you can just say: print $pjx +BEGIN { + use vars qw ($VERSION @ISA @METHODS); + @METHODS = qw(url_list coderef_list DEBUG JSDEBUG html + js_encode_function cgi_header_extra); + + CGI::Ajax->mk_accessors( @METHODS ); + + $VERSION = .697; +} + +########################################### main pod documentation begin ## + +=head1 NAME + +CGI::Ajax - a perl-specific system for writing Asynchronous web +applications + +=head1 SYNOPSIS + + use strict; + use CGI; # or any other CGI:: form handler/decoder + use CGI::Ajax; + + my $cgi = new CGI; + my $pjx = new CGI::Ajax( 'exported_func' => \&perl_func ); + + print $pjx->build_html( $cgi, \&Show_HTML); + + sub perl_func { + my $input = shift; + # do something with $input + my $output = $input . " was the input!"; + return( $output ); + } + + sub Show_HTML { + my $html = < + + Enter something: + +
+
+ + + EOHTML + return $html; + } + +I + +=head1 DESCRIPTION + +CGI::Ajax is an object-oriented module that provides a unique +mechanism for using perl code asynchronously from javascript- +enhanced HTML pages. CGI::Ajax unburdens the user from having to +write extensive javascript, except for associating an exported +method with a document-defined event (such as onClick, onKeyUp, +etc). CGI::Ajax also mixes well with HTML containing more complex +javascript. + +CGI::Ajax supports methods that return single results or multiple +results to the web page, and supports returning values to multiple +DIV elements on the HTML page. + +Using CGI::Ajax, the URL for the HTTP GET/POST request is +automatically generated based on HTML layout and events, and the +page is then dynamically updated with the output from the perl +function. Additionally, CGI::Ajax supports mapping URL's to a +CGI::Ajax function name, so you can separate your code processing +over multiple scripts. + +Other than using the Class::Accessor module to generate CGI::Ajax' +accessor methods, CGI::Ajax is completely self-contained - it +does not require you to install a larger package or a full Content +Management System, etc. + +We have added I for other CGI handler/decoder modules, +like L or L, but we can't test these +since we run mod_perl2 only here. CGI::Ajax checks to see if a +header() method is available to the CGI object, and then uses it. +If method() isn't available, it creates it's own minimal header. + +A primary goal of CGI::Ajax is to keep the module streamlined and +maximally flexible. We are trying to keep the generated javascript +code to a minimum, but still provide users with a variety of +methods for deploying CGI::Ajax. And VERY little user javascript. + +=head1 EXAMPLES + +The CGI::Ajax module allows a Perl subroutine to be called +asynchronously, when triggered from a javascript event on the +HTML page. To do this, the subroutine must be I, +usually done during: + + my $pjx = new CGI::Ajax( 'JSFUNC' => \&PERLFUNC ); + +This maps a perl subroutine (PERLFUNC) to an automatically +generated Javascript function (JSFUNC). Next you setup a trigger this +function when an event occurs (e.g. "onClick"): + + onClick="JSFUNC(['source1','source2'], ['dest1','dest2']);" + +where 'source1', 'dest1', 'source2', 'dest2' are the DIV ids of +HTML elements in your page... + + + +
+
+ +L sends the values from source1 and source2 to your +Perl subroutine and returns the results to dest1 and dest2. + +=head2 4 Usage Methods + +=over 4 + +=item 1 Standard CGI::Ajax example + +Start by defining a perl subroutine that you want available from +javascript. In this case we'll define a subrouting that determines +whether or not an input is odd, even, or not a number (NaN): + + use strict; + use CGI::Ajax; + use CGI; + + + sub evenodd_func { + my $input = shift; + + # see if input is defined + if ( not defined $input ) { + return("input not defined or NaN"); + } + + # see if value is a number (*thanks Randall!*) + if ( $input !~ /\A\d+\z/ ) { + return("input is NaN"); + } + + # got a number, so mod by 2 + $input % 2 == 0 ? return("EVEN") : return("ODD"); + } + +Alternatively, we could have used coderefs to associate an +exported name... + + my $evenodd_func = sub { + # exactly the same as in the above subroutine + }; + +Next we define a function to generate the web page - this can +be done many different ways, and can also be defined as an +anonymous sub. The only requirement is that the sub send back +the html of the page. You can do this via a string containing the +html, or from a coderef that returns the html, or from a function +(as shown here)... + + sub Show_HTML { + my $html = < + CGI::Ajax Example + + + Enter a number:  + +
+
+
+
+ + +EOT + return $html; + } + +The exported Perl subrouting is triggered using the C +event handler of the input HTML element. The subroutine takes one +value from the form, the input element B<'val1'>, and returns the +the result to an HTML div element with an id of B<'resultdiv'>. +Sending in the input id in an array format is required to support +multiple inputs, and similarly, to output multiple the results, +you can use an array for the output divs, but this isn't mandatory - +as will be explained in the B usage. + +Now create a CGI object and a CGI::Ajax object, associating a reference +to our subroutine with the name we want available to javascript. + + my $cgi = new CGI(); + my $pjx = new CGI::Ajax( 'evenodd' => \&evenodd_func ); + +And if we used a coderef, it would look like this... + + my $pjx = new CGI::Ajax( 'evenodd' => $evenodd_func ); + +Now we're ready to print the output page; we send in the cgi +object and the HTML-generating function. + + print $pjx->build_html($cgi,\&Show_HTML); + +CGI::Ajax has support for passing in extra HTML header information +to the CGI object. This can be accomplished by adding a third +argument to the build_html() call. The argument needs to be a +hashref containing Key=>value pairs that CGI objects understand: + + print $pjx->build_html($cgi,\&Show_HTML, + {-charset=>'UTF-8, -expires=>'-1d'}); + +See L for more header() method options. + +That's it for the CGI::Ajax standard method. Let's look at +something more advanced. + +=item 2 Advanced CGI::Ajax example + +Let's say we wanted to have a perl subroutine process multiple +values from the HTML page, and similarly return multiple values +back to distinct divs on the page. This is easy to do, and +requires no changes to the perl code - you just create it as you +would any perl subroutine that works with multiple input values +and returns multiple values. The significant change happens in +the event handler javascript in the HTML... + + onClick="exported_func(['input1','input2'],['result1','result2']);" + +Here we associate our javascript function ("exported_func") with +two HTML element ids ('input1','input2'), and also send in two +HTML element ids to place the results in ('result1','result2'). + +=item 3 Sending Perl Subroutine Output to a Javascript function + +Occassionally, you might want to have a custom javascript function +process the returned information from your Perl subroutine. +This is possible, and the only requierment is that you change +your event handler code... + + onClick="exported_func(['input1'],[js_process_func]);" + +In this scenario, C is a javascript function you +write to take the returned value from your Perl subroutine and +process the results. I Beware that with this usage, B. If the exported Perl subroutine returns, e.g. 2 +values, then C would need to process the input +by working through an array, or using the javascript Function +C object. + + function js_process_func() { + var input1 = arguments[0] + var input2 = arguments[1]; + // do something and return results, or set HTML divs using + // innerHTML + document.getElementById('outputdiv').innerHTML = input1; + } + +=item 4 URL/Outside Script CGI::Ajax example + +There are times when you may want a different script to +return content to your page. This could be because you have +an existing script already written to perform a particular +task, or you want to distribute a part of your application to another +script. This can be accomplished in L by using a URL in +place of a locally-defined Perl subroutine. In this usage, +you alter you creation of the L object to link an +exported javascript function name to a local URL instead of +a coderef or a subroutine. + + my $url = 'scripts/other_script.pl'; + my $pjx = new CGI::Ajax( 'external' => $url ); + +This will work as before in terms of how it is called from you +event handler: + + onClick="external(['input1','input2'],['resultdiv']);" + +The other_script.pl will get the values via a CGI object and +accessing the 'args' key. The values of the B<'args'> key will +be an array of everything that was sent into the script. + + my @input = $cgi->params('args'); + $input[0]; # contains first argument + $input[1]; # contains second argument, etc... + +This is good, but what if you need to send in arguments to the +other script which are directly from the calling Perl script, +i.e. you want a calling Perl script's variable to be sent, not +the value from an HTML element on the page? This is possible +using the following syntax: + + onClick="exported_func(['args__$input1','args__$input2'], + ['resultdiv']);" + +Similary, if the external script required a constant as input +(e.g. C, you would use this syntax: + + onClick="exported_func(['args__42'],['resultdiv']);" + +In both of the above examples, the result from the external +script would get placed into the I element on our +(the calling script's) page. + +If you are sending more than one argument from an external perl +script back to a javascript function, you will need to split the +string (AJAX applications communicate in strings only) on something. +Internally, we use '__pjx__', and this string is checked for. If +found, L will automatically split it. However, if you +don't want to use '__pjx__', you can do it yourself: + +For example, from your Perl script, you would... + + return("A|B"); # join with "|" + +and then in the javascript function you would have something like... + + process_func() { + var arr = arguments[0].split("|"); + // arr[0] eq 'A' + // arr[1] eq 'B' + } + +In order to rename parameters, in case the outside script needs +specifically-named parameters and not CGI::Ajax' I<'args'> default +parameter name, change your event handler associated with an HTML +event like this + + onClick="exported_func(['myname__$input1','myparam__$input2'], + ['resultdiv']);" + +The URL generated would look like this... + +C + +You would then retrieve the input in the outside script with this... + + my $p1 = $cgi->params('myname'); + my $p1 = $cgi->params('myparam'); + +Finally, what if we need to get a value from our HTML page and we +want to send that value to an outside script but the outside script +requires a named parameter different from I<'args'>? You can +accomplish this with L using the getVal() javascript +method (which returns an array, thus the C notation): + + onClick="exported_func(['myparam__' + getVal('div_id')[0]], + ['resultdiv']);" + +This will get the value of our HTML element with and +I of I, and submit it to the url attached to +I. So if our exported handler referred to a URI +called I'; + return $rv; +} + +## new +sub new { + my ($class) = shift; + my $self = bless ({}, ref ($class) || $class); +# $self->SUPER::new(); + $self->JSDEBUG(0); # turn javascript debugging off (if on, + # extra info will be added to the web page output + # if set to 1, then the core js will get + # compressed, but the user-defined functions will + # not be compressed. If set to 2 (or anything + # greater than 1 or 0), then none of the + # javascript will get compressed. + # + $self->DEBUG(0); # turn debugging off (if on, check web logs) + + #accessorized attributes + $self->coderef_list({}); + $self->url_list({}); + #$self->html(""); + #$self->cgi(); + #$self->cgi_header_extra(""); # set cgi_header_extra to an empty string + + # setup a default endcoding; if you need support for international + # charsets, use 'escape' instead of encodeURIComponent. Due to the + # number of browser problems users report about scripts with a default of + # encodeURIComponent, we are setting the default to 'escape' + $self->js_encode_function('escape'); + + if ( @_ < 2 ) { + die "incorrect usage: must have fn=>code pairs in new\n"; + } + + while ( @_ ) { + my($function_name,$code) = splice( @_, 0, 2 ); + if ( ref( $code ) eq "CODE" ) { + if ( $self->DEBUG() ) { + print STDERR "name = $function_name, code = $code\n"; + } + # add the name/code to hash + $self->coderef_list()->{ $function_name } = $code; + } elsif ( ref($code) ) { + die "Unsuported code block/url\n"; + } else { + if ( $self->DEBUG() ) { + print STDERR "Setting function $function_name to url $code\n"; + } + # if it's a url, it is added here + $self->url_list()->{ $function_name } = $code; + } + } + return ($self); +} + +###################################################### +## METHODS - private ## +###################################################### + +# sub cgiobj(), cgi() +# +# Purpose: accessor method to associate a CGI object with our +# CGI::Ajax object +# Arguments: a CGI object +# Returns: CGI::Ajax objects cgi object +# Called By: originating cgi script, or build_html() +# +sub cgiobj { + my $self = shift; + # see if any values were sent in... + if ( @_ ) { + my $cgi = shift; + # add support for other CGI::* modules This requires that your web server + # be configured properly. I can't test anything but a mod_perl2 + # setup, so this prevents me from testing CGI::Lite,CGI::Simple, etc. + if ( ref($cgi) =~ /CGI.*/ ) { + if ( $self->DEBUG() ) { + print STDERR "cgiobj() received a CGI-like object ($cgi)\n"; + } + $self->{'cgi'} = $cgi; + } else { + die "CGI::Ajax -- Can't set internal CGI object to a non-CGI object ($cgi)\n"; + } + } + # return the object + return( $self->{'cgi'} ); +} + +sub cgi { + my $self = shift; + if ( @_ ) { + return( $self->cgiobj( @_ ) ); + } else { + return( $self->cgiobj() ); + } +} + +## # sub cgi_header_extra +## # +## # Purpose: accessor method to associate CGI header information +## # with the CGI::Ajax object +## # Arguments: a hashref with key=>value pairs that get handed off to +## # the CGI object's header() method +## # Returns: hashref of extra cgi header params +## # Called By: originating cgi script, or build_html() +## +## sub cgi_header_extra { +## my $self = shift; +## if ( @_ ) { +## $self->{'cgi_header_extra'} = shift; +## } +## return( $self->{'cgi_header_extra'} ); +## } + +# sub create_js_setRequestHeader +# +# Purpose: create text of the header for the javascript side, +# xmlhttprequest call +# Arguments: none +# Returns: text of header to pass to xmlhttpreq call so it will +# match whatever was setup for the main web-page +# Called By: originating cgi script, or build_html() +# + +sub create_js_setRequestHeader { + my $self = shift; + my $cgi_header_extra = $self->cgi_header_extra(); + my $js_header_string = q{r.setRequestHeader("}; + #$js_header_string .= $self->cgi()->header( $cgi_header_extra ); + $js_header_string .= $self->cgi()->header(); + $js_header_string .= q{");}; + #if ( ref $cgi_header_extra eq "HASH" ) { + # foreach my $k ( keys(%$cgi_header_extra) ) { + # $js_header_string .= $self->cgi()->header($cgi_headers) + # } + #} else { + #print STDERR $self->cgi()->header($cgi_headers) ; + + if ( $self->DEBUG() ) { + print STDERR "js_header_string is (", $js_header_string, ")\n"; + } + + return($js_header_string); +} + +# sub show_common_js() +# +# Purpose: create text of the javascript needed to interface with +# the perl functions +# Arguments: none +# Returns: text of common javascript subroutine, 'do_http_request' +# Called By: originating cgi script, or build_html() +# + +sub show_common_js { + my $self = shift; + my $encodefn = $self->js_encode_function(); + my $decodefn = $encodefn; + $decodefn =~ s/^(en)/de/; + $decodefn =~ s/^(esc)/unesc/; + #my $request_header_str = $self->create_js_setRequestHeader(); + my $request_header_str = ""; + my $rv = <
";
+    for( var i=0; i < ajax.length; i++ ) {
+      tmp += '' +
+      decodeURI(ajax[i].url) + ' 
';
+    }
+    document.getElementById('pjxdebugrequest').innerHTML = tmp + "
"; +} + +EOT + + if ( $self->JSDEBUG() <= 1 ) { + $rv = $self->compress_js($rv); + } + + return($rv); +} + +# sub compress_js() +# +# Purpose: searches the javascript for newlines and spaces and +# removes them (if a newline) or shrinks them to a single (if +# space). +# Arguments: javascript to compress +# Returns: compressed js string +# Called By: show_common_js(), +# + +sub compress_js { + my($self,$js) = @_; + return if not defined $js; + return if $js eq ""; + $js =~ s/\n//g; # drop newlines + $js =~ s/\s+/ /g; # replace 1+ spaces with just one space + return $js; +} + + +# sub insert_js_in_head() +# +# Purpose: searches the html value in the CGI::Ajax object and inserts +# the ajax javascript code in the section, +# or if no such section exists, then it creates it. If +# JSDEBUG is set, then an extra div will be added and the +# url wil be desplayed as a link +# Arguments: none +# Returns: none +# Called By: build_html() +# + +sub insert_js_in_head{ + my $self = shift; + my $mhtml = $self->html(); + my $newhtml; + my @shtml; + my $js = $self->show_javascript(); + + if ( $self->JSDEBUG() ) { + my $showurl=qq!

!; + # find the terminal so we can insert just before it + my @splith = $mhtml =~ /(.*)(<\s*\/\s*body[^>]*>?)(.*)/is; + $mhtml = $splith[0].$showurl.$splith[1].$splith[2]; + } + + # see if we can match on + @shtml= $mhtml =~ /(.*)(<\s*head[^>]*>?)(.*)/is; + if ( @shtml ) { + # yes, there's already a , so let's insert inside it, + # at the beginning + $newhtml = $shtml[0].$shtml[1].$js.$shtml[2]; + } elsif( @shtml= $mhtml =~ /(.*)(<\s*html[^>]*>?)(.*)/is){ + # there's no , so look for the tag, and insert out + # javascript inside that tag + $newhtml = $shtml[0].$shtml[1].$js.$shtml[2]; + } else { + $newhtml .= ""; + $newhtml .= $js; + $newhtml .= ""; + $newhtml .= "No head/html tags, nowhere to insert. Returning javascript anyway
"; + $newhtml .= ""; + } + $self->html($newhtml); + return; +} + +# sub handle_request() +# +# Purpose: makes sure a fname function name was set in the CGI +# object, and then tries to eval the function with +# parameters sent in on args +# Arguments: none +# Returns: the result of the perl subroutine, as text; if multiple +# arguments are sent back from the defined, exported perl +# method, then join then with a connector (__pjx__). +# Called By: build_html() +# + +sub handle_request { + my ($self) = shift; + + my $result; # $result takes the output of the function, if it's an + # array split on __pjx__ + my @other = (); # array for catching extra parameters + + # we need to access "fname" in the form from the web page, so make + # sure there is a CGI object defined + return undef unless defined $self->cgi(); + + my $rv = ""; + if ( $self->cgi()->can('header') ) { + $rv = $self->cgi()->header( $self->cgi_header_extra() ); + } else { + # don't have an object with a "header()" method, so just create + # a mimimal one + $rv = "Content-Type: text/html;"; + # TODO: + $rv .= $self->cgi_header_extra(); + $rv .= "\n\n"; + } + + # get the name of the function + my $func_name = $self->cgi()->param("fname"); + + # check if the function name was created + if ( defined $self->coderef_list()->{$func_name} ) { + my $code = $self->coderef_list()->{$func_name}; + + # eval the code from the coderef, and append the output to $rv + if ( ref($code) eq "CODE" ) { + eval { ($result, @other) = $code->( $self->cgi()->param("args") ) }; + + if ($@) { + # see if the eval caused and error and report it + # Should we be more severe and die? + if ( $self->DEBUG() ) { + print STDERR "Problem with code: $@\n"; + } + } + + if( @other ) { + $rv .= join( "__pjx__", ($result, @other) ); + if ( $self->DEBUG() ) { + print STDERR "rv = $rv\n"; + } + } else { + if ( defined $result ) { + $rv .= $result; + } + } + + } # end if ref = CODE + } else { + # # problems with the URL, return a CGI rrror + print STDERR "POSSIBLE SECURITY INCIDENT! Browser from ", $self->cgi()->remote_addr(); + print STDERR "\trequested URL: ", $self->cgi()->url(); + print STDERR "\tfname request: ", $self->cgi()->param('fname'); + print STDERR " -- returning Bad Request status 400\n"; + if ( $self->cgi()->can('header') ) { + return($self->cgi()->header( -status=>'400' )); + } else { + # don't have an object with a "header()" method, so just create + # a mimimal one with 400 error + $rv = "Status: 400\nContent-Type: text/html;\n\n"; + } + } + return $rv; +} + + +# sub make_function() +# +# Purpose: creates the javascript wrapper for the underlying perl +# subroutine +# Arguments: CGI object from web form, and the name of the perl +# function to export to javascript, or a url if the +# function name refers to another cgi script +# Returns: text of the javascript-wrapped perl subroutine +# Called By: show_javascript; called once for each registered perl +# subroutine +# + +sub make_function { + my ($self, $func_name ) = @_; + return("") if not defined $func_name; + return("") if $func_name eq ""; + my $rv = ""; + my $script = $0 || $ENV{SCRIPT_FILENAME}; + $script =~ s/.*[\/|\\](.+)$/$1/; + my $outside_url = $self->url_list()->{ $func_name }; + my $url = defined $outside_url ? $outside_url : $script; + if ($url =~ /\?/) { $url.='&'; } else {$url.='?'} + $url = "'$url'"; + my $jsdebug = ""; + if ( $self->JSDEBUG()) { + $jsdebug = "jsdebug()"; + } + + #create the javascript text + $rv .= <JSDEBUG() ) { + $rv = $self->compress_js($rv); + } + return $rv; +} + +=item register() + + Purpose: adds a function name and a code ref to the global coderef + hash, after the original object was created + Arguments: function name, code reference + Returns: none + Called By: originating web script + +=cut + +sub register { + my ( $self, $fn, $coderef ) = @_; + # coderef_list() is a Class::Accessor function + # url_list() is a Class::Accessor function + if ( ref( $coderef ) eq "CODE" ) { + $self->coderef_list()->{$fn} = $coderef; + } elsif ( ref($coderef) ) { + die "Unsupported code/url type - error\n"; + } else { + $self->url_list()->{$fn} = $coderef; + } +} + +=item JSDEBUG() + + Purpose: Show the AJAX URL that is being generated, and stop + compression of the generated javascript, both of which can aid + during debugging. If set to 1, then the core js will get + compressed, but the user-defined functions will not be + compressed. If set to 2 (or anything greater than 1 or 0), + then none of the javascript will get compressed. + + Arguments: JSDEBUG(0); # turn javascript debugging off + JSDEBUG(1); # turn javascript debugging on, some javascript compression + JSDEBUG(2); # turn javascript debugging on, no javascript compresstion + Returns: prints a link to the url that is being generated automatically by + the Ajax object. this is VERY useful for seeing what + CGI::Ajax is doing. Following the link, will show a page + with the output that the page is generating. + + Called By: $pjx->JSDEBUG(1) # where $pjx is a CGI::Ajax object; + +=item DEBUG() + + Purpose: Show debugging information in web server logs + Arguments: DEBUG(0); # turn debugging off (default) + DEBUG(1); # turn debugging on + Returns: prints debugging information to the web server logs using + STDERR + Called By: $pjx->DEBUG(1) # where $pjx is a CGI::Ajax object; + +=back + +=head1 BUGS + +Follow any bugs at our homepage.... + + http://www.perljax.us + +=head1 SUPPORT + +Check out the news/discussion/bugs lists at our homepage: + + http://www.perljax.us + +=head1 AUTHORS + + Brian C. Thomas Brent Pedersen + CPAN ID: BCT + bct.x42@gmail.com bpederse@gmail.com + +=head1 A NOTE ABOUT THE MODULE NAME + +This module was initiated using the name "Perljax", but then +registered with CPAN under the WWW group "CGI::", and so became +"CGI::Perljax". Upon further deliberation, we decided to change it's +name to L. + +=head1 COPYRIGHT + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=head1 SEE ALSO + +L +L +L + +=cut + +1; +__END__ diff --git a/modules/fallback/CGI/LICENSE b/modules/fallback/CGI/LICENSE new file mode 100644 index 000000000..9d0305b3f --- /dev/null +++ b/modules/fallback/CGI/LICENSE @@ -0,0 +1,383 @@ +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" + +--------------------------------------------------------------------------- + +The General Public License (GPL) +Version 2, June 1991 + +Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, +Cambridge, MA 02139, 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 Library 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. Aggregation of this Package with a commercial distribution is always permitted +provided that the use of this Package is embedded; that is, when no overt attempt +is made to make this Package's interfaces visible to the end user of the +commercial distribution. Such use shall not be construed as a distribution of +this Package. + +9. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +10. 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 + + diff --git a/modules/fallback/CGI/README b/modules/fallback/CGI/README new file mode 100644 index 000000000..1af8860c6 --- /dev/null +++ b/modules/fallback/CGI/README @@ -0,0 +1,41 @@ +pod2text CGI::Perljax.pm > README + +CGI::Perljax + +Perljax - a perl-specific system for writing AJAX- or +DHTML-based web applications. + + +Perljax provides a unique mechanism for using perl code +asynchronously from javascript using AJAX to access user-written +perl functions/methods. Perljax unburdens the user from having to +write any javascript, except for having to associate an exported +method with a document-defined event (such as onClick, onKeyUp, +etc). Only in the more advanced implementations of a exported perl +method would a user need to write custom javascript. Perljax supports +methods that return single results, or multiple results to the web +page. No other projects that we know of are like Perljax for the +following reasons: 1. Perljax is targeted specifically for perl +development. 2. Perljax shields the user from having to write any +javascript at all (unless they want to). 3. The URL for the HTTP GET +request is automatically generated based on HTML layout and events, +and the page is then dynamically updated. 4. Perljax is not part +of a Content Management System, or some other larger project. + + +INSTALL + +perl Makefile.PL +make +make test +make install + +*If you are on a windows box you should use 'nmake' rather than 'make'. + +Installation will place Perljax into the system perl @INC path, but it +is important that you make sure mod_perl uses this path (which is +mod_perl's default behavior, and also assuming you use mod_perl, and +not just run perl as a CGI). + +Example scripts are provided in the source script directory, and can +also be seen on the project's website, http://www.perljax.us. diff --git a/modules/override/README b/modules/override/README new file mode 100644 index 000000000..0fbb2fd09 --- /dev/null +++ b/modules/override/README @@ -0,0 +1,611 @@ +NAME + YAML - YAML Ain't Markup Language (tm) + +SYNOPSIS + use YAML; + + # Load a YAML stream of 3 YAML documents into Perl data structures. + my ($hashref, $arrayref, $string) = Load(<<'...'); + --- + name: ingy + age: old + weight: heavy + # I should comment that I also like pink, but don't tell anybody. + favorite colors: + - red + - green + - blue + --- + - Clark Evans + - Oren Ben-Kiki + - Ingy döt Net + --- > + You probably think YAML stands for "Yet Another Markup Language". It + ain't! YAML is really a data serialization language. But if you want + to think of it as a markup, that's OK with me. A lot of people try + to use XML as a serialization format. + + "YAML" is catchy and fun to say. Try it. "YAML, YAML, YAML!!!" + ... + + # Dump the Perl data structures back into YAML. + print Dump($string, $arrayref, $hashref); + + # YAML::Dump is used the same way you'd use Data::Dumper::Dumper + use Data::Dumper; + print Dumper($string, $arrayref, $hashref); + +DESCRIPTION + The YAML.pm module implements a YAML Loader and Dumper based on the YAML + 1.0 specification. + + YAML is a generic data serialization language that is optimized for + human readability. It can be used to express the data structures of most + modern programming languages. (Including Perl!!!) + + For information on the YAML syntax, please refer to the YAML + specification. + +WHY YAML IS COOL + YAML is readable for people. + It makes clear sense out of complex data structures. You should find + that YAML is an exceptional data dumping tool. Structure is shown + through indentation, YAML supports recursive data, and hash keys are + sorted by default. In addition, YAML supports several styles of + scalar formatting for different types of data. + + YAML is editable. + YAML was designed from the ground up to be an excellent syntax for + configuration files. Almost all programs need configuration files, + so why invent a new syntax for each one? And why subject users to + the complexities of XML or native Perl code? + + YAML is multilingual. + Yes, YAML supports Unicode. But I'm actually referring to + programming languages. YAML was designed to meet the serialization + needs of Perl, Python, Ruby, Tcl, PHP, Javascript and Java. It was + also designed to be interoperable between those languages. That + means YAML serializations produced by Perl can be processed by + Python. + + YAML is taint safe. + Using modules like Data::Dumper for serialization is fine as long as + you can be sure that nobody can tamper with your data files or + transmissions. That's because you need to use Perl's "eval()" + built-in to deserialize the data. Somebody could add a snippet of + Perl to erase your files. + + YAML's parser does not need to eval anything. + + YAML is full featured. + YAML can accurately serialize all of the common Perl data structures + and deserialize them again without losing data relationships. + Although it is not 100% perfect (no serializer is or can be + perfect), it fares as well as the popular current modules: + Data::Dumper, Storable, XML::Dumper and Data::Denter. + + YAML.pm also has the ability to handle code (subroutine) references + and typeglobs. (Still experimental) These features are not found in + Perl's other serialization modules. + + YAML is extensible. + The YAML language has been designed to be flexible enough to solve + it's own problems. The markup itself has 3 basic construct which + resemble Perl's hash, array and scalar. By default, these map to + their Perl equivalents. But each YAML node also supports a tagging + mechanism (type system) which can cause that node to be interpreted + in a completely different manner. That's how YAML can support object + serialization and oddball structures like Perl's typeglob. + +YAML IMPLEMENTATIONS IN PERL + This module, YAML.pm, is really just the interface module for YAML + modules written in Perl. The basic interface for YAML consists of two + functions: "Dump" and "Load". The real work is done by the modules + YAML::Dumper and YAML::Loader. + + Different YAML module distributions can be created by subclassing + YAML.pm and YAML::Loader and YAML::Dumper. For example, YAML-Simple + consists of YAML::Simple YAML::Dumper::Simple and YAML::Loader::Simple. + + Why would there be more than one implementation of YAML? Well, despite + YAML's offering of being a simple data format, YAML is actually very + deep and complex. Implementing the entirety of the YAML specification is + a daunting task. + + For this reason I am currently working on 3 different YAML + implementations. + + YAML + The main YAML distribution will keeping evolving to support the + entire YAML specification in pure Perl. This may not be the fastest + or most stable module though. Currently, YAML.pm has lots of known + bugs. It is mostly a great tool for dumping Perl data structures to + a readable form. + + YAML::Lite + The point of YAML::Lite is to strip YAML down to the 90% that people + use most and offer that in a small, fast, stable, pure Perl form. + YAML::Lite will simply die when it is asked to do something it + can't. + + YAML::Syck + "libsyck" is the C based YAML processing library used by the Ruby + programming language (and also Python, PHP and Pugs). YAML::Syck is + the Perl binding to "libsyck". It should be very fast, but may have + problems of its own. It will also require C compilation. + + NOTE: Audrey Tang has actually completed this module and it works + great and is 10 times faster than YAML.pm. + + In the future, there will likely be even more YAML modules. Remember, + people other than Ingy are allowed to write YAML modules! + +FUNCTIONAL USAGE + YAML is completely OO under the hood. Still it exports a few useful top + level functions so that it is dead simple to use. These functions just + do the OO stuff for you. If you want direct access to the OO API see the + documentation for YAML::Dumper and YAML::Loader. + + Exported Functions + The following functions are exported by YAML.pm by default. The reason + they are exported is so that YAML works much like Data::Dumper. If you + don't want functions to be imported, just use YAML with an empty import + list: + + use YAML (); + + Dump(list-of-Perl-data-structures) + Turn Perl data into YAML. This function works very much like + Data::Dumper::Dumper(). It takes a list of Perl data strucures and + dumps them into a serialized form. It returns a string containing + the YAML stream. The structures can be references or plain scalars. + + Load(string-containing-a-YAML-stream) + Turn YAML into Perl data. This is the opposite of Dump. Just like + Storable's thaw() function or the eval() function in relation to + Data::Dumper. It parses a string containing a valid YAML stream into + a list of Perl data structures. + + Exportable Functions + These functions are not exported by default but you can request them in + an import list like this: + + use YAML qw'freeze thaw Bless'; + + freeze() and thaw() + Aliases to Dump() and Load() for Storable fans. This will also allow + YAML.pm to be plugged directly into modules like POE.pm, that use + the freeze/thaw API for internal serialization. + + DumpFile(filepath, list) + Writes the YAML stream to a file instead of just returning a string. + + LoadFile(filepath) + Reads the YAML stream from a file instead of a string. + + Bless(perl-node, [yaml-node | class-name]) + Associate a normal Perl node, with a yaml node. A yaml node is an + object tied to the YAML::Node class. The second argument is either a + yaml node that you've already created or a class (package) name that + supports a yaml_dump() function. A yaml_dump() function should take + a perl node and return a yaml node. If no second argument is + provided, Bless will create a yaml node. This node is not returned, + but can be retrieved with the Blessed() function. + + Here's an example of how to use Bless. Say you have a hash + containing three keys, but you only want to dump two of them. + Furthermore the keys must be dumped in a certain order. Here's how + you do that: + + use YAML qw(Dump Bless); + $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; + print Dump $hash; + Bless($hash)->keys(['banana', 'apple']); + print Dump $hash; + + produces: + + --- + apple: good + banana: bad + cauliflower: ugly + --- + banana: bad + apple: good + + Bless returns the tied part of a yaml-node, so that you can call the + YAML::Node methods. This is the same thing that YAML::Node::ynode() + returns. So another way to do the above example is: + + use YAML qw(Dump Bless); + use YAML::Node; + $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; + print Dump $hash; + Bless($hash); + $ynode = ynode(Blessed($hash)); + $ynode->keys(['banana', 'apple']); + print Dump $hash; + + Note that Blessing a Perl data structure does not change it anyway. + The extra information is stored separately and looked up by the + Blessed node's memory address. + + Blessed(perl-node) + Returns the yaml node that a particular perl node is associated with + (see above). Returns undef if the node is not (YAML) Blessed. + +GLOBAL OPTIONS + YAML options are set using a group of global variables in the YAML + namespace. This is similar to how Data::Dumper works. + + For example, to change the indentation width, do something like: + + local $YAML::Indent = 3; + + The current options are: + + DumperClass + You can override which module/class YAML uses for Dumping data. + + LoaderClass + You can override which module/class YAML uses for Loading data. + + Indent + This is the number of space characters to use for each indentation + level when doing a Dump(). The default is 2. + + By the way, YAML can use any number of characters for indentation at + any level. So if you are editing YAML by hand feel free to do it + anyway that looks pleasing to you; just be consistent for a given + level. + + SortKeys + Default is 1. (true) + + Tells YAML.pm whether or not to sort hash keys when storing a + document. + + YAML::Node objects can have their own sort order, which is usually + what you want. To override the YAML::Node order and sort the keys + anyway, set SortKeys to 2. + + Stringify + Default is 0. (false) + + Objects with string overloading should honor the overloading and + dump the stringification of themselves, rather than the actual + object's guts. + + UseHeader + Default is 1. (true) + + This tells YAML.pm whether to use a separator string for a Dump + operation. This only applies to the first document in a stream. + Subsequent documents must have a YAML header by definition. + + UseVersion + Default is 0. (false) + + Tells YAML.pm whether to include the YAML version on the + separator/header. + + --- %YAML:1.0 + + AnchorPrefix + Default is ''. + + Anchor names are normally numeric. YAML.pm simply starts with '1' + and increases by one for each new anchor. This option allows you to + specify a string to be prepended to each anchor number. + + UseCode + Setting the UseCode option is a shortcut to set both the DumpCode + and LoadCode options at once. Setting UseCode to '1' tells YAML.pm + to dump Perl code references as Perl (using B::Deparse) and to load + them back into memory using eval(). The reason this has to be an + option is that using eval() to parse untrusted code is, well, + untrustworthy. + + DumpCode + Determines if and how YAML.pm should serialize Perl code references. + By default YAML.pm will dump code references as dummy placeholders + (much like Data::Dumper). If DumpCode is set to '1' or 'deparse', + code references will be dumped as actual Perl code. + + DumpCode can also be set to a subroutine reference so that you can + write your own serializing routine. YAML.pm passes you the code ref. + You pass back the serialization (as a string) and a format + indicator. The format indicator is a simple string like: 'deparse' + or 'bytecode'. + + LoadCode + LoadCode is the opposite of DumpCode. It tells YAML if and how to + deserialize code references. When set to '1' or 'deparse' it will + use "eval()". Since this is potentially risky, only use this option + if you know where your YAML has been. + + LoadCode can also be set to a subroutine reference so that you can + write your own deserializing routine. YAML.pm passes the + serialization (as a string) and a format indicator. You pass back + the code reference. + + UseBlock + YAML.pm uses heuristics to guess which scalar style is best for a + given node. Sometimes you'll want all multiline scalars to use the + 'block' style. If so, set this option to 1. + + NOTE: YAML's block style is akin to Perl's here-document. + + UseFold + If you want to force YAML to use the 'folded' style for all + multiline scalars, then set $UseFold to 1. + + NOTE: YAML's folded style is akin to the way HTML folds text, except + smarter. + + UseAliases + YAML has an alias mechanism such that any given structure in memory + gets serialized once. Any other references to that structure are + serialized only as alias markers. This is how YAML can serialize + duplicate and recursive structures. + + Sometimes, when you KNOW that your data is nonrecursive in nature, + you may want to serialize such that every node is expressed in full. + (ie as a copy of the original). Setting $YAML::UseAliases to 0 will + allow you to do this. This also may result in faster processing + because the lookup overhead is by bypassed. + + THIS OPTION CAN BE DANGEROUS. *If* your data is recursive, this + option *will* cause Dump() to run in an endless loop, chewing up + your computers memory. You have been warned. + + CompressSeries + Default is 1. + + Compresses the formatting of arrays of hashes: + + - + foo: bar + - + bar: foo + + becomes: + + - foo: bar + - bar: foo + + Since this output is usually more desirable, this option is turned + on by default. + +YAML TERMINOLOGY + YAML is a full featured data serialization language, and thus has its + own terminology. + + It is important to remember that although YAML is heavily influenced by + Perl and Python, it is a language in its own right, not merely just a + representation of Perl structures. + + YAML has three constructs that are conspicuously similar to Perl's hash, + array, and scalar. They are called mapping, sequence, and string + respectively. By default, they do what you would expect. But each + instance may have an explicit or implicit tag (type) that makes it + behave differently. In this manner, YAML can be extended to represent + Perl's Glob or Python's tuple, or Ruby's Bigint. + + stream + A YAML stream is the full sequence of unicode characters that a YAML + parser would read or a YAML emitter would write. A stream may + contain one or more YAML documents separated by YAML headers. + + --- + a: mapping + foo: bar + --- + - a + - sequence + + document + A YAML document is an independent data structure representation + within a stream. It is a top level node. Each document in a YAML + stream must begin with a YAML header line. Actually the header is + optional on the first document. + + --- + This: top level mapping + is: + - a + - YAML + - document + + header + A YAML header is a line that begins a YAML document. It consists of + three dashes, possibly followed by more info. Another purpose of the + header line is that it serves as a place to put top level tag and + anchor information. + + --- !recursive-sequence &001 + - * 001 + - * 001 + + node + A YAML node is the representation of a particular data stucture. + Nodes may contain other nodes. (In Perl terms, nodes are like + scalars. Strings, arrayrefs and hashrefs. But this refers to the + serialized format, not the in-memory structure.) + + tag This is similar to a type. It indicates how a particular YAML node + serialization should be transferred into or out of memory. For + instance a Foo::Bar object would use the tag 'perl/Foo::Bar': + + - !perl/Foo::Bar + foo: 42 + bar: stool + + collection + A collection is the generic term for a YAML data grouping. YAML has + two types of collections: mappings and sequences. (Similar to hashes + and arrays) + + mapping + A mapping is a YAML collection defined by unordered key/value pairs + with unique keys. By default YAML mappings are loaded into Perl + hashes. + + a mapping: + foo: bar + two: times two is 4 + + sequence + A sequence is a YAML collection defined by an ordered list of + elements. By default YAML sequences are loaded into Perl arrays. + + a sequence: + - one bourbon + - one scotch + - one beer + + scalar + A scalar is a YAML node that is a single value. By default YAML + scalars are loaded into Perl scalars. + + a scalar key: a scalar value + + YAML has many styles for representing scalars. This is important + because varying data will have varying formatting requirements to + retain the optimum human readability. + + plain scalar + A plain sclar is unquoted. All plain scalars are automatic + candidates for "implicit tagging". This means that their tag may be + determined automatically by examination. The typical uses for this + are plain alpha strings, integers, real numbers, dates, times and + currency. + + - a plain string + - -42 + - 3.1415 + - 12:34 + - 123 this is an error + + single quoted scalar + This is similar to Perl's use of single quotes. It means no escaping + except for single quotes which are escaped by using two adjacent + single quotes. + + - 'When I say ''\n'' I mean "backslash en"' + + double quoted scalar + This is similar to Perl's use of double quotes. Character escaping + can be used. + + - "This scalar\nhas two lines, and a bell -->\a" + + folded scalar + This is a multiline scalar which begins on the next line. It is + indicated by a single right angle bracket. It is unescaped like the + single quoted scalar. Line folding is also performed. + + - > + This is a multiline scalar which begins on + the next line. It is indicated by a single + carat. It is unescaped like the single + quoted scalar. Line folding is also + performed. + + block scalar + This final multiline form is akin to Perl's here-document except + that (as in all YAML data) scope is indicated by indentation. + Therefore, no ending marker is required. The data is verbatim. No + line folding. + + - | + QTY DESC PRICE TOTAL + --- ---- ----- ----- + 1 Foo Fighters $19.95 $19.95 + 2 Bar Belles $29.95 $59.90 + + parser + A YAML processor has four stages: parse, load, dump, emit. + + A parser parses a YAML stream. YAML.pm's Load() function contains a + parser. + + loader + The other half of the Load() function is a loader. This takes the + information from the parser and loads it into a Perl data structure. + + dumper + The Dump() function consists of a dumper and an emitter. The dumper + walks through each Perl data structure and gives info to the + emitter. + + emitter + The emitter takes info from the dumper and turns it into a YAML + stream. + + NOTE: In YAML.pm the parser/loader and the dumper/emitter code are + currently very closely tied together. In the future they may be + broken into separate stages. + + For more information please refer to the immensely helpful YAML + specification available at . + +ysh - The YAML Shell + The YAML distribution ships with a script called 'ysh', the YAML shell. + ysh provides a simple, interactive way to play with YAML. If you type in + Perl code, it displays the result in YAML. If you type in YAML it turns + it into Perl code. + + To run ysh, (assuming you installed it along with YAML.pm) simply type: + + ysh [options] + + Please read the "ysh" documentation for the full details. There are lots + of options. + +BUGS & DEFICIENCIES + If you find a bug in YAML, please try to recreate it in the YAML Shell + with logging turned on ('ysh -L'). When you have successfully reproduced + the bug, please mail the LOG file to the author (ingy@cpan.org). + + WARNING: This is still *ALPHA* code. Well, most of this code has been + around for years... + + BIGGER WARNING: YAML.pm has been slow in the making, but I am committed + to having top notch YAML tools in the Perl world. The YAML team is close + to finalizing the YAML 1.1 spec. This version of YAML.pm is based off of + a very old pre 1.0 spec. In actuality there isn't a ton of difference, + and this YAML.pm is still fairly useful. Things will get much better in + the future. + +RESOURCES + is the mailing + list. This is where the language is discussed and designed. + + is the official YAML website. + + is the YAML 1.0 specification. + + is the official YAML wiki. + +SEE ALSO + See YAML::Syck. Fast! + +AUTHOR + Ingy döt Net + + is resonsible for YAML.pm. + + The YAML serialization language is the result of years of collaboration + between Oren Ben-Kiki, Clark Evans and Ingy döt Net. Several others + have added help along the way. + +COPYRIGHT + Copyright (c) 2005, 2006. Ingy döt Net. All rights reserved. Copyright + (c) 2001, 2002, 2005. Brian Ingerson. All rights reserved. + + This program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + + See + diff --git a/modules/override/YAML.pm b/modules/override/YAML.pm new file mode 100644 index 000000000..3b6aad55a --- /dev/null +++ b/modules/override/YAML.pm @@ -0,0 +1,787 @@ +package YAML; +use strict; use warnings; +use YAML::Base; +use base 'YAML::Base'; +use YAML::Node; # XXX This is a temp fix for Module::Build +use 5.006001; +our $VERSION = '0.62'; +our @EXPORT = qw'Dump Load'; +our @EXPORT_OK = qw'freeze thaw DumpFile LoadFile Bless Blessed'; + +# XXX This VALUE nonsense needs to go. +use constant VALUE => "\x07YAML\x07VALUE\x07"; + +# YAML Object Properties +field dumper_class => 'YAML::Dumper'; +field loader_class => 'YAML::Loader'; +field dumper_object => + -init => '$self->init_action_object("dumper")'; +field loader_object => + -init => '$self->init_action_object("loader")'; + +sub Dump { + my $yaml = YAML->new; + $yaml->dumper_class($YAML::DumperClass) + if $YAML::DumperClass; + return $yaml->dumper_object->dump(@_); +} + +sub Load { + my $yaml = YAML->new; + $yaml->loader_class($YAML::LoaderClass) + if $YAML::LoaderClass; + return $yaml->loader_object->load(@_); +} + +{ + no warnings 'once'; + # freeze/thaw is the API for Storable string serialization. Some + # modules make use of serializing packages on if they use freeze/thaw. + *freeze = \ &Dump; + *thaw = \ &Load; +} + +sub DumpFile { + my $OUT; + my $filename = shift; + if (ref $filename eq 'GLOB') { + $OUT = $filename; + } + else { + my $mode = '>'; + if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) { + ($mode, $filename) = ($1, $2); + } + open $OUT, $mode, $filename + or YAML::Base->die('YAML_DUMP_ERR_FILE_OUTPUT', $filename, $!); + } + local $/ = "\n"; # reset special to "sane" + print $OUT Dump(@_); +} + +sub LoadFile { + my $IN; + my $filename = shift; + if (ref $filename eq 'GLOB') { + $IN = $filename; + } + else { + open $IN, $filename + or YAML::Base->die('YAML_LOAD_ERR_FILE_INPUT', $filename, $!); + } + return Load(do { local $/; <$IN> }); +} + +sub init_action_object { + my $self = shift; + my $object_class = (shift) . '_class'; + my $module_name = $self->$object_class; + eval "require $module_name"; + $self->die("Error in require $module_name - $@") + if $@ and "$@" !~ /Can't locate/; + my $object = $self->$object_class->new; + $object->set_global_options; + return $object; +} + +my $global = {}; +sub Bless { + require YAML::Dumper::Base; + YAML::Dumper::Base::bless($global, @_) +} +sub Blessed { + require YAML::Dumper::Base; + YAML::Dumper::Base::blessed($global, @_) +} +sub global_object { $global } + +1; + +__END__ + +=head1 NAME + +YAML - YAML Ain't Markup Language (tm) + +=head1 SYNOPSIS + + use YAML; + + # Load a YAML stream of 3 YAML documents into Perl data structures. + my ($hashref, $arrayref, $string) = Load(<<'...'); + --- + name: ingy + age: old + weight: heavy + # I should comment that I also like pink, but don't tell anybody. + favorite colors: + - red + - green + - blue + --- + - Clark Evans + - Oren Ben-Kiki + - Ingy döt Net + --- > + You probably think YAML stands for "Yet Another Markup Language". It + ain't! YAML is really a data serialization language. But if you want + to think of it as a markup, that's OK with me. A lot of people try + to use XML as a serialization format. + + "YAML" is catchy and fun to say. Try it. "YAML, YAML, YAML!!!" + ... + + # Dump the Perl data structures back into YAML. + print Dump($string, $arrayref, $hashref); + + # YAML::Dump is used the same way you'd use Data::Dumper::Dumper + use Data::Dumper; + print Dumper($string, $arrayref, $hashref); + +=head1 DESCRIPTION + +The YAML.pm module implements a YAML Loader and Dumper based on the YAML +1.0 specification. L + +YAML is a generic data serialization language that is optimized for +human readability. It can be used to express the data structures of most +modern programming languages. (Including Perl!!!) + +For information on the YAML syntax, please refer to the YAML +specification. + +=head1 WHY YAML IS COOL + +=over 4 + +=item YAML is readable for people. + +It makes clear sense out of complex data structures. You should find +that YAML is an exceptional data dumping tool. Structure is shown +through indentation, YAML supports recursive data, and hash keys are +sorted by default. In addition, YAML supports several styles of scalar +formatting for different types of data. + +=item YAML is editable. + +YAML was designed from the ground up to be an excellent syntax for +configuration files. Almost all programs need configuration files, so +why invent a new syntax for each one? And why subject users to the +complexities of XML or native Perl code? + +=item YAML is multilingual. + +Yes, YAML supports Unicode. But I'm actually referring to programming +languages. YAML was designed to meet the serialization needs of Perl, +Python, Ruby, Tcl, PHP, Javascript and Java. It was also designed to be +interoperable between those languages. That means YAML serializations +produced by Perl can be processed by Python. + +=item YAML is taint safe. + +Using modules like Data::Dumper for serialization is fine as long as you +can be sure that nobody can tamper with your data files or +transmissions. That's because you need to use Perl's C built-in +to deserialize the data. Somebody could add a snippet of Perl to erase +your files. + +YAML's parser does not need to eval anything. + +=item YAML is full featured. + +YAML can accurately serialize all of the common Perl data structures and +deserialize them again without losing data relationships. Although it is +not 100% perfect (no serializer is or can be perfect), it fares as well +as the popular current modules: Data::Dumper, Storable, XML::Dumper and +Data::Denter. + +YAML.pm also has the ability to handle code (subroutine) references and +typeglobs. (Still experimental) These features are not found in Perl's +other serialization modules. + +=item YAML is extensible. + +The YAML language has been designed to be flexible enough to solve it's +own problems. The markup itself has 3 basic construct which resemble +Perl's hash, array and scalar. By default, these map to their Perl +equivalents. But each YAML node also supports a tagging mechanism (type +system) which can cause that node to be interpreted in a completely +different manner. That's how YAML can support object serialization and +oddball structures like Perl's typeglob. + +=back + +=head1 YAML IMPLEMENTATIONS IN PERL + +This module, YAML.pm, is really just the interface module for YAML +modules written in Perl. The basic interface for YAML consists of two +functions: C and C. The real work is done by the modules +YAML::Dumper and YAML::Loader. + +Different YAML module distributions can be created by subclassing +YAML.pm and YAML::Loader and YAML::Dumper. For example, YAML-Simple +consists of YAML::Simple YAML::Dumper::Simple and YAML::Loader::Simple. + +Why would there be more than one implementation of YAML? Well, despite +YAML's offering of being a simple data format, YAML is actually very +deep and complex. Implementing the entirety of the YAML specification is +a daunting task. + +For this reason I am currently working on 3 different YAML implementations. + +=over + +=item YAML + +The main YAML distribution will keeping evolving to support the entire +YAML specification in pure Perl. This may not be the fastest or most +stable module though. Currently, YAML.pm has lots of known bugs. It is +mostly a great tool for dumping Perl data structures to a readable form. + +=item YAML::Lite + +The point of YAML::Lite is to strip YAML down to the 90% that people +use most and offer that in a small, fast, stable, pure Perl form. +YAML::Lite will simply die when it is asked to do something it can't. + +=item YAML::Syck + +C is the C based YAML processing library used by the Ruby +programming language (and also Python, PHP and Pugs). YAML::Syck is the +Perl binding to C. It should be very fast, but may have +problems of its own. It will also require C compilation. + +NOTE: Audrey Tang has actually completed this module and it works great + and is 10 times faster than YAML.pm. + +=back + +In the future, there will likely be even more YAML modules. Remember, +people other than Ingy are allowed to write YAML modules! + +=head1 FUNCTIONAL USAGE + +YAML is completely OO under the hood. Still it exports a few useful top +level functions so that it is dead simple to use. These functions just +do the OO stuff for you. If you want direct access to the OO API see the +documentation for YAML::Dumper and YAML::Loader. + +=head2 Exported Functions + +The following functions are exported by YAML.pm by default. The reason +they are exported is so that YAML works much like Data::Dumper. If you +don't want functions to be imported, just use YAML with an empty +import list: + + use YAML (); + +=over 4 + +=item Dump(list-of-Perl-data-structures) + +Turn Perl data into YAML. This function works very much like +Data::Dumper::Dumper(). It takes a list of Perl data strucures and +dumps them into a serialized form. It returns a string containing the +YAML stream. The structures can be references or plain scalars. + +=item Load(string-containing-a-YAML-stream) + +Turn YAML into Perl data. This is the opposite of Dump. Just like +Storable's thaw() function or the eval() function in relation to +Data::Dumper. It parses a string containing a valid YAML stream into a +list of Perl data structures. + +=back + +=head2 Exportable Functions + +These functions are not exported by default but you can request them in +an import list like this: + + use YAML qw'freeze thaw Bless'; + +=over 4 + +=item freeze() and thaw() + +Aliases to Dump() and Load() for Storable fans. This will also allow +YAML.pm to be plugged directly into modules like POE.pm, that use the +freeze/thaw API for internal serialization. + +=item DumpFile(filepath, list) + +Writes the YAML stream to a file instead of just returning a string. + +=item LoadFile(filepath) + +Reads the YAML stream from a file instead of a string. + +=item Bless(perl-node, [yaml-node | class-name]) + +Associate a normal Perl node, with a yaml node. A yaml node is an object +tied to the YAML::Node class. The second argument is either a yaml node +that you've already created or a class (package) name that supports a +yaml_dump() function. A yaml_dump() function should take a perl node and +return a yaml node. If no second argument is provided, Bless will create +a yaml node. This node is not returned, but can be retrieved with the +Blessed() function. + +Here's an example of how to use Bless. Say you have a hash containing +three keys, but you only want to dump two of them. Furthermore the keys +must be dumped in a certain order. Here's how you do that: + + use YAML qw(Dump Bless); + $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; + print Dump $hash; + Bless($hash)->keys(['banana', 'apple']); + print Dump $hash; + +produces: + + --- + apple: good + banana: bad + cauliflower: ugly + --- + banana: bad + apple: good + +Bless returns the tied part of a yaml-node, so that you can call the +YAML::Node methods. This is the same thing that YAML::Node::ynode() +returns. So another way to do the above example is: + + use YAML qw(Dump Bless); + use YAML::Node; + $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; + print Dump $hash; + Bless($hash); + $ynode = ynode(Blessed($hash)); + $ynode->keys(['banana', 'apple']); + print Dump $hash; + +Note that Blessing a Perl data structure does not change it anyway. The +extra information is stored separately and looked up by the Blessed +node's memory address. + +=item Blessed(perl-node) + +Returns the yaml node that a particular perl node is associated with +(see above). Returns undef if the node is not (YAML) Blessed. + +=back + +=head1 GLOBAL OPTIONS + +YAML options are set using a group of global variables in the YAML +namespace. This is similar to how Data::Dumper works. + +For example, to change the indentation width, do something like: + + local $YAML::Indent = 3; + +The current options are: + +=over 4 + +=item DumperClass + +You can override which module/class YAML uses for Dumping data. + +=item LoaderClass + +You can override which module/class YAML uses for Loading data. + +=item Indent + +This is the number of space characters to use for each indentation level +when doing a Dump(). The default is 2. + +By the way, YAML can use any number of characters for indentation at any +level. So if you are editing YAML by hand feel free to do it anyway that +looks pleasing to you; just be consistent for a given level. + +=item SortKeys + +Default is 1. (true) + +Tells YAML.pm whether or not to sort hash keys when storing a document. + +YAML::Node objects can have their own sort order, which is usually what +you want. To override the YAML::Node order and sort the keys anyway, set +SortKeys to 2. + +=item Stringify + +Default is 0. (false) + +Objects with string overloading should honor the overloading and dump the +stringification of themselves, rather than the actual object's guts. + +=item UseHeader + +Default is 1. (true) + +This tells YAML.pm whether to use a separator string for a Dump +operation. This only applies to the first document in a stream. +Subsequent documents must have a YAML header by definition. + +=item UseVersion + +Default is 0. (false) + +Tells YAML.pm whether to include the YAML version on the +separator/header. + + --- %YAML:1.0 + +=item AnchorPrefix + +Default is ''. + +Anchor names are normally numeric. YAML.pm simply starts with '1' and +increases by one for each new anchor. This option allows you to specify a +string to be prepended to each anchor number. + +=item UseCode + +Setting the UseCode option is a shortcut to set both the DumpCode and +LoadCode options at once. Setting UseCode to '1' tells YAML.pm to dump +Perl code references as Perl (using B::Deparse) and to load them back +into memory using eval(). The reason this has to be an option is that +using eval() to parse untrusted code is, well, untrustworthy. + +=item DumpCode + +Determines if and how YAML.pm should serialize Perl code references. By +default YAML.pm will dump code references as dummy placeholders (much +like Data::Dumper). If DumpCode is set to '1' or 'deparse', code +references will be dumped as actual Perl code. + +DumpCode can also be set to a subroutine reference so that you can +write your own serializing routine. YAML.pm passes you the code ref. You +pass back the serialization (as a string) and a format indicator. The +format indicator is a simple string like: 'deparse' or 'bytecode'. + +=item LoadCode + +LoadCode is the opposite of DumpCode. It tells YAML if and how to +deserialize code references. When set to '1' or 'deparse' it will use +C. Since this is potentially risky, only use this option if you +know where your YAML has been. + +LoadCode can also be set to a subroutine reference so that you can write +your own deserializing routine. YAML.pm passes the serialization (as a +string) and a format indicator. You pass back the code reference. + +=item UseBlock + +YAML.pm uses heuristics to guess which scalar style is best for a given +node. Sometimes you'll want all multiline scalars to use the 'block' +style. If so, set this option to 1. + +NOTE: YAML's block style is akin to Perl's here-document. + +=item UseFold + +If you want to force YAML to use the 'folded' style for all multiline +scalars, then set $UseFold to 1. + +NOTE: YAML's folded style is akin to the way HTML folds text, + except smarter. + +=item UseAliases + +YAML has an alias mechanism such that any given structure in memory gets +serialized once. Any other references to that structure are serialized +only as alias markers. This is how YAML can serialize duplicate and +recursive structures. + +Sometimes, when you KNOW that your data is nonrecursive in nature, you +may want to serialize such that every node is expressed in full. (ie as +a copy of the original). Setting $YAML::UseAliases to 0 will allow you +to do this. This also may result in faster processing because the lookup +overhead is by bypassed. + +THIS OPTION CAN BE DANGEROUS. *If* your data is recursive, this option +*will* cause Dump() to run in an endless loop, chewing up your computers +memory. You have been warned. + +=item CompressSeries + +Default is 1. + +Compresses the formatting of arrays of hashes: + + - + foo: bar + - + bar: foo + +becomes: + + - foo: bar + - bar: foo + +Since this output is usually more desirable, this option is turned on by +default. + +=back + +=head1 YAML TERMINOLOGY + +YAML is a full featured data serialization language, and thus has its +own terminology. + +It is important to remember that although YAML is heavily influenced by +Perl and Python, it is a language in its own right, not merely just a +representation of Perl structures. + +YAML has three constructs that are conspicuously similar to Perl's hash, +array, and scalar. They are called mapping, sequence, and string +respectively. By default, they do what you would expect. But each +instance may have an explicit or implicit tag (type) that makes it +behave differently. In this manner, YAML can be extended to represent +Perl's Glob or Python's tuple, or Ruby's Bigint. + +=over 4 + +=item stream + +A YAML stream is the full sequence of unicode characters that a YAML +parser would read or a YAML emitter would write. A stream may contain +one or more YAML documents separated by YAML headers. + + --- + a: mapping + foo: bar + --- + - a + - sequence + +=item document + +A YAML document is an independent data structure representation within a +stream. It is a top level node. Each document in a YAML stream must +begin with a YAML header line. Actually the header is optional on the +first document. + + --- + This: top level mapping + is: + - a + - YAML + - document + +=item header + +A YAML header is a line that begins a YAML document. It consists of +three dashes, possibly followed by more info. Another purpose of the +header line is that it serves as a place to put top level tag and anchor +information. + + --- !recursive-sequence &001 + - * 001 + - * 001 + +=item node + +A YAML node is the representation of a particular data stucture. Nodes +may contain other nodes. (In Perl terms, nodes are like scalars. +Strings, arrayrefs and hashrefs. But this refers to the serialized +format, not the in-memory structure.) + +=item tag + +This is similar to a type. It indicates how a particular YAML node +serialization should be transferred into or out of memory. For instance +a Foo::Bar object would use the tag 'perl/Foo::Bar': + + - !perl/Foo::Bar + foo: 42 + bar: stool + +=item collection + +A collection is the generic term for a YAML data grouping. YAML has two +types of collections: mappings and sequences. (Similar to hashes and arrays) + +=item mapping + +A mapping is a YAML collection defined by unordered key/value pairs with +unique keys. By default YAML mappings are loaded into Perl hashes. + + a mapping: + foo: bar + two: times two is 4 + +=item sequence + +A sequence is a YAML collection defined by an ordered list of elements. By +default YAML sequences are loaded into Perl arrays. + + a sequence: + - one bourbon + - one scotch + - one beer + +=item scalar + +A scalar is a YAML node that is a single value. By default YAML scalars +are loaded into Perl scalars. + + a scalar key: a scalar value + +YAML has many styles for representing scalars. This is important because +varying data will have varying formatting requirements to retain the +optimum human readability. + +=item plain scalar + +A plain sclar is unquoted. All plain scalars are automatic candidates +for "implicit tagging". This means that their tag may be determined +automatically by examination. The typical uses for this are plain alpha +strings, integers, real numbers, dates, times and currency. + + - a plain string + - -42 + - 3.1415 + - 12:34 + - 123 this is an error + +=item single quoted scalar + +This is similar to Perl's use of single quotes. It means no escaping +except for single quotes which are escaped by using two adjacent +single quotes. + + - 'When I say ''\n'' I mean "backslash en"' + +=item double quoted scalar + +This is similar to Perl's use of double quotes. Character escaping can +be used. + + - "This scalar\nhas two lines, and a bell -->\a" + +=item folded scalar + +This is a multiline scalar which begins on the next line. It is +indicated by a single right angle bracket. It is unescaped like the +single quoted scalar. Line folding is also performed. + + - > + This is a multiline scalar which begins on + the next line. It is indicated by a single + carat. It is unescaped like the single + quoted scalar. Line folding is also + performed. + +=item block scalar + +This final multiline form is akin to Perl's here-document except that +(as in all YAML data) scope is indicated by indentation. Therefore, no +ending marker is required. The data is verbatim. No line folding. + + - | + QTY DESC PRICE TOTAL + --- ---- ----- ----- + 1 Foo Fighters $19.95 $19.95 + 2 Bar Belles $29.95 $59.90 + +=item parser + +A YAML processor has four stages: parse, load, dump, emit. + +A parser parses a YAML stream. YAML.pm's Load() function contains a +parser. + +=item loader + +The other half of the Load() function is a loader. This takes the +information from the parser and loads it into a Perl data structure. + +=item dumper + +The Dump() function consists of a dumper and an emitter. The dumper +walks through each Perl data structure and gives info to the emitter. + +=item emitter + +The emitter takes info from the dumper and turns it into a YAML stream. + +NOTE: +In YAML.pm the parser/loader and the dumper/emitter code are currently +very closely tied together. In the future they may be broken into +separate stages. + +=back + +For more information please refer to the immensely helpful YAML +specification available at L. + +=head1 ysh - The YAML Shell + +The YAML distribution ships with a script called 'ysh', the YAML shell. +ysh provides a simple, interactive way to play with YAML. If you type in +Perl code, it displays the result in YAML. If you type in YAML it turns +it into Perl code. + +To run ysh, (assuming you installed it along with YAML.pm) simply type: + + ysh [options] + +Please read the C documentation for the full details. There are +lots of options. + +=head1 BUGS & DEFICIENCIES + +If you find a bug in YAML, please try to recreate it in the YAML Shell +with logging turned on ('ysh -L'). When you have successfully reproduced +the bug, please mail the LOG file to the author (ingy@cpan.org). + +WARNING: This is still *ALPHA* code. Well, most of this code has been +around for years... + +BIGGER WARNING: YAML.pm has been slow in the making, but I am committed +to having top notch YAML tools in the Perl world. The YAML team is close +to finalizing the YAML 1.1 spec. This version of YAML.pm is based off of +a very old pre 1.0 spec. In actuality there isn't a ton of difference, +and this YAML.pm is still fairly useful. Things will get much better in +the future. + +=head1 RESOURCES + +L is the mailing +list. This is where the language is discussed and designed. + +L is the official YAML website. + +L is the YAML 1.0 specification. + +L is the official YAML wiki. + +=head1 SEE ALSO + +See YAML::Syck. Fast! + +=head1 AUTHOR + +Ingy döt Net + +is resonsible for YAML.pm. + +The YAML serialization language is the result of years of collaboration +between Oren Ben-Kiki, Clark Evans and Ingy döt Net. Several others +have added help along the way. + +=head1 COPYRIGHT + +Copyright (c) 2005, 2006. Ingy döt Net. All rights reserved. +Copyright (c) 2001, 2002, 2005. Brian Ingerson. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/modules/override/YAML/Base.pm b/modules/override/YAML/Base.pm new file mode 100644 index 000000000..f97f28660 --- /dev/null +++ b/modules/override/YAML/Base.pm @@ -0,0 +1,200 @@ +package YAML::Base; +use strict; use warnings; +use base 'Exporter'; + +our @EXPORT = qw(field XXX); + +sub new { + my $class = shift; + $class = ref($class) || $class; + my $self = bless {}, $class; + while (@_) { + my $method = shift; + $self->$method(shift); + } + return $self; +} + +# Use lexical subs to reduce pollution of private methods by base class. +my ($_new_error, $_info, $_scalar_info, $parse_arguments, $default_as_code); + +sub XXX { + require Data::Dumper; + CORE::die(Data::Dumper::Dumper(@_)); +} + +my %code = ( + sub_start => + "sub {\n", + set_default => + " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", + init => + " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . + " unless \$#_ > 0 or defined \$_[0]->{%s};\n", + return_if_get => + " return \$_[0]->{%s} unless \$#_ > 0;\n", + set => + " \$_[0]->{%s} = \$_[1];\n", + sub_end => + " return \$_[0]->{%s};\n}\n", +); + +sub field { + my $package = caller; + my ($args, @values) = &$parse_arguments( + [ qw(-package -init) ], + @_, + ); + my ($field, $default) = @values; + $package = $args->{-package} if defined $args->{-package}; + return if defined &{"${package}::$field"}; + my $default_string = + ( ref($default) eq 'ARRAY' and not @$default ) + ? '[]' + : (ref($default) eq 'HASH' and not keys %$default ) + ? '{}' + : &$default_as_code($default); + + my $code = $code{sub_start}; + if ($args->{-init}) { + my $fragment = $code{init}; + $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4; + } + $code .= sprintf $code{set_default}, $field, $default_string, $field + if defined $default; + $code .= sprintf $code{return_if_get}, $field; + $code .= sprintf $code{set}, $field; + $code .= sprintf $code{sub_end}, $field; + + my $sub = eval $code; + die $@ if $@; + no strict 'refs'; + *{"${package}::$field"} = $sub; + return $code if defined wantarray; +} + +sub die { + my $self = shift; + my $error = $self->$_new_error(@_); + $error->type('Error'); + Carp::croak($error->format_message); +} + +sub warn { + my $self = shift; + return unless $^W; + my $error = $self->$_new_error(@_); + $error->type('Warning'); + Carp::cluck($error->format_message); +} + +# This code needs to be refactored to be simpler and more precise, and no, +# Scalar::Util doesn't DWIM. +# +# Can't handle: +# * blessed regexp +sub node_info { + my $self = shift; + my $stringify = $_[1] || 0; + my ($class, $type, $id) = + ref($_[0]) + ? $stringify + ? &$_info("$_[0]") + : do { + require overload; + my @info = &$_info(overload::StrVal($_[0])); + if (ref($_[0]) eq 'Regexp') { + @info[0, 1] = (undef, 'REGEXP'); + } + @info; + } + : &$_scalar_info($_[0]); + ($class, $type, $id) = &$_scalar_info("$_[0]") + unless $id; + return wantarray ? ($class, $type, $id) : $id; +} + +#------------------------------------------------------------------------------- +$_info = sub { + return (($_[0]) =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o); +}; + +$_scalar_info = sub { + my $id = 'undef'; + if (defined $_[0]) { + \$_[0] =~ /\((\w+)\)$/o or CORE::die(); + $id = "$1-S"; + } + return (undef, undef, $id); +}; + +$_new_error = sub { + require Carp; + my $self = shift; + require YAML::Error; + + my $code = shift || 'unknown error'; + my $error = YAML::Error->new(code => $code); + $error->line($self->line) if $self->can('line'); + $error->document($self->document) if $self->can('document'); + $error->arguments([@_]); + return $error; +}; + +$parse_arguments = sub { + my $paired_arguments = shift || []; + my ($args, @values) = ({}, ()); + my %pairs = map { ($_, 1) } @$paired_arguments; + while (@_) { + my $elem = shift; + if (defined $elem and defined $pairs{$elem} and @_) { + $args->{$elem} = shift; + } + else { + push @values, $elem; + } + } + return wantarray ? ($args, @values) : $args; +}; + +$default_as_code = sub { + no warnings 'once'; + require Data::Dumper; + local $Data::Dumper::Sortkeys = 1; + my $code = Data::Dumper::Dumper(shift); + $code =~ s/^\$VAR1 = //; + $code =~ s/;$//; + return $code; +}; + +1; + +__END__ + +=head1 NAME + +YAML::Base - Base class for YAML classes + +=head1 SYNOPSIS + + package YAML::Something; + use YAML::Base -base; + +=head1 DESCRIPTION + +YAML::Base is the parent of all YAML classes. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/modules/override/YAML/Dumper.pm b/modules/override/YAML/Dumper.pm new file mode 100644 index 000000000..5521f8c33 --- /dev/null +++ b/modules/override/YAML/Dumper.pm @@ -0,0 +1,584 @@ +package YAML::Dumper; +use strict; use warnings; +use YAML::Base; +use base 'YAML::Dumper::Base'; + +use YAML::Node; +use YAML::Types; + +# Context constants +use constant KEY => 3; +use constant BLESSED => 4; +use constant FROMARRAY => 5; +use constant VALUE => "\x07YAML\x07VALUE\x07"; + +# Common YAML character sets +my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]'; +my $LIT_CHAR = '|'; + +#============================================================================== +# OO version of Dump. YAML->new->dump($foo); +sub dump { + my $self = shift; + $self->stream(''); + $self->document(0); + for my $document (@_) { + $self->{document}++; + $self->transferred({}); + $self->id_refcnt({}); + $self->id_anchor({}); + $self->anchor(1); + $self->level(0); + $self->offset->[0] = 0 - $self->indent_width; + $self->_prewalk($document); + $self->_emit_header($document); + $self->_emit_node($document); + } + return $self->stream; +} + +# Every YAML document in the stream must begin with a YAML header, unless +# there is only a single document and the user requests "no header". +sub _emit_header { + my $self = shift; + my ($node) = @_; + if (not $self->use_header and + $self->document == 1 + ) { + $self->die('YAML_DUMP_ERR_NO_HEADER') + unless ref($node) =~ /^(HASH|ARRAY)$/; + $self->die('YAML_DUMP_ERR_NO_HEADER') + if ref($node) eq 'HASH' and keys(%$node) == 0; + $self->die('YAML_DUMP_ERR_NO_HEADER') + if ref($node) eq 'ARRAY' and @$node == 0; + # XXX Also croak if aliased, blessed, or ynode + $self->headless(1); + return; + } + $self->{stream} .= '---'; +# XXX Consider switching to 1.1 style + if ($self->use_version) { +# $self->{stream} .= " #YAML:1.0"; + } +} + +# Walk the tree to be dumped and keep track of its reference counts. +# This function is where the Dumper does all its work. All type +# transfers happen here. +sub _prewalk { + my $self = shift; + my $stringify = $self->stringify; + my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify); + + # Handle typeglobs + if ($type eq 'GLOB') { + $self->transferred->{$node_id} = + YAML::Type::glob->yaml_dump($_[0]); + $self->_prewalk($self->transferred->{$node_id}); + return; + } + + # Handle regexps + if (ref($_[0]) eq 'Regexp') { + $self->transferred->{$node_id} = + YAML::Type::regexp->yaml_dump($_[0], $class, $self); + return; + } + + # Handle Purity for scalars. + # XXX can't find a use case yet. Might be YAGNI. + if (not ref $_[0]) { + $self->{id_refcnt}{$node_id}++ if $self->purity; + return; + } + + # Make a copy of original + my $value = $_[0]; + ($class, $type, $node_id) = $self->node_info($value, $stringify); + + # Must be a stringified object. + return if (ref($value) and not $type); + + # Look for things already transferred. + if ($self->transferred->{$node_id}) { + (undef, undef, $node_id) = (ref $self->transferred->{$node_id}) + ? $self->node_info($self->transferred->{$node_id}, $stringify) + : $self->node_info(\ $self->transferred->{$node_id}, $stringify); + $self->{id_refcnt}{$node_id}++; + return; + } + + # Handle code refs + if ($type eq 'CODE') { + $self->transferred->{$node_id} = 'placeholder'; + YAML::Type::code->yaml_dump( + $self->dump_code, + $_[0], + $self->transferred->{$node_id} + ); + ($class, $type, $node_id) = + $self->node_info(\ $self->transferred->{$node_id}, $stringify); + $self->{id_refcnt}{$node_id}++; + return; + } + + # Handle blessed things + if (defined $class) { + if ($value->can('yaml_dump')) { + $value = $value->yaml_dump; + } + elsif ($type eq 'SCALAR') { + $self->transferred->{$node_id} = 'placeholder'; + YAML::Type::blessed->yaml_dump + ($_[0], $self->transferred->{$node_id}); + ($class, $type, $node_id) = + $self->node_info(\ $self->transferred->{$node_id}, $stringify); + $self->{id_refcnt}{$node_id}++; + return; + } + else { + $value = YAML::Type::blessed->yaml_dump($value); + } + $self->transferred->{$node_id} = $value; + (undef, $type, $node_id) = $self->node_info($value, $stringify); + } + + # Handle YAML Blessed things + if (defined YAML->global_object()->{blessed_map}{$node_id}) { + $value = YAML->global_object()->{blessed_map}{$node_id}; + $self->transferred->{$node_id} = $value; + ($class, $type, $node_id) = $self->node_info($value, $stringify); + $self->_prewalk($value); + return; + } + + # Handle hard refs + if ($type eq 'REF' or $type eq 'SCALAR') { + $value = YAML::Type::ref->yaml_dump($value); + $self->transferred->{$node_id} = $value; + (undef, $type, $node_id) = $self->node_info($value, $stringify); + } + + # Handle ref-to-glob's + elsif ($type eq 'GLOB') { + my $ref_ynode = $self->transferred->{$node_id} = + YAML::Type::ref->yaml_dump($value); + + my $glob_ynode = $ref_ynode->{&VALUE} = + YAML::Type::glob->yaml_dump($$value); + + (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify); + $self->transferred->{$node_id} = $glob_ynode; + $self->_prewalk($glob_ynode); + return; + } + + # Increment ref count for node + return if ++($self->{id_refcnt}{$node_id}) > 1; + + # Keep on walking + if ($type eq 'HASH') { + $self->_prewalk($value->{$_}) + for keys %{$value}; + return; + } + elsif ($type eq 'ARRAY') { + $self->_prewalk($_) + for @{$value}; + return; + } + + # Unknown type. Need to know about it. + $self->warn(<<"..."); +YAML::Dumper can't handle dumping this type of data. +Please report this to the author. + +id: $node_id +type: $type +class: $class +value: $value + +... + + return; +} + +# Every data element and sub data element is a node. +# Everything emitted goes through this function. +sub _emit_node { + my $self = shift; + my ($type, $node_id); + my $ref = ref($_[0]); + if ($ref and $ref ne 'Regexp') { + (undef, $type, $node_id) = $self->node_info($_[0], $self->stringify); + } + else { + $type = $ref || 'SCALAR'; + (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify); + } + + my ($ynode, $tag) = ('') x 2; + my ($value, $context) = (@_, 0); + + if (defined $self->transferred->{$node_id}) { + $value = $self->transferred->{$node_id}; + $ynode = ynode($value); + if (ref $value) { + $tag = defined $ynode ? $ynode->tag->short : ''; + (undef, $type, $node_id) = + $self->node_info($value, $self->stringify); + } + else { + $ynode = ynode($self->transferred->{$node_id}); + $tag = defined $ynode ? $ynode->tag->short : ''; + $type = 'SCALAR'; + (undef, undef, $node_id) = + $self->node_info( + \ $self->transferred->{$node_id}, + $self->stringify + ); + } + } + elsif ($ynode = ynode($value)) { + $tag = $ynode->tag->short; + } + + if ($self->use_aliases) { + $self->{id_refcnt}{$node_id} ||= 0; + if ($self->{id_refcnt}{$node_id} > 1) { + if (defined $self->{id_anchor}{$node_id}) { + $self->{stream} .= ' *' . $self->{id_anchor}{$node_id} . "\n"; + return; + } + my $anchor = $self->anchor_prefix . $self->{anchor}++; + $self->{stream} .= ' &' . $anchor; + $self->{id_anchor}{$node_id} = $anchor; + } + } + + return $self->_emit_str("$value") # Stringified object + if ref($value) and not $type; + return $self->_emit_scalar($value, $tag) + if $type eq 'SCALAR' and $tag; + return $self->_emit_str($value) + if $type eq 'SCALAR'; + return $self->_emit_mapping($value, $tag, $node_id, $context) + if $type eq 'HASH'; + return $self->_emit_sequence($value, $tag) + if $type eq 'ARRAY'; + $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type); + return $self->_emit_str("$value"); +} + +# A YAML mapping is akin to a Perl hash. +sub _emit_mapping { + my $self = shift; + my ($value, $tag, $node_id, $context) = @_; + $self->{stream} .= " !$tag" if $tag; + + # Sometimes 'keys' fails. Like on a bad tie implementation. + my $empty_hash = not(eval {keys %$value}); + $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@; + return ($self->{stream} .= " {}\n") if $empty_hash; + + # If CompressSeries is on (default) and legal is this context, then + # use it and make the indent level be 2 for this node. + if ($context == FROMARRAY and + $self->compress_series and + not (defined $self->{id_anchor}{$node_id} or $tag or $empty_hash) + ) { + $self->{stream} .= ' '; + $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2; + } + else { + $context = 0; + $self->{stream} .= "\n" + unless $self->headless && not($self->headless(0)); + $self->offset->[$self->level+1] = + $self->offset->[$self->level] + $self->indent_width; + } + + $self->{level}++; + my @keys; + if ($self->sort_keys == 1) { + if (ynode($value)) { + @keys = keys %$value; + } + else { + @keys = sort keys %$value; + } + } + elsif ($self->sort_keys == 2) { + @keys = sort keys %$value; + } + # XXX This is hackish but sometimes handy. Not sure whether to leave it in. + elsif (ref($self->sort_keys) eq 'ARRAY') { + my $i = 1; + my %order = map { ($_, $i++) } @{$self->sort_keys}; + @keys = sort { + (defined $order{$a} and defined $order{$b}) + ? ($order{$a} <=> $order{$b}) + : ($a cmp $b); + } keys %$value; + } + else { + @keys = keys %$value; + } + # Force the YAML::VALUE ('=') key to sort last. + if (exists $value->{&VALUE}) { + for (my $i = 0; $i < @keys; $i++) { + if ($keys[$i] eq &VALUE) { + splice(@keys, $i, 1); + push @keys, &VALUE; + last; + } + } + } + + for my $key (@keys) { + $self->_emit_key($key, $context); + $context = 0; + $self->{stream} .= ':'; + $self->_emit_node($value->{$key}); + } + $self->{level}--; +} + +# A YAML series is akin to a Perl array. +sub _emit_sequence { + my $self = shift; + my ($value, $tag) = @_; + $self->{stream} .= " !$tag" if $tag; + + return ($self->{stream} .= " []\n") if @$value == 0; + + $self->{stream} .= "\n" + unless $self->headless && not($self->headless(0)); + + # XXX Really crufty feature. Better implemented by ynodes. + if ($self->inline_series and + @$value <= $self->inline_series and + not (scalar grep {ref or /\n/} @$value) + ) { + $self->{stream} =~ s/\n\Z/ /; + $self->{stream} .= '['; + for (my $i = 0; $i < @$value; $i++) { + $self->_emit_str($value->[$i], KEY); + last if $i == $#{$value}; + $self->{stream} .= ', '; + } + $self->{stream} .= "]\n"; + return; + } + + $self->offset->[$self->level + 1] = + $self->offset->[$self->level] + $self->indent_width; + $self->{level}++; + for my $val (@$value) { + $self->{stream} .= ' ' x $self->offset->[$self->level]; + $self->{stream} .= '-'; + $self->_emit_node($val, FROMARRAY); + } + $self->{level}--; +} + +# Emit a mapping key +sub _emit_key { + my $self = shift; + my ($value, $context) = @_; + $self->{stream} .= ' ' x $self->offset->[$self->level] + unless $context == FROMARRAY; + $self->_emit_str($value, KEY); +} + +# Emit a blessed SCALAR +sub _emit_scalar { + my $self = shift; + my ($value, $tag) = @_; + $self->{stream} .= " !$tag"; + $self->_emit_str($value, BLESSED); +} + +sub _emit { + my $self = shift; + $self->{stream} .= join '', @_; +} + +# Emit a string value. YAML has many scalar styles. This routine attempts to +# guess the best style for the text. +sub _emit_str { + my $self = shift; + my $type = $_[1] || 0; + + # Use heuristics to find the best scalar emission style. + $self->offset->[$self->level + 1] = + $self->offset->[$self->level] + $self->indent_width; + $self->{level}++; + + my $sf = $type == KEY ? '' : ' '; + my $sb = $type == KEY ? '? ' : ' '; + my $ef = $type == KEY ? '' : "\n"; + my $eb = "\n"; + + while (1) { + $self->_emit($sf), + $self->_emit_plain($_[0]), + $self->_emit($ef), last + if not defined $_[0]; + $self->_emit($sf, '=', $ef), last + if $_[0] eq VALUE; + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if $_[0] =~ /$ESCAPE_CHAR/; + if ($_[0] =~ /\n/) { + $self->_emit($sb), + $self->_emit_block($LIT_CHAR, $_[0]), + $self->_emit($eb), last + if $self->use_block; + Carp::cluck "[YAML] \$UseFold is no longer supported" + if $self->use_fold; + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if length $_[0] <= 30; + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if $_[0] !~ /\n\s*\S/; + $self->_emit($sb), + $self->_emit_block($LIT_CHAR, $_[0]), + $self->_emit($eb), last; + } + $self->_emit($sf), + $self->_emit_plain($_[0]), + $self->_emit($ef), last + if $self->is_valid_plain($_[0]); + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if $_[0] =~ /'/; + $self->_emit($sf), + $self->_emit_single($_[0]), + $self->_emit($ef); + last; + } + + $self->{level}--; + + return; +} + +# Check whether or not a scalar should be emitted as an plain scalar. +sub is_valid_plain { + my $self = shift; + return 0 unless length $_[0]; + # refer to YAML::Loader::parse_inline_simple() + return 0 if $_[0] =~ /^[\s\{\[\~\`\'\"\!\@\#\>\|\%\&\?\*\^]/; + return 0 if $_[0] =~ /[\{\[\]\},]/; + return 0 if $_[0] =~ /[:\-\?]\s/; + return 0 if $_[0] =~ /\s#/; + return 0 if $_[0] =~ /\:(\s|$)/; + return 0 if $_[0] =~ /[\s\|\>]$/; + return 1; +} + +sub _emit_block { + my $self = shift; + my ($indicator, $value) = @_; + $self->{stream} .= $indicator; + $value =~ /(\n*)\Z/; + my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-'; + $value = '~' if not defined $value; + $self->{stream} .= $chomp; + $self->{stream} .= $self->indent_width if $value =~ /^\s/; + $self->{stream} .= $self->indent($value); +} + +# Plain means that the scalar is unquoted. +sub _emit_plain { + my $self = shift; + $self->{stream} .= defined $_[0] ? $_[0] : '~'; +} + +# Double quoting is for single lined escaped strings. +sub _emit_double { + my $self = shift; + (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g; + $self->{stream} .= qq{"$escaped"}; +} + +# Single quoting is for single lined unescaped strings. +sub _emit_single { + my $self = shift; + my $item = shift; + $item =~ s{'}{''}g; + $self->{stream} .= "'$item'"; +} + +#============================================================================== +# Utility subroutines. +#============================================================================== + +# Indent a scalar to the current indentation level. +sub indent { + my $self = shift; + my ($text) = @_; + return $text unless length $text; + $text =~ s/\n\Z//; + my $indent = ' ' x $self->offset->[$self->level]; + $text =~ s/^/$indent/gm; + $text = "\n$text"; + return $text; +} + +# Escapes for unprintable characters +my @escapes = qw(\z \x01 \x02 \x03 \x04 \x05 \x06 \a + \x08 \t \n \v \f \r \x0e \x0f + \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17 + \x18 \x19 \x1a \e \x1c \x1d \x1e \x1f + ); + +# Escape the unprintable characters +sub escape { + my $self = shift; + my ($text) = @_; + $text =~ s/\\/\\\\/g; + $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge; + return $text; +} + +1; + +__END__ + +=head1 NAME + +YAML::Dumper - YAML class for dumping Perl objects to YAML + +=head1 SYNOPSIS + + use YAML::Dumper; + my $dumper = YAML::Dumper->new; + $dumper->indent_width(4); + print $dumper->dump({foo => 'bar'}); + +=head1 DESCRIPTION + +YAML::Dumper is the module that YAML.pm used to serialize Perl objects to +YAML. It is fully object oriented and usable on its own. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/modules/override/YAML/Dumper/Base.pm b/modules/override/YAML/Dumper/Base.pm new file mode 100644 index 000000000..8e4de0c87 --- /dev/null +++ b/modules/override/YAML/Dumper/Base.pm @@ -0,0 +1,137 @@ +package YAML::Dumper::Base; +use strict; use warnings; +use YAML::Base; use base 'YAML::Base'; +use YAML::Node; + +# YAML Dumping options +field spec_version => '1.0'; +field indent_width => 2; +field use_header => 1; +field use_version => 0; +field sort_keys => 1; +field anchor_prefix => ''; +field dump_code => 0; +field use_block => 0; +field use_fold => 0; +field compress_series => 1; +field inline_series => 0; +field use_aliases => 1; +field purity => 0; +field stringify => 0; + +# Properties +field stream => ''; +field document => 0; +field transferred => {}; +field id_refcnt => {}; +field id_anchor => {}; +field anchor => 1; +field level => 0; +field offset => []; +field headless => 0; +field blessed_map => {}; + +# Global Options are an idea taken from Data::Dumper. Really they are just +# sugar on top of real OO properties. They make the simple Dump/Load API +# easy to configure. +sub set_global_options { + my $self = shift; + $self->spec_version($YAML::SpecVersion) + if defined $YAML::SpecVersion; + $self->indent_width($YAML::Indent) + if defined $YAML::Indent; + $self->use_header($YAML::UseHeader) + if defined $YAML::UseHeader; + $self->use_version($YAML::UseVersion) + if defined $YAML::UseVersion; + $self->sort_keys($YAML::SortKeys) + if defined $YAML::SortKeys; + $self->anchor_prefix($YAML::AnchorPrefix) + if defined $YAML::AnchorPrefix; + $self->dump_code($YAML::DumpCode || $YAML::UseCode) + if defined $YAML::DumpCode or defined $YAML::UseCode; + $self->use_block($YAML::UseBlock) + if defined $YAML::UseBlock; + $self->use_fold($YAML::UseFold) + if defined $YAML::UseFold; + $self->compress_series($YAML::CompressSeries) + if defined $YAML::CompressSeries; + $self->inline_series($YAML::InlineSeries) + if defined $YAML::InlineSeries; + $self->use_aliases($YAML::UseAliases) + if defined $YAML::UseAliases; + $self->purity($YAML::Purity) + if defined $YAML::Purity; + $self->stringify($YAML::Stringify) + if defined $YAML::Stringify; +} + +sub dump { + my $self = shift; + $self->die('dump() not implemented in this class.'); +} + +sub blessed { + my $self = shift; + my ($ref) = @_; + $ref = \$_[0] unless ref $ref; + my (undef, undef, $node_id) = YAML::Base->node_info($ref); + $self->{blessed_map}->{$node_id}; +} + +sub bless { + my $self = shift; + my ($ref, $blessing) = @_; + my $ynode; + $ref = \$_[0] unless ref $ref; + my (undef, undef, $node_id) = YAML::Base->node_info($ref); + if (not defined $blessing) { + $ynode = YAML::Node->new($ref); + } + elsif (ref $blessing) { + $self->die() unless ynode($blessing); + $ynode = $blessing; + } + else { + no strict 'refs'; + my $transfer = $blessing . "::yaml_dump"; + $self->die() unless defined &{$transfer}; + $ynode = &{$transfer}($ref); + $self->die() unless ynode($ynode); + } + $self->{blessed_map}->{$node_id} = $ynode; + my $object = ynode($ynode) or $self->die(); + return $object; +} + +1; + +__END__ + +=head1 NAME + +YAML::Dumper::Base - Base class for YAML Dumper classes + +=head1 SYNOPSIS + + package YAML::Dumper::Something; + use YAML::Dumper::Base -base; + +=head1 DESCRIPTION + +YAML::Dumper::Base is a base class for creating YAML dumper classes. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/modules/override/YAML/Error.pm b/modules/override/YAML/Error.pm new file mode 100644 index 000000000..23b9c5ca5 --- /dev/null +++ b/modules/override/YAML/Error.pm @@ -0,0 +1,220 @@ +package YAML::Error; +use strict; use warnings; +use YAML::Base; use base 'YAML::Base'; + +field 'code'; +field 'type' => 'Error'; +field 'line'; +field 'document'; +field 'arguments' => []; + +my ($error_messages, %line_adjust); + +sub format_message { + my $self = shift; + my $output = 'YAML ' . $self->type . ': '; + my $code = $self->code; + if ($error_messages->{$code}) { + $code = sprintf($error_messages->{$code}, @{$self->arguments}); + } + $output .= $code . "\n"; + + $output .= ' Code: ' . $self->code . "\n" + if defined $self->code; + $output .= ' Line: ' . $self->line . "\n" + if defined $self->line; + $output .= ' Document: ' . $self->document . "\n" + if defined $self->document; + return $output; +} + +sub error_messages { + $error_messages; +} + +%$error_messages = map {s/^\s+//;$_} split "\n", <<'...'; +YAML_PARSE_ERR_BAD_CHARS + Invalid characters in stream. This parser only supports printable ASCII +YAML_PARSE_ERR_NO_FINAL_NEWLINE + Stream does not end with newline character +YAML_PARSE_ERR_BAD_MAJOR_VERSION + Can't parse a %s document with a 1.0 parser +YAML_PARSE_WARN_BAD_MINOR_VERSION + Parsing a %s document with a 1.0 parser +YAML_PARSE_WARN_MULTIPLE_DIRECTIVES + '%s directive used more than once' +YAML_PARSE_ERR_TEXT_AFTER_INDICATOR + No text allowed after indicator +YAML_PARSE_ERR_NO_ANCHOR + No anchor for alias '*%s' +YAML_PARSE_ERR_NO_SEPARATOR + Expected separator '---' +YAML_PARSE_ERR_SINGLE_LINE + Couldn't parse single line value +YAML_PARSE_ERR_BAD_ANCHOR + Invalid anchor +YAML_DUMP_ERR_INVALID_INDENT + Invalid Indent width specified: '%s' +YAML_LOAD_USAGE + usage: YAML::Load($yaml_stream_scalar) +YAML_PARSE_ERR_BAD_NODE + Can't parse node +YAML_PARSE_ERR_BAD_EXPLICIT + Unsupported explicit transfer: '%s' +YAML_DUMP_USAGE_DUMPCODE + Invalid value for DumpCode: '%s' +YAML_LOAD_ERR_FILE_INPUT + Couldn't open %s for input:\n%s +YAML_DUMP_ERR_FILE_CONCATENATE + Can't concatenate to YAML file %s +YAML_DUMP_ERR_FILE_OUTPUT + Couldn't open %s for output:\n%s +YAML_DUMP_ERR_NO_HEADER + With UseHeader=0, the node must be a plain hash or array +YAML_DUMP_WARN_BAD_NODE_TYPE + Can't perform serialization for node type: '%s' +YAML_EMIT_WARN_KEYS + Encountered a problem with 'keys':\n%s +YAML_DUMP_WARN_DEPARSE_FAILED + Deparse failed for CODE reference +YAML_DUMP_WARN_CODE_DUMMY + Emitting dummy subroutine for CODE reference +YAML_PARSE_ERR_MANY_EXPLICIT + More than one explicit transfer +YAML_PARSE_ERR_MANY_IMPLICIT + More than one implicit request +YAML_PARSE_ERR_MANY_ANCHOR + More than one anchor +YAML_PARSE_ERR_ANCHOR_ALIAS + Can't define both an anchor and an alias +YAML_PARSE_ERR_BAD_ALIAS + Invalid alias +YAML_PARSE_ERR_MANY_ALIAS + More than one alias +YAML_LOAD_ERR_NO_CONVERT + Can't convert implicit '%s' node to explicit '%s' node +YAML_LOAD_ERR_NO_DEFAULT_VALUE + No default value for '%s' explicit transfer +YAML_LOAD_ERR_NON_EMPTY_STRING + Only the empty string can be converted to a '%s' +YAML_LOAD_ERR_BAD_MAP_TO_SEQ + Can't transfer map as sequence. Non numeric key '%s' encountered. +YAML_DUMP_ERR_BAD_GLOB + '%s' is an invalid value for Perl glob +YAML_DUMP_ERR_BAD_REGEXP + '%s' is an invalid value for Perl Regexp +YAML_LOAD_ERR_BAD_MAP_ELEMENT + Invalid element in map +YAML_LOAD_WARN_DUPLICATE_KEY + Duplicate map key found. Ignoring. +YAML_LOAD_ERR_BAD_SEQ_ELEMENT + Invalid element in sequence +YAML_PARSE_ERR_INLINE_MAP + Can't parse inline map +YAML_PARSE_ERR_INLINE_SEQUENCE + Can't parse inline sequence +YAML_PARSE_ERR_BAD_DOUBLE + Can't parse double quoted string +YAML_PARSE_ERR_BAD_SINGLE + Can't parse single quoted string +YAML_PARSE_ERR_BAD_INLINE_IMPLICIT + Can't parse inline implicit value '%s' +YAML_PARSE_ERR_BAD_IMPLICIT + Unrecognized implicit value '%s' +YAML_PARSE_ERR_INDENTATION + Error. Invalid indentation level +YAML_PARSE_ERR_INCONSISTENT_INDENTATION + Inconsistent indentation level +YAML_LOAD_WARN_UNRESOLVED_ALIAS + Can't resolve alias *%s +YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP + No 'REGEXP' element for Perl regexp +YAML_LOAD_WARN_BAD_REGEXP_ELEM + Unknown element '%s' in Perl regexp +YAML_LOAD_WARN_GLOB_NAME + No 'NAME' element for Perl glob +YAML_LOAD_WARN_PARSE_CODE + Couldn't parse Perl code scalar: %s +YAML_LOAD_WARN_CODE_DEPARSE + Won't parse Perl code unless $YAML::LoadCode is set +YAML_EMIT_ERR_BAD_LEVEL + Internal Error: Bad level detected +YAML_PARSE_WARN_AMBIGUOUS_TAB + Amibiguous tab converted to spaces +YAML_LOAD_WARN_BAD_GLOB_ELEM + Unknown element '%s' in Perl glob +YAML_PARSE_ERR_ZERO_INDENT + Can't use zero as an indentation width +YAML_LOAD_WARN_GLOB_IO + Can't load an IO filehandle. Yet!!! +... + +%line_adjust = map {($_, 1)} + qw(YAML_PARSE_ERR_BAD_MAJOR_VERSION + YAML_PARSE_WARN_BAD_MINOR_VERSION + YAML_PARSE_ERR_TEXT_AFTER_INDICATOR + YAML_PARSE_ERR_NO_ANCHOR + YAML_PARSE_ERR_MANY_EXPLICIT + YAML_PARSE_ERR_MANY_IMPLICIT + YAML_PARSE_ERR_MANY_ANCHOR + YAML_PARSE_ERR_ANCHOR_ALIAS + YAML_PARSE_ERR_BAD_ALIAS + YAML_PARSE_ERR_MANY_ALIAS + YAML_LOAD_ERR_NO_CONVERT + YAML_LOAD_ERR_NO_DEFAULT_VALUE + YAML_LOAD_ERR_NON_EMPTY_STRING + YAML_LOAD_ERR_BAD_MAP_TO_SEQ + YAML_LOAD_ERR_BAD_STR_TO_INT + YAML_LOAD_ERR_BAD_STR_TO_DATE + YAML_LOAD_ERR_BAD_STR_TO_TIME + YAML_LOAD_WARN_DUPLICATE_KEY + YAML_PARSE_ERR_INLINE_MAP + YAML_PARSE_ERR_INLINE_SEQUENCE + YAML_PARSE_ERR_BAD_DOUBLE + YAML_PARSE_ERR_BAD_SINGLE + YAML_PARSE_ERR_BAD_INLINE_IMPLICIT + YAML_PARSE_ERR_BAD_IMPLICIT + YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP + YAML_LOAD_WARN_BAD_REGEXP_ELEM + YAML_LOAD_WARN_REGEXP_CREATE + YAML_LOAD_WARN_GLOB_NAME + YAML_LOAD_WARN_PARSE_CODE + YAML_LOAD_WARN_CODE_DEPARSE + YAML_LOAD_WARN_BAD_GLOB_ELEM + YAML_PARSE_ERR_ZERO_INDENT + ); + +package YAML::Warning; +use base 'YAML::Error'; + +1; + +__END__ + +=head1 NAME + +YAML::Error - Error formatting class for YAML modules + +=head1 SYNOPSIS + + $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias); + $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); + +=head1 DESCRIPTION + +This module provides a C and a C facility. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/modules/override/YAML/Loader.pm b/modules/override/YAML/Loader.pm new file mode 100644 index 000000000..969867d90 --- /dev/null +++ b/modules/override/YAML/Loader.pm @@ -0,0 +1,766 @@ +package YAML::Loader; +use strict; use warnings; +use YAML::Base; +use base 'YAML::Loader::Base'; +use YAML::Types; + +# Context constants +use constant LEAF => 1; +use constant COLLECTION => 2; +use constant VALUE => "\x07YAML\x07VALUE\x07"; +use constant COMMENT => "\x07YAML\x07COMMENT\x07"; + +# Common YAML character sets +my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]'; +my $FOLD_CHAR = '>'; +my $LIT_CHAR = '|'; +my $LIT_CHAR_RX = "\\$LIT_CHAR"; + +sub load { + my $self = shift; + $self->stream($_[0] || ''); + return $self->_parse(); +} + +# Top level function for parsing. Parse each document in order and +# handle processing for YAML headers. +sub _parse { + my $self = shift; + my (%directives, $preface); + $self->{stream} =~ s|\015\012|\012|g; + $self->{stream} =~ s|\015|\012|g; + $self->line(0); + $self->die('YAML_PARSE_ERR_BAD_CHARS') + if $self->stream =~ /$ESCAPE_CHAR/; + $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE') + if length($self->stream) and + $self->{stream} !~ s/(.)\n\Z/$1/s; + $self->lines([split /\x0a/, $self->stream, -1]); + $self->line(1); + # Throw away any comments or blanks before the header (or start of + # content for headerless streams) + $self->_parse_throwaway_comments(); + $self->document(0); + $self->documents([]); + # Add an "assumed" header if there is no header and the stream is + # not empty (after initial throwaways). + if (not $self->eos) { + if ($self->lines->[0] !~ /^---(\s|$)/) { + unshift @{$self->lines}, '---'; + $self->{line}--; + } + } + + # Main Loop. Parse out all the top level nodes and return them. + while (not $self->eos) { + $self->anchor2node({}); + $self->{document}++; + $self->done(0); + $self->level(0); + $self->offset->[0] = -1; + + if ($self->lines->[0] =~ /^---\s*(.*)$/) { + my @words = split /\s+/, $1; + %directives = (); + while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) { + my ($key, $value) = ($1, $2); + shift(@words); + if (defined $directives{$key}) { + $self->warn('YAML_PARSE_WARN_MULTIPLE_DIRECTIVES', + $key, $self->document); + next; + } + $directives{$key} = $value; + } + $self->preface(join ' ', @words); + } + else { + $self->die('YAML_PARSE_ERR_NO_SEPARATOR'); + } + + if (not $self->done) { + $self->_parse_next_line(COLLECTION); + } + if ($self->done) { + $self->{indent} = -1; + $self->content(''); + } + + $directives{YAML} ||= '1.0'; + $directives{TAB} ||= 'NONE'; + ($self->{major_version}, $self->{minor_version}) = + split /\./, $directives{YAML}, 2; + $self->die('YAML_PARSE_ERR_BAD_MAJOR_VERSION', $directives{YAML}) + if $self->major_version ne '1'; + $self->warn('YAML_PARSE_WARN_BAD_MINOR_VERSION', $directives{YAML}) + if $self->minor_version ne '0'; + $self->die('Unrecognized TAB policy') + unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/; + + push @{$self->documents}, $self->_parse_node(); + } + return wantarray ? @{$self->documents} : $self->documents->[-1]; +} + +# This function is the dispatcher for parsing each node. Every node +# recurses back through here. (Inlines are an exception as they have +# their own sub-parser.) +sub _parse_node { + my $self = shift; + my $preface = $self->preface; + $self->preface(''); + my ($node, $type, $indicator, $escape, $chomp) = ('') x 5; + my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5; + ($anchor, $alias, $explicit, $implicit, $preface) = + $self->_parse_qualifiers($preface); + if ($anchor) { + $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node'; + } + $self->inline(''); + while (length $preface) { + my $line = $self->line - 1; + if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) { + $indicator = $1; + $chomp = $2 if defined($2); + } + else { + $self->die('YAML_PARSE_ERR_TEXT_AFTER_INDICATOR') if $indicator; + $self->inline($preface); + $preface = ''; + } + } + if ($alias) { + $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias) + unless defined $self->anchor2node->{$alias}; + if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') { + $node = $self->anchor2node->{$alias}; + } + else { + $node = do {my $sv = "*$alias"}; + push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; + } + } + elsif (length $self->inline) { + $node = $self->_parse_inline(1, $implicit, $explicit); + if (length $self->inline) { + $self->die('YAML_PARSE_ERR_SINGLE_LINE'); + } + } + elsif ($indicator eq $LIT_CHAR) { + $self->{level}++; + $node = $self->_parse_block($chomp); + $node = $self->_parse_implicit($node) if $implicit; + $self->{level}--; + } + elsif ($indicator eq $FOLD_CHAR) { + $self->{level}++; + $node = $self->_parse_unfold($chomp); + $node = $self->_parse_implicit($node) if $implicit; + $self->{level}--; + } + else { + $self->{level}++; + $self->offset->[$self->level] ||= 0; + if ($self->indent == $self->offset->[$self->level]) { + if ($self->content =~ /^-( |$)/) { + $node = $self->_parse_seq($anchor); + } + elsif ($self->content =~ /(^\?|\:( |$))/) { + $node = $self->_parse_mapping($anchor); + } + elsif ($preface =~ /^\s*$/) { + $node = $self->_parse_implicit(''); + } + else { + $self->die('YAML_PARSE_ERR_BAD_NODE'); + } + } + else { + $node = undef; + } + $self->{level}--; + } + $#{$self->offset} = $self->level; + + if ($explicit) { + if ($class) { + if (not ref $node) { + my $copy = $node; + undef $node; + $node = \$copy; + } + CORE::bless $node, $class; + } + else { + $node = $self->_parse_explicit($node, $explicit); + } + } + if ($anchor) { + if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') { + # XXX Can't remember what this code actually does + for my $ref (@{$self->anchor2node->{$anchor}}) { + ${$ref->[0]} = $node; + $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS', + $anchor, $ref->[1]); + } + } + $self->anchor2node->{$anchor} = $node; + } + return $node; +} + +# Preprocess the qualifiers that may be attached to any node. +sub _parse_qualifiers { + my $self = shift; + my ($preface) = @_; + my ($anchor, $alias, $explicit, $implicit, $token) = ('') x 5; + $self->inline(''); + while ($preface =~ /^[&*!]/) { + my $line = $self->line - 1; + if ($preface =~ s/^\!(\S+)\s*//) { + $self->die('YAML_PARSE_ERR_MANY_EXPLICIT') if $explicit; + $explicit = $1; + } + elsif ($preface =~ s/^\!\s*//) { + $self->die('YAML_PARSE_ERR_MANY_IMPLICIT') if $implicit; + $implicit = 1; + } + elsif ($preface =~ s/^\&([^ ,:]+)\s*//) { + $token = $1; + $self->die('YAML_PARSE_ERR_BAD_ANCHOR') + unless $token =~ /^[a-zA-Z0-9]+$/; + $self->die('YAML_PARSE_ERR_MANY_ANCHOR') if $anchor; + $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $alias; + $anchor = $token; + } + elsif ($preface =~ s/^\*([^ ,:]+)\s*//) { + $token = $1; + $self->die('YAML_PARSE_ERR_BAD_ALIAS') + unless $token =~ /^[a-zA-Z0-9]+$/; + $self->die('YAML_PARSE_ERR_MANY_ALIAS') if $alias; + $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $anchor; + $alias = $token; + } + } + return ($anchor, $alias, $explicit, $implicit, $preface); +} + +# Morph a node to it's explicit type +sub _parse_explicit { + my $self = shift; + my ($node, $explicit) = @_; + my ($type, $class); + if ($explicit =~ /^\!perl\/(hash|array|scalar)\:(\w(\w|\:\:)*)?$/) { + ($type, $class) = (($1 || ''), ($2 || '')); + if (ref $node) { + return CORE::bless $node, $class; + } + else { + return CORE::bless \$node, $class; + } + } + if ($explicit =~ + /^\!?perl\/(undef|glob|regexp|code|ref)\:(\w(\w|\:\:)*)?$/) { + ($type, $class) = (($1 || ''), ($2 || '')); + my $type_class = "YAML::Type::$type"; + no strict 'refs'; + if ($type_class->can('yaml_load')) { + return $type_class->yaml_load($node, $class, $self); + } + else { + $self->die('YAML_LOAD_ERR_NO_CONVERT', 'XXX', $explicit); + } + } + # This !perl/@Foo and !perl/$Foo are deprecated but still parsed + elsif ($YAML::TagClass->{$explicit} || + $explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$} + ) { + $class = $YAML::TagClass->{$explicit} || $2; + if ($class->can('yaml_load')) { + require YAML::Node; + return $class->yaml_load(YAML::Node->new($node, $explicit)); + } + else { + if (ref $node) { + return CORE::bless $node, $class; + } + else { + return CORE::bless \$node, $class; + } + } + } + elsif (ref $node) { + require YAML::Node; + return YAML::Node->new($node, $explicit); + } + else { + # XXX This is likely wrong. Failing test: + # --- !unknown 'scalar value' + return $node; + } +} + +# Parse a YAML mapping into a Perl hash +sub _parse_mapping { + my $self = shift; + my ($anchor) = @_; + my $mapping = {}; + $self->anchor2node->{$anchor} = $mapping; + my $key; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + # If structured key: + if ($self->{content} =~ s/^\?\s*//) { + $self->preface($self->content); + $self->_parse_next_line(COLLECTION); + $key = $self->_parse_node(); + $key = "$key"; + } + # If "default" key (equals sign) + elsif ($self->{content} =~ s/^\=\s*//) { + $key = VALUE; + } + # If "comment" key (slash slash) + elsif ($self->{content} =~ s/^\=\s*//) { + $key = COMMENT; + } + # Regular scalar key: + else { + $self->inline($self->content); + $key = $self->_parse_inline(); + $key = "$key"; + $self->content($self->inline); + $self->inline(''); + } + + unless ($self->{content} =~ s/^:\s*//) { + $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT'); + } + $self->preface($self->content); + my $line = $self->line; + $self->_parse_next_line(COLLECTION); + my $value = $self->_parse_node(); + if (exists $mapping->{$key}) { + $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); + } + else { + $mapping->{$key} = $value; + } + } + return $mapping; +} + +# Parse a YAML sequence into a Perl array +sub _parse_seq { + my $self = shift; + my ($anchor) = @_; + my $seq = []; + $self->anchor2node->{$anchor} = $seq; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + if ($self->content =~ /^-(?: (.*))?$/) { + $self->preface(defined($1) ? $1 : ''); + } + else { + $self->die('YAML_LOAD_ERR_BAD_SEQ_ELEMENT'); + } + if ($self->preface =~ /^(\s*)(\w.*\:(?: |$).*)$/) { + $self->indent($self->offset->[$self->level] + 2 + length($1)); + $self->content($2); + $self->level($self->level + 1); + $self->offset->[$self->level] = $self->indent; + $self->preface(''); + push @$seq, $self->_parse_mapping(''); + $self->{level}--; + $#{$self->offset} = $self->level; + } + else { + $self->_parse_next_line(COLLECTION); + push @$seq, $self->_parse_node(); + } + } + return $seq; +} + +# Parse an inline value. Since YAML supports inline collections, this is +# the top level of a sub parsing. +sub _parse_inline { + my $self = shift; + my ($top, $top_implicit, $top_explicit) = (@_, '', '', ''); + $self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump + my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5; + ($anchor, $alias, $explicit, $implicit, $self->{inline}) = + $self->_parse_qualifiers($self->inline); + if ($anchor) { + $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node'; + } + $implicit ||= $top_implicit; + $explicit ||= $top_explicit; + ($top_implicit, $top_explicit) = ('', ''); + if ($alias) { + $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias) + unless defined $self->anchor2node->{$alias}; + if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') { + $node = $self->anchor2node->{$alias}; + } + else { + $node = do {my $sv = "*$alias"}; + push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; + } + } + elsif ($self->inline =~ /^\{/) { + $node = $self->_parse_inline_mapping($anchor); + } + elsif ($self->inline =~ /^\[/) { + $node = $self->_parse_inline_seq($anchor); + } + elsif ($self->inline =~ /^"/) { + $node = $self->_parse_inline_double_quoted(); + $node = $self->_unescape($node); + $node = $self->_parse_implicit($node) if $implicit; + } + elsif ($self->inline =~ /^'/) { + $node = $self->_parse_inline_single_quoted(); + $node = $self->_parse_implicit($node) if $implicit; + } + else { + if ($top) { + $node = $self->inline; + $self->inline(''); + } + else { + $node = $self->_parse_inline_simple(); + } + $node = $self->_parse_implicit($node) unless $explicit; + } + if ($explicit) { + $node = $self->_parse_explicit($node, $explicit); + } + if ($anchor) { + if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') { + for my $ref (@{$self->anchor2node->{$anchor}}) { + ${$ref->[0]} = $node; + $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS', + $anchor, $ref->[1]); + } + } + $self->anchor2node->{$anchor} = $node; + } + return $node; +} + +# Parse the inline YAML mapping into a Perl hash +sub _parse_inline_mapping { + my $self = shift; + my ($anchor) = @_; + my $node = {}; + $self->anchor2node->{$anchor} = $node; + + $self->die('YAML_PARSE_ERR_INLINE_MAP') + unless $self->{inline} =~ s/^\{\s*//; + while (not $self->{inline} =~ s/^\s*\}//) { + my $key = $self->_parse_inline(); + $self->die('YAML_PARSE_ERR_INLINE_MAP') + unless $self->{inline} =~ s/^\: \s*//; + my $value = $self->_parse_inline(); + if (exists $node->{$key}) { + $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); + } + else { + $node->{$key} = $value; + } + next if $self->inline =~ /^\s*\}/; + $self->die('YAML_PARSE_ERR_INLINE_MAP') + unless $self->{inline} =~ s/^\,\s*//; + } + return $node; +} + +# Parse the inline YAML sequence into a Perl array +sub _parse_inline_seq { + my $self = shift; + my ($anchor) = @_; + my $node = []; + $self->anchor2node->{$anchor} = $node; + + $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE') + unless $self->{inline} =~ s/^\[\s*//; + while (not $self->{inline} =~ s/^\s*\]//) { + my $value = $self->_parse_inline(); + push @$node, $value; + next if $self->inline =~ /^\s*\]/; + $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE') + unless $self->{inline} =~ s/^\,\s*//; + } + return $node; +} + +# Parse the inline double quoted string. +sub _parse_inline_double_quoted { + my $self = shift; + my $node; + if ($self->inline =~ /^"((?:\\"|[^"])*)"\s*(.*)$/) { + $node = $1; + $self->inline($2); + $node =~ s/\\"/"/g; + } + else { + $self->die('YAML_PARSE_ERR_BAD_DOUBLE'); + } + return $node; +} + + +# Parse the inline single quoted string. +sub _parse_inline_single_quoted { + my $self = shift; + my $node; + if ($self->inline =~ /^'((?:''|[^'])*)'\s*(.*)$/) { + $node = $1; + $self->inline($2); + $node =~ s/''/'/g; + } + else { + $self->die('YAML_PARSE_ERR_BAD_SINGLE'); + } + return $node; +} + +# Parse the inline unquoted string and do implicit typing. +sub _parse_inline_simple { + my $self = shift; + my $value; + if ($self->inline =~ /^(|[^!@#%^&*].*?)(?=[\[\]\{\},]|, |: |- |:\s*$|$)/) { + $value = $1; + substr($self->{inline}, 0, length($1)) = ''; + } + else { + $self->die('YAML_PARSE_ERR_BAD_INLINE_IMPLICIT', $value); + } + return $value; +} + +sub _parse_implicit { + my $self = shift; + my ($value) = @_; + $value =~ s/\s*$//; + return $value if $value eq ''; + return undef if $value =~ /^~$/; + return $value + unless $value =~ /^[\@\`\^]/ or + $value =~ /^[\-\?]\s/; + $self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value); +} + +# Unfold a YAML multiline scalar into a single string. +sub _parse_unfold { + my $self = shift; + my ($chomp) = @_; + my $node = ''; + my $space = 0; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + $node .= $self->content. "\n"; + $self->_parse_next_line(LEAF); + } + $node =~ s/^(\S.*)\n(?=\S)/$1 /gm; + $node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm; + $node =~ s/\n*\Z// unless $chomp eq '+'; + $node .= "\n" unless $chomp; + return $node; +} + +# Parse a YAML block style scalar. This is like a Perl here-document. +sub _parse_block { + my $self = shift; + my ($chomp) = @_; + my $node = ''; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + $node .= $self->content . "\n"; + $self->_parse_next_line(LEAF); + } + return $node if '+' eq $chomp; + $node =~ s/\n*\Z/\n/; + $node =~ s/\n\Z// if $chomp eq '-'; + return $node; +} + +# Handle Perl style '#' comments. Comments must be at the same indentation +# level as the collection line following them. +sub _parse_throwaway_comments { + my $self = shift; + while (@{$self->lines} and + $self->lines->[0] =~ m{^\s*(\#|$)} + ) { + shift @{$self->lines}; + $self->{line}++; + } + $self->eos($self->{done} = not @{$self->lines}); +} + +# This is the routine that controls what line is being parsed. It gets called +# once for each line in the YAML stream. +# +# This routine must: +# 1) Skip past the current line +# 2) Determine the indentation offset for a new level +# 3) Find the next _content_ line +# A) Skip over any throwaways (Comments/blanks) +# B) Set $self->indent, $self->content, $self->line +# 4) Expand tabs appropriately +sub _parse_next_line { + my $self = shift; + my ($type) = @_; + my $level = $self->level; + my $offset = $self->offset->[$level]; + $self->die('YAML_EMIT_ERR_BAD_LEVEL') unless defined $offset; + shift @{$self->lines}; + $self->eos($self->{done} = not @{$self->lines}); + return if $self->eos; + $self->{line}++; + + # Determine the offset for a new leaf node + if ($self->preface =~ + qr/(?:^|\s)(?:$FOLD_CHAR|$LIT_CHAR_RX)(?:-|\+)?(\d*)\s*$/ + ) { + $self->die('YAML_PARSE_ERR_ZERO_INDENT') + if length($1) and $1 == 0; + $type = LEAF; + if (length($1)) { + $self->offset->[$level + 1] = $offset + $1; + } + else { + # First get rid of any comments. + while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) { + $self->lines->[0] =~ /^( *)/ or die; + last unless length($1) <= $offset; + shift @{$self->lines}; + $self->{line}++; + } + $self->eos($self->{done} = not @{$self->lines}); + return if $self->eos; + if ($self->lines->[0] =~ /^( *)\S/ and length($1) > $offset) { + $self->offset->[$level+1] = length($1); + } + else { + $self->offset->[$level+1] = $offset + 1; + } + } + $offset = $self->offset->[++$level]; + } + # Determine the offset for a new collection level + elsif ($type == COLLECTION and + $self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) { + $self->_parse_throwaway_comments(); + if ($self->eos) { + $self->offset->[$level+1] = $offset + 1; + return; + } + else { + $self->lines->[0] =~ /^( *)\S/ or die; + if (length($1) > $offset) { + $self->offset->[$level+1] = length($1); + } + else { + $self->offset->[$level+1] = $offset + 1; + } + } + $offset = $self->offset->[++$level]; + } + + if ($type == LEAF) { + while (@{$self->lines} and + $self->lines->[0] =~ m{^( *)(\#)} and + length($1) < $offset + ) { + shift @{$self->lines}; + $self->{line}++; + } + $self->eos($self->{done} = not @{$self->lines}); + } + else { + $self->_parse_throwaway_comments(); + } + return if $self->eos; + + if ($self->lines->[0] =~ /^---(\s|$)/) { + $self->done(1); + return; + } + if ($type == LEAF and + $self->lines->[0] =~ /^ {$offset}(.*)$/ + ) { + $self->indent($offset); + $self->content($1); + } + elsif ($self->lines->[0] =~ /^\s*$/) { + $self->indent($offset); + $self->content(''); + } + else { + $self->lines->[0] =~ /^( *)(\S.*)$/; + while ($self->offset->[$level] > length($1)) { + $level--; + } + $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION') + if $self->offset->[$level] != length($1); + $self->indent(length($1)); + $self->content($2); + } + $self->die('YAML_PARSE_ERR_INDENTATION') + if $self->indent - $offset > 1; +} + +#============================================================================== +# Utility subroutines. +#============================================================================== + +# Printable characters for escapes +my %unescapes = + ( + z => "\x00", a => "\x07", t => "\x09", + n => "\x0a", v => "\x0b", f => "\x0c", + r => "\x0d", e => "\x1b", '\\' => '\\', + ); + +# Transform all the backslash style escape characters to their literal meaning +sub _unescape { + my $self = shift; + my ($node) = @_; + $node =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/ + (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex; + return $node; +} + +1; + +__END__ + +=head1 NAME + +YAML::Loader - YAML class for loading Perl objects to YAML + +=head1 SYNOPSIS + + use YAML::Loader; + my $loader = YAML::Loader->new; + my $hash = $loader->load(<<'...'); + foo: bar + ... + +=head1 DESCRIPTION + +YAML::Loader is the module that YAML.pm used to deserialize YAML to Perl +objects. It is fully object oriented and usable on its own. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/modules/override/YAML/Loader/Base.pm b/modules/override/YAML/Loader/Base.pm new file mode 100644 index 000000000..4d5b02dd0 --- /dev/null +++ b/modules/override/YAML/Loader/Base.pm @@ -0,0 +1,64 @@ +package YAML::Loader::Base; +use strict; use warnings; +use YAML::Base; use base 'YAML::Base'; + +field load_code => 0; + +field stream => ''; +field document => 0; +field line => 0; +field documents => []; +field lines => []; +field eos => 0; +field done => 0; +field anchor2node => {}; +field level => 0; +field offset => []; +field preface => ''; +field content => ''; +field indent => 0; +field major_version => 0; +field minor_version => 0; +field inline => ''; + +sub set_global_options { + my $self = shift; + $self->load_code($YAML::LoadCode || $YAML::UseCode) + if defined $YAML::LoadCode or defined $YAML::UseCode; +} + +sub load { + die 'load() not implemented in this class.'; +} + +1; + +__END__ + +=head1 NAME + +YAML::Loader::Base - Base class for YAML Loader classes + +=head1 SYNOPSIS + + package YAML::Loader::Something; + use YAML::Loader::Base -base; + +=head1 DESCRIPTION + +YAML::Loader::Base is a base class for creating YAML loader classes. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/modules/override/YAML/Marshall.pm b/modules/override/YAML/Marshall.pm new file mode 100644 index 000000000..5985ecea8 --- /dev/null +++ b/modules/override/YAML/Marshall.pm @@ -0,0 +1,77 @@ +package YAML::Marshall; +use strict; use warnings; +use YAML::Node(); + +sub import { + my $class = shift; + no strict 'refs'; + my $package = caller; + unless (grep { $_ eq $class} @{$package . '::ISA'}) { + push @{$package . '::ISA'}, $class; + } + + my $tag = shift; + if ($tag) { + no warnings 'once'; + $YAML::TagClass->{$tag} = $package; + ${$package . "::YamlTag"} = $tag; + } +} + +sub yaml_dump { + my $self = shift; + no strict 'refs'; + my $tag = ${ref($self) . "::YamlTag"} || 'perl/' . ref($self); + $self->yaml_node($self, $tag); +} + +sub yaml_load { + my ($class, $node) = @_; + if (my $ynode = $class->yaml_ynode($node)) { + $node = $ynode->{NODE}; + } + bless $node, $class; +} + +sub yaml_node { + shift; + YAML::Node->new(@_); +} + +sub yaml_ynode { + shift; + YAML::Node::ynode(@_); +} + +1; + +__END__ + +=head1 NAME + +YAML::Marshall - YAML marshalling class you can mixin to your classes + +=head1 SYNOPSIS + + package Bar; + use Foo -base; + use YAML::Marshall -mixin; + +=head1 DESCRIPTION + +For classes that want to handle their own YAML serialization. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/modules/override/YAML/Node.pm b/modules/override/YAML/Node.pm new file mode 100644 index 000000000..69affcf67 --- /dev/null +++ b/modules/override/YAML/Node.pm @@ -0,0 +1,296 @@ +package YAML::Node; +use strict; use warnings; +use YAML::Base; use base 'YAML::Base'; +use YAML::Tag; + +our @EXPORT = qw(ynode); + +sub ynode { + my $self; + if (ref($_[0]) eq 'HASH') { + $self = tied(%{$_[0]}); + } + elsif (ref($_[0]) eq 'ARRAY') { + $self = tied(@{$_[0]}); + } + else { + $self = tied($_[0]); + } + return (ref($self) =~ /^yaml_/) ? $self : undef; +} + +sub new { + my ($class, $node, $tag) = @_; + my $self; + $self->{NODE} = $node; + my (undef, $type) = $class->node_info($node); + $self->{KIND} = (not defined $type) ? 'scalar' : + ($type eq 'ARRAY') ? 'sequence' : + ($type eq 'HASH') ? 'mapping' : + $class->die("Can't create YAML::Node from '$type'"); + tag($self, ($tag || '')); + if ($self->{KIND} eq 'scalar') { + yaml_scalar->new($self, $_[1]); + return \ $_[1]; + } + my $package = "yaml_" . $self->{KIND}; + $package->new($self) +} + +sub node { $_->{NODE} } +sub kind { $_->{KIND} } +sub tag { + my ($self, $value) = @_; + if (defined $value) { + $self->{TAG} = YAML::Tag->new($value); + return $self; + } + else { + return $self->{TAG}; + } +} +sub keys { + my ($self, $value) = @_; + if (defined $value) { + $self->{KEYS} = $value; + return $self; + } + else { + return $self->{KEYS}; + } +} + +#============================================================================== +package yaml_scalar; +@yaml_scalar::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + tie $_[2], $class, $self; +} + +sub TIESCALAR { + my ($class, $self) = @_; + bless $self, $class; + $self +} + +sub FETCH { + my ($self) = @_; + $self->{NODE} +} + +sub STORE { + my ($self, $value) = @_; + $self->{NODE} = $value +} + +#============================================================================== +package yaml_sequence; +@yaml_sequence::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + my $new; + tie @$new, $class, $self; + $new +} + +sub TIEARRAY { + my ($class, $self) = @_; + bless $self, $class +} + +sub FETCHSIZE { + my ($self) = @_; + scalar @{$self->{NODE}}; +} + +sub FETCH { + my ($self, $index) = @_; + $self->{NODE}[$index] +} + +sub STORE { + my ($self, $index, $value) = @_; + $self->{NODE}[$index] = $value +} + +sub undone { + die "Not implemented yet"; # XXX +} + +*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = +*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = +*undone; # XXX Must implement before release + +#============================================================================== +package yaml_mapping; +@yaml_mapping::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + @{$self->{KEYS}} = sort keys %{$self->{NODE}}; + my $new; + tie %$new, $class, $self; + $new +} + +sub TIEHASH { + my ($class, $self) = @_; + bless $self, $class +} + +sub FETCH { + my ($self, $key) = @_; + if (exists $self->{NODE}{$key}) { + return (grep {$_ eq $key} @{$self->{KEYS}}) + ? $self->{NODE}{$key} : undef; + } + return $self->{HASH}{$key}; +} + +sub STORE { + my ($self, $key, $value) = @_; + if (exists $self->{NODE}{$key}) { + $self->{NODE}{$key} = $value; + } + elsif (exists $self->{HASH}{$key}) { + $self->{HASH}{$key} = $value; + } + else { + if (not grep {$_ eq $key} @{$self->{KEYS}}) { + push(@{$self->{KEYS}}, $key); + } + $self->{HASH}{$key} = $value; + } + $value +} + +sub DELETE { + my ($self, $key) = @_; + my $return; + if (exists $self->{NODE}{$key}) { + $return = $self->{NODE}{$key}; + } + elsif (exists $self->{HASH}{$key}) { + $return = delete $self->{NODE}{$key}; + } + for (my $i = 0; $i < @{$self->{KEYS}}; $i++) { + if ($self->{KEYS}[$i] eq $key) { + splice(@{$self->{KEYS}}, $i, 1); + } + } + return $return; +} + +sub CLEAR { + my ($self) = @_; + @{$self->{KEYS}} = (); + %{$self->{HASH}} = (); +} + +sub FIRSTKEY { + my ($self) = @_; + $self->{ITER} = 0; + $self->{KEYS}[0] +} + +sub NEXTKEY { + my ($self) = @_; + $self->{KEYS}[++$self->{ITER}] +} + +sub EXISTS { + my ($self, $key) = @_; + exists $self->{NODE}{$key} +} + +1; + +__END__ + +=head1 NAME + +YAML::Node - A generic data node that encapsulates YAML information + +=head1 SYNOPSIS + + use YAML; + use YAML::Node; + + my $ynode = YAML::Node->new({}, 'ingerson.com/fruit'); + %$ynode = qw(orange orange apple red grape green); + print Dump $ynode; + +yields: + + --- !ingerson.com/fruit + orange: orange + apple: red + grape: green + +=head1 DESCRIPTION + +A generic node in YAML is similar to a plain hash, array, or scalar node +in Perl except that it must also keep track of its type. The type is a +URI called the YAML type tag. + +YAML::Node is a class for generating and manipulating these containers. +A YAML node (or ynode) is a tied hash, array or scalar. In most ways it +behaves just like the plain thing. But you can assign and retrieve and +YAML type tag URI to it. For the hash flavor, you can also assign the +order that the keys will be retrieved in. By default a ynode will offer +its keys in the same order that they were assigned. + +YAML::Node has a class method call new() that will return a ynode. You +pass it a regular node and an optional type tag. After that you can +use it like a normal Perl node, but when you YAML::Dump it, the magical +properties will be honored. + +This is how you can control the sort order of hash keys during a YAML +serialization. By default, YAML sorts keys alphabetically. But notice +in the above example that the keys were Dumped in the same order they +were assigned. + +YAML::Node exports a function called ynode(). This function returns the tied object so that you can call special methods on it like ->keys(). + +keys() works like this: + + use YAML; + use YAML::Node; + + %$node = qw(orange orange apple red grape green); + $ynode = YAML::Node->new($node); + ynode($ynode)->keys(['grape', 'apple']); + print Dump $ynode; + +produces: + + --- + grape: green + apple: red + +It tells the ynode which keys and what order to use. + +ynodes will play a very important role in how programs use YAML. They +are the foundation of how a Perl class can marshall the Loading and +Dumping of its objects. + +The upcoming versions of YAML.pm will have much more information on this. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. +Copyright (c) 2002. Brian Ingerson. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/modules/override/YAML/Tag.pm b/modules/override/YAML/Tag.pm new file mode 100644 index 000000000..a6826fd94 --- /dev/null +++ b/modules/override/YAML/Tag.pm @@ -0,0 +1,48 @@ +package YAML::Tag; +use strict; use warnings; + +use overload '""' => sub { ${$_[0]} }; + +sub new { + my ($class, $self) = @_; + bless \$self, $class +} + +sub short { + ${$_[0]} +} + +sub canonical { + ${$_[0]} +} + +1; + +__END__ + +=head1 NAME + +YAML::Tag - Tag URI object class for YAML + +=head1 SYNOPSIS + + use YAML::Tag; + +=head1 DESCRIPTION + +Used by YAML::Node. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/modules/override/YAML/Types.pm b/modules/override/YAML/Types.pm new file mode 100644 index 000000000..4d737baee --- /dev/null +++ b/modules/override/YAML/Types.pm @@ -0,0 +1,262 @@ +package YAML::Types; +use strict; use warnings; +use YAML::Base; use base 'YAML::Base'; +use YAML::Node; + +# XXX These classes and their APIs could still use some refactoring, +# but at least they work for now. +#------------------------------------------------------------------------------- +package YAML::Type::blessed; +use YAML::Base; # XXX +sub yaml_dump { + my $self = shift; + my ($value) = @_; + my ($class, $type) = YAML::Base->node_info($value); + no strict 'refs'; + my $kind = lc($type) . ':'; + my $tag = ${$class . '::ClassTag'} || + "!perl/$kind$class"; + if ($type eq 'REF') { + YAML::Node->new( + {(&YAML::VALUE, ${$_[0]})}, $tag + ); + } + elsif ($type eq 'SCALAR') { + $_[1] = $$value; + YAML::Node->new($_[1], $tag); + } else { + YAML::Node->new($value, $tag); + } +} + +#------------------------------------------------------------------------------- +package YAML::Type::undef; +sub yaml_dump { + my $self = shift; +} + +sub yaml_load { + my $self = shift; +} + +#------------------------------------------------------------------------------- +package YAML::Type::glob; +sub yaml_dump { + my $self = shift; + my $ynode = YAML::Node->new({}, '!perl/glob:'); + for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) { + my $value = *{$_[0]}{$type}; + $value = $$value if $type eq 'SCALAR'; + if (defined $value) { + if ($type eq 'IO') { + my @stats = qw(device inode mode links uid gid rdev size + atime mtime ctime blksize blocks); + undef $value; + $value->{stat} = YAML::Node->new({}); + map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]}); + $value->{fileno} = fileno(*{$_[0]}); + { + local $^W; + $value->{tell} = tell(*{$_[0]}); + } + } + $ynode->{$type} = $value; + } + } + return $ynode; +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + my ($name, $package); + if (defined $node->{NAME}) { + $name = $node->{NAME}; + delete $node->{NAME}; + } + else { + $loader->warn('YAML_LOAD_WARN_GLOB_NAME'); + return undef; + } + if (defined $node->{PACKAGE}) { + $package = $node->{PACKAGE}; + delete $node->{PACKAGE}; + } + else { + $package = 'main'; + } + no strict 'refs'; + if (exists $node->{SCALAR}) { + *{"${package}::$name"} = \$node->{SCALAR}; + delete $node->{SCALAR}; + } + for my $elem (qw(ARRAY HASH CODE IO)) { + if (exists $node->{$elem}) { + if ($elem eq 'IO') { + $loader->warn('YAML_LOAD_WARN_GLOB_IO'); + delete $node->{IO}; + next; + } + *{"${package}::$name"} = $node->{$elem}; + delete $node->{$elem}; + } + } + for my $elem (sort keys %$node) { + $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem); + } + return *{"${package}::$name"}; +} + +#------------------------------------------------------------------------------- +package YAML::Type::code; +my $dummy_warned = 0; +my $default = '{ "DUMMY" }'; +sub yaml_dump { + my $self = shift; + my $code; + my ($dumpflag, $value) = @_; + my ($class, $type) = YAML::Base->node_info($value); + $class ||= ''; + my $tag = "!perl/code:$class"; + if (not $dumpflag) { + $code = $default; + } + else { + bless $value, "CODE" if $class; + eval { use B::Deparse }; + return if $@; + my $deparse = B::Deparse->new(); + eval { + local $^W = 0; + $code = $deparse->coderef2text($value); + }; + if ($@) { + warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W; + $code = $default; + } + bless $value, $class if $class; + chomp $code; + $code .= "\n"; + } + $_[2] = $code; + YAML::Node->new($_[2], $tag); +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + if ($loader->load_code) { + my $code = eval "package main; sub $node"; + if ($@) { + $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@); + return sub {}; + } + else { + CORE::bless $code, $class if $class; + return $code; + } + } + else { + return sub {}; + } +} + +#------------------------------------------------------------------------------- +package YAML::Type::ref; +sub yaml_dump { + my $self = shift; + YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref:') +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr') + unless exists $node->{&YAML::VALUE}; + return \$node->{&YAML::VALUE}; +} + +#------------------------------------------------------------------------------- +package YAML::Type::regexp; +# XXX Be sure to handle blessed regexps (if possible) +sub yaml_dump { + my $self = shift; + my ($node, $class, $dumper) = @_; + my ($regexp, $modifiers); + if ("$node" =~ /^\(\?(\w*)(?:\-\w+)?\:(.*)\)$/) { + $regexp = $2; + $modifiers = $1 || ''; + } + else { + $dumper->die('YAML_DUMP_ERR_BAD_REGEXP', $node); + } + my $tag = '!perl/regexp:'; + $tag .= $class if $class; + my $ynode = YAML::Node->new({}, $tag); + $ynode->{REGEXP} = $regexp; + $ynode->{MODIFIERS} = $modifiers if $modifiers; + return $ynode; +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + my ($regexp, $modifiers); + if (defined $node->{REGEXP}) { + $regexp = $node->{REGEXP}; + delete $node->{REGEXP}; + } + else { + $loader->warn('YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP'); + return undef; + } + if (defined $node->{MODIFIERS}) { + $modifiers = $node->{MODIFIERS}; + delete $node->{MODIFIERS}; + } + else { + $modifiers = ''; + } + for my $elem (sort keys %$node) { + $loader->warn('YAML_LOAD_WARN_BAD_REGEXP_ELEM', $elem); + } + my $qr = $regexp; + $qr = "(?$modifiers:$qr)"; + return qr{$qr}; +} + +1; + +__END__ + +=head1 NAME + +YAML::Transfer - Marshall Perl internal data types to/from YAML + +=head1 SYNOPSIS + + $::foo = 42; + print YAML::Dump(*::foo); + + print YAML::Dump(qr{match me}); + +=head1 DESCRIPTION + +This module has the helper classes for transferring objects, +subroutines, references, globs, regexps and file handles to and +from YAML. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/scripts/dbupgrade2_tool.pl b/scripts/dbupgrade2_tool.pl index e62a9aaba..1d1403eba 100755 --- a/scripts/dbupgrade2_tool.pl +++ b/scripts/dbupgrade2_tool.pl @@ -6,8 +6,8 @@ BEGIN { exit(1); } - unshift @INC, "modules/YAML"; # Use our own version of YAML. - push @INC, "modules"; # Only use our own versions of modules if there's no system version. + unshift @INC, "modules/override"; # Use our own versions of various modules (e.g. YAML). + push @INC, "modules/fallback"; # Only use our own versions of modules if there's no system version. } use English '-no_match_vars'; diff --git a/scripts/installation_check.pl b/scripts/installation_check.pl index 2022c1665..306156b21 100755 --- a/scripts/installation_check.pl +++ b/scripts/installation_check.pl @@ -1,8 +1,8 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, "modules/YAML"; # Use our own version of YAML. - push @INC, "modules"; # Only use our own versions of modules if there's no system version. + unshift @INC, "modules/override"; # Use our own versions of various modules (e.g. YAML). + push @INC, "modules/fallback"; # Only use our own versions of modules if there's no system version. } use SL::InstallationCheck; diff --git a/scripts/spawn_oo.pl b/scripts/spawn_oo.pl index b192a9318..058de3474 100755 --- a/scripts/spawn_oo.pl +++ b/scripts/spawn_oo.pl @@ -1,8 +1,8 @@ #!/usr/bin/perl BEGIN { - unshift @INC, "modules/YAML"; # Use our own version of YAML. - push @INC, "modules"; # Only use our own versions of modules if there's no system version. + unshift @INC, "modules/override"; # Use our own versions of various modules (e.g. YAML). + push @INC, "modules/fallback"; # Only use our own versions of modules if there's no system version. } use DBI;