Statistics-R-0.24/0000755000175000017500000000000011656373117014222 5ustar flofloooflofloooStatistics-R-0.24/lib/0000755000175000017500000000000011656373117014770 5ustar flofloooflofloooStatistics-R-0.24/lib/Statistics/0000755000175000017500000000000011656373117017122 5ustar flofloooflofloooStatistics-R-0.24/lib/Statistics/R.pm0000644000175000017500000003535011656373027017667 0ustar floflooofloflooopackage Statistics::R; use 5.006; use strict; use warnings; use Regexp::Common; use File::Spec::Functions; use Statistics::R::Legacy; use IPC::Run qw( harness start pump finish ); use Text::Balanced qw ( extract_delimited extract_multiple ); if ( $^O =~ m/^(?:.*?win32|dos)$/i ) { require Statistics::R::Win32; } our $VERSION = '0.24'; our ($SHARED_BRIDGE, $SHARED_STDIN, $SHARED_STDOUT, $SHARED_STDERR); my $prog = 'R'; # executable we are after... R my $eos = 'Statistics::R::EOS'; # string to signal the R output stream end my $eos_re = qr/$eos\n$/; # regexp to match end of R stream =head1 NAME Statistics::R - Perl interface with the R statistical program =head1 DESCRIPTION I is a module to controls the R interpreter (R project for statistical computing: L). It lets you start R, pass commands to it and retrieve the output. A shared mode allow to have several instances of I talk to the same R process. The current I implementation uses pipes (for stdin, stdout and and stderr) to communicate with R. This implementation should be more efficient and reliable than that in previous version, which relied on reading and writing files. As before, this module works on GNU/Linux, MS Windows and probably many more systems. =head1 SYNOPSIS use Statistics::R; # Create a communication bridge with R and start R my $R = Statistics::R->new(); # Run simple R commands my $output_file = "file.ps"; $R->run(qq`postscript("$output_file" , horizontal=FALSE , width=500 , height=500 , pointsize=1)`); $R->run(q`plot(c(1, 5, 10), type = "l")`); $R->run(q`dev.off()`); # Pass and retrieve data (scalars or arrays) my $input_value = 1; $R->set('x', $input_value); $R->run(q`y <- x^2`); my $output_value = $R->get('y'); print "y = $output_value\n"; $R->stop(); =head1 METHODS =over 4 =item new() Build a I bridge object between Perl and R. Available options are: =over 4 =item r_bin Specify the full path to R if it is not automatically found. See L. =item shared Start a shared bridge. When using a shared bridge, several instances of Statistics::R can communicate with the same unique R instance. Example: use Statistics::R; my $R1 = Statistics::R->new( shared => 1); my $R2 = Statistics::R->new( shared => 1); $R1->set( 'x', 'pear' ); my $x = $R2->get( 'x' ); print "x = $x\n"; Do not call the I method is you still have processes that need to interact with R. =back =item run() First, start() R if it is not yet running. Then, execute R commands passed as a string and return the output as a string. If your command fails to run in R, an error message will be displayed. Example: my $out = $R->run( q`print( 1 + 2 )` ); If you intend on runnning many R commands, it may be convenient to pass an array of commands or put multiple commands in an here-doc: # Array of R commands: my $out1 = $R->run( q`a <- 2`, q`b <- 5`, q`c <- a * b`, q`print("ok")` ); # Here-doc with multiple R commands: my $cmds = <run($cmds); To run commands from a file, see the run_from_file() method. The output you get from run() is the combination of what R would display on the standard output and the standard error, but the order may differ. When loading modules, some may write numerous messages on standard error. You can disable this behavior using the following R command: suppressPackageStartupMessages(library(library_to_load)) =item run_from_file() Similar to run() but reads the R commands from the specified file. Internally, this method uses the R source() command to read the file. =item set() Set the value of an R variable (scalar or arrayref). Example: $R->set( 'x', 'pear' ); or $R->set( 'y', [1, 2, 3] ); =item get() Get the value of an R variable (scalar or arrayref). Example: my $x = $R->get( 'x' ); # $y is an scalar or my $y = $R->get( 'y' ); # $x is an arrayref =item start() Explicitly start R. Most times, you do not need to do that because the first execution of run() or set() will automatically call start(). =item stop() Stop a running instance of R. =item restart() stop() and start() R. =item bin() Get or set the path to the R executable. =item is_shared() Was R started in shared mode? =item is_started() Is R running? =item pid() Return the pid of the running R process =back =head1 INSTALLATION Since I relies on R to work, you need to install R first. See this page for downloads, L. If R is in your PATH environment variable, then it should be available from a terminal and be detected automatically by I. This means that you don't have to do anything on Linux systems to get I working. On Windows systems, in addition to the folders described in PATH, the usual suspects will be checked for the presence of the R binary, e.g. C:\Program Files\R. If I does not find R installation, your last recourse is to specify its full path when calling new(): my $R = Statistics::R->new( r_bin => $fullpath ); You also need to have the following CPAN Perl modules installed: =over 4 =item Text::Balanced (>= 1.97) =item Regexp::Common =item IPC::Run =back =head1 SEE ALSO =over 4 =item * L =item * L =item * The R-project web site: L =item * Statistics:: modules for Perl: L =back =head1 AUTHORS Florent Angly Eflorent.angly@gmail.comE (2011 rewrite) Graciliano M. P. Egm@virtuasites.com.brE (original code) =head1 MAINTAINER Brian Cassidy Ebricas@cpan.orgE =head1 COPYRIGHT & LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 BUGS All complex software has bugs lurking in it, and this program is no exception. If you find a bug, please report it on the CPAN Tracker of Statistics::R: L Bug reports, suggestions and patches are welcome. The Statistics::R code is developed on Github (L) and is under Git revision control. To get the latest revision, run: git clone git@github.com:bricas/statistics-r.git =cut sub new { # Create a new R communication object my ($class, %args) = @_; my $self = {}; bless $self, ref($class) || $class; $self->initialize( %args ); return $self; } sub is_shared { # Get (/ set) the whether or not Statistics::R is setup to run in shared mode my ($self, $val) = @_; if (defined $val) { $self->{is_shared} = $val; } return $self->{is_shared}; } { no warnings 'redefine'; sub start { my ($self, %args) = @_; my $status = 1; if (not $self->is_started) { # If shared mode option of start() requested, rebuild the bridge in shared # mode. Don't use this option though. It is only here to cater for the legacy # method start_shared() if ( exists($args{shared}) && ($args{shared} == 1) ) { $self->is_shared( 1 ); $self->bridge( 1 ); } # Now, start R my $bridge = $self->bridge; $status = $bridge->start or die "Error starting $prog: $?\n"; $self->bin( $bridge->{KIDS}->[0]->{PATH} ); } return $status; } } sub stop { my ($self) = @_; my $status = 1; if ($self->is_started) { $status = $self->bridge->finish or die "Error stopping $prog: $?\n"; } return $status; } sub restart { my ($self) = @_; return $self->stop && $self->start; } sub is_started { # Query whether or not R is currently running return shift->bridge->{STATE} eq IPC::Run::_started ? 1 : 0; } sub pid { # Get (/ set) the PID of the running R process. It is accessible only after # the bridge has start()ed return shift->bridge->{KIDS}->[0]->{PID}; } sub bin { # Get / set the full path to the R binary program to use. Unless you have set # the path yourself, it is accessible only after the bridge has start()ed my ($self, $val) = @_; if (defined $val) { $self->{bin} = $val; } return $self->{bin}; } sub run { # Pass the input and get the output my ($self, @cmds) = @_; # Need to start R now if it is not already running $self->start if not $self->is_started; # Process each command my $results = ''; for my $cmd (@cmds) { # Wrap command for execution in R $self->stdin( $self->wrap_cmd($cmd) ); # Pass input to R and get its output my $bridge = $self->bridge; while ( $self->stdout !~ m/$eos_re/gc && $bridge->pumpable ) { $bridge->pump; } # Parse outputs, detect errors my $out = $self->stdout; $out =~ s/$eos_re//g; chomp $out; my $err = $self->stderr; chomp $err; if ($out =~ m//sg) { # Parse (multi-line) error message my $err_msg = $1."\n".$err; die "Problem running the R command:\n$cmd\n\nGot the error:\n$err_msg\n"; } # Save results and reinitialize $results .= "\n" if $results; $results .= $err.$out; $self->stdout(''); $self->stderr(''); } $self->result($results); return $results; } sub run_from_file { my ($self, $file) = @_; my $results = $self->run( qq`source('$file')` ); return $results; } sub set { # Assign a variable or array of variables in R. Use undef if you want to # assign NULL to an R variable my ($self, $varname, $arr) = @_; # Check variable type, convert everything into an arrayref my $ref = ref $arr; if ($ref eq '') { # This is a scalar $arr = [ $arr ]; } elsif ($ref eq 'ARRAY') { # This is an array reference, nothing to do } else { die "Error: Import variable of type $ref is not supported\n"; } # Quote strings and nullify undef variables for (my $i = 0; $i < scalar @$arr; $i++) { if (defined $$arr[$i]) { if ( $$arr[$i] !~ /^$RE{num}{real}$/ ) { $$arr[$i] = '"'.$$arr[$i].'"'; } } else { $$arr[$i] = 'NULL'; } } # Build a string and run it to import data my $cmd = $varname.' <- c('.join(', ',@$arr).')'; $self->run($cmd); return 1; } sub get { # Get the value of an R variable my ($self, $varname) = @_; my $string = $self->run(qq`print($varname)`); # Parse R output my $value; if ($string eq 'NULL') { $value = undef; } elsif ($string =~ m/^\s*\[\d+\]/) { # Vector: its string look like: # ' [1] 6.4 13.3 4.1 1.3 14.1 10.6 9.9 9.6 15.3 # [16] 5.2 10.9 14.4' my @lines = split /\n/, $string; for (my $i = 0; $i < scalar @lines; $i++) { $lines[$i] =~ s/^\s*\[\d+\] //; } $value = join ' ', @lines; } else { my @lines = split /\n/, $string; if (scalar @lines == 2) { # String looks like: ' mean # 10.41111 ' # Extract value from second line $value = $lines[1]; $value =~ s/^\s*(\S+)\s*$/$1/; } else { #die "Error: Don't know how to handle this R output\n$string\n"; $value = $string; } } # Clean my @arr; if (not defined $value) { @arr = ( undef ); } else { # Split string into an array, paying attention to strings containing spaces @arr = extract_multiple( $value, [sub { extract_delimited($_[0],q{ '"}) },] ); for (my $i = 0; $i < scalar @arr; $i++) { my $elem = $arr[$i]; if ($elem =~ m/^\s*$/) { # Remove elements that are simply whitespaces splice @arr, $i, 1; $i--; } else { # Trim whitespaces $arr[$i] =~ s/^\s*(.*?)\s*$/$1/; # Remove double-quotes $arr[$i] =~ s/^"(.*)"$/$1/; } } } # Return either a scalar of an arrayref my $ret_val; if (scalar @arr == 1) { $ret_val = $arr[0]; } else { $ret_val = \@arr; } return $ret_val; } #---------- INTERNAL METHODS --------------------------------------------------# sub initialize { my ($self, %args) = @_; # Path of R binary my $bin; if ( $args{ r_bin } || $args{ R_bin } ) { $bin = $args{ r_bin } || $args{ R_bin }; } else { $bin = $prog; # IPC::Run will find the full path for the program later } $self->bin( $bin ); # Using shared mode? if ( exists($args{shared}) && ($args{shared} == 1) ) { $self->is_shared( 1 ); } else { $self->is_shared( 0 ); } # Build the bridge $self->bridge( 1 ); return 1; } sub bridge { # Get or build the communication bridge and IOs with R my ($self, $build) = @_; if ($build) { my $cmd = [ $self->bin, '--vanilla', '--slave' ]; if (not $self->is_shared) { my ($stdin, $stdout, $stderr); $self->{stdin} = \$stdin; $self->{stdout} = \$stdout; $self->{stderr} = \$stderr; $self->{bridge} = harness $cmd, $self->{stdin}, $self->{stdout}, $self->{stderr}; } else { $self->{stdin} = \$SHARED_STDIN ; $self->{stdout} = \$SHARED_STDOUT; $self->{stderr} = \$SHARED_STDERR; if (not defined $SHARED_BRIDGE) { # The first Statics::R instance builds the bridge $SHARED_BRIDGE = harness $cmd, $self->{stdin}, $self->{stdout}, $self->{stderr}; } $self->{bridge} = $SHARED_BRIDGE; } } return $self->{bridge}; } sub stdin { # Get / set standard input string for R my ($self, $val) = @_; if (defined $val) { ${$self->{stdin}} = $val; } return ${$self->{stdin}}; } sub stdout { # Get / set standard output string for R my ($self, $val) = @_; if (defined $val) { ${$self->{stdout}} = $val; } return ${$self->{stdout}}; } sub stderr { # Get / set standard error string for R my ($self, $val) = @_; if (defined $val) { ${$self->{stderr}} = $val; } return ${$self->{stderr}}; } sub result { # Get / set result of last R command my ($self, $val) = @_; if (defined $val) { $self->{result} = $val; } return $self->{result}; } sub wrap_cmd { # Wrap a command to pass to R. Whether the command is successful or not, the # end of stream string will appear on stdout and indicate that R has finished # processing the data. Note that $cmd can be multiple R commands. my ($self, $cmd) = @_; # Escape double-quotes $cmd =~ s/"/\\"/g; # Evaluate command (and catch syntax and runtime errors) $cmd = qq`tryCatch( eval(parse(text="$cmd")) , error = function(e){print(e)} ); write("$eos",stdout())\n`; return $cmd; } 1; Statistics-R-0.24/lib/Statistics/R/0000755000175000017500000000000011656373117017323 5ustar flofloooflofloooStatistics-R-0.24/lib/Statistics/R/Legacy.pm0000644000175000017500000000614011627276441021066 0ustar floflooofloflooopackage Statistics::R::Legacy; use strict; use warnings; use base qw( Statistics::R ); use vars qw{@ISA @EXPORT}; BEGIN { @ISA = 'Exporter'; @EXPORT = qw{ startR stopR restartR Rbin start_sharedR start_shared read receive is_blocked is_locked receive lock unlock send error clean_up }; } =head1 NAME Statistics::R::Legacy - Legacy methods for Statistics::R =head1 DESCRIPTION This module contains legacy methods for I. They are provided solely so that code that uses older versions of I does not crash with recent version. Do not use these methods in new code! Some of these legacy methods simply had their name changed, but some others were changed to do nothing and return only single value because it did not make sense to keep these methods as originally intended anymore. =head1 METHODS =over 4 =item startR() This is the same thing as start(). =item stopR() This is the same thing as stop(). =item restartR() This is the same thing as restart(). =item Rbin() This is the same thing as bin(). =item start_sharedR() / start_shared() Use the shared option of new() instead. =item send / read() / receive() Use run() instead. =item lock() Does nothing anymore. =item unlock() Does nothing anymore. =item is_blocked() / is_locked() Return 0. =item Return the empty string. =item clean_up() Does nothing anymore. =back =head1 SEE ALSO =over 4 =item * L =back =head1 AUTHORS Florent Angly Eflorent.angly@gmail.comE (2011 rewrite) Graciliano M. P. Egm@virtuasites.com.brE (original code) =head1 MAINTAINER Brian Cassidy Ebricas@cpan.orgE =head1 COPYRIGHT & LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 BUGS All complex software has bugs lurking in it, and this program is no exception. If you find a bug, please report it on the CPAN Tracker of Statistics::R: L Bug reports, suggestions and patches are welcome. The Statistics::R code is developed on Github (L) and is under Git revision control. To get the latest revision, run: git clone git@github.com:bricas/statistics-r.git =cut { # Prevent "Name XXX used only once" warnings in this block no warnings 'once'; *startR = \&Statistics::R::start; *stopR = \&Statistics::R::stop; *restartR = \&Statistics::R::restart; *Rbin = \&Statistics::R::bin; *receive = \&Statistics::R::result; *start_sharedR = \&start_shared; *read = \&receive; *is_blocked = \&is_locked; } sub start_shared { my $self = shift; $self->start( shared => 1 ); } sub lock { return 1; } sub unlock { return 1; } sub is_locked { return 0; } sub send { # Send a command to R. Do not return the output. my ($self, $cmd) = @_; $self->run($cmd); return 1; } sub error { return ''; } sub clean_up { return 1; } 1; Statistics-R-0.24/lib/Statistics/R/Win32.pm0000644000175000017500000001027211627276447020573 0ustar floflooofloflooopackage Statistics::R::Win32; use strict; use warnings; use File::Spec::Functions; use File::DosGlob qw( glob ); use Env qw( @PATH $PROGRAMFILES ); use vars qw{@ISA @EXPORT}; BEGIN { @ISA = 'Exporter'; @EXPORT = qw{ win32_path_adjust win32_space_quote win32_space_escape win32_double_bs }; } our $PROG = 'R'; =head1 NAME Statistics::R::Win32 - Helper functions for Statistics::R on MS Windows platforms =head1 DESCRIPTION Helper functions to deal with environment variables and escape file paths on MS Windows platforms. =head1 SYNOPSIS if ( $^O =~ m/^(?:.*?win32|dos)$/i ) { require Statistics::R::Win32; } =head1 METHODS =over 4 =item win32_path_adjust( ) Looks for paths where R could be installed, e.g. C:\Program Files (x86)\R-2.1\bin and add it to the PATH environment variable. =item win32_space_quote( ) Takes a path and return a path that is surrounded by double-quotes if the path contains whitespaces. Example: C:\Program Files\R\bin\x64 becomes "C:\Program Files\R\bin\x64" =item win32_space_escape( ) Takes a path and return a path where spaces have been escaped by a backslash. contains whitespaces. Example: C:\Program Files\R\bin\x64 becomes C:\Program\ Files\R\bin\x64 =item win32_double_bs Takes a path and return a path where each backslash was replaced by two backslashes. Example: C:\Program Files\R\bin\x64 becomes C:\\Program Files\\R\\bin\\x64 =back =head1 SEE ALSO =over 4 =item * L =back =head1 AUTHORS Florent Angly Eflorent.angly@gmail.comE (2011 rewrite) Graciliano M. P. Egm@virtuasites.com.brE (original code) =head1 MAINTAINER Brian Cassidy Ebricas@cpan.orgE =head1 COPYRIGHT & LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 BUGS All complex software has bugs lurking in it, and this program is no exception. If you find a bug, please report it on the CPAN Tracker of Statistics::R: L Bug reports, suggestions and patches are welcome. The Statistics::R code is developed on Github (L) and is under Git revision control. To get the latest revision, run: git clone git@github.com:bricas/statistics-r.git =cut # Adjust PATH environment variable when this module is loaded. win32_path_adjust(); sub win32_path_adjust { # Find potential R directories in the Windows Program Files folder and add # them to the PATH environment variable # Find potential R directories, e.g. C:\Program Files (x86)\R-2.1\bin # or C:\Program Files\R\bin\x64 my @r_dirs; my @prog_file_dirs; if (defined $PROGRAMFILES) { push @prog_file_dirs, $PROGRAMFILES; # e.g. C:\Program Files (x86) my ($programfiles_2) = ($PROGRAMFILES =~ m/^(.*) \(/); # e.g. C:\Program Files push @prog_file_dirs, $programfiles_2 if not $programfiles_2 eq $PROGRAMFILES; } for my $prog_file_dir ( @prog_file_dirs ) { next if not -d $prog_file_dir; my @subdirs; my @globs = ( catfile($prog_file_dir, $PROG), catfile($prog_file_dir, $PROG.'-*') ); for my $glob ( @globs ) { $glob = win32_space_escape( win32_double_bs( $glob ) ); push @subdirs, glob $glob; # DosGlob } for my $subdir (@subdirs) { my $subdir2 = catfile($subdir, 'bin'); if ( -d $subdir2 ) { my $subdir3 = catfile($subdir2, 'x64'); if ( -d $subdir3 ) { push @r_dirs, $subdir3; } push @r_dirs, $subdir2; } push @r_dirs, $subdir; } } # Append R directories to PATH (order is important) push @PATH, @r_dirs; return 1; } sub win32_space_quote { # Quote a path if it contains whitespaces my $path = shift; $path = '"'.$path.'"' if $path =~ /\s/; return $path; } sub win32_space_escape { # Escape spaces with a single backslash my $path = shift; $path =~ s/ /\\ /g; return $path; } sub win32_double_bs { # Double the backslashes my $path = shift; $path =~ s/\\/\\\\/g; return $path; } 1; Statistics-R-0.24/Changes0000644000175000017500000000723411656372762015530 0ustar flofloooflofloooRevision history for Perl extension Statistics::R. 0.24 2011-11-09 - Require Text::Balanced >= 0.97 to prevent bad surprises (reported by Ryan Golhar) 0.23 2011-10-28 - Arrays of number-containing strings are now handled properly (RT bug #71988, patch by dheiman) 0.22 2011-10-09 - The run() method now accepts an array of strings as input - New run_from_file() method to read and execute commands from an R file - Better detection of R errors by using the R exception system (issue reported by Mike Imelfort) - Updated error handling mechanism to detect R syntax errors in addition to R runtime errors - Tests now work for different locales (issue reported by Knut Behrends) 0.21 2011-09-04 - Tweaked the regular expressions that parse the R output stream for added speed and robustness 0.20 2011-08-31 - Refactored the entire R communication bridge to avoid writing and reading files. All data is now stored in memory and passed by pipes. This fixes bug RT #11309, #11918, #66190 and #70314 - Refactored the communications in shared mode - Put platform-specific code and legacy code in separate modules 0.10 2011-08-27 - Refactoring to remove old code doing platform-specific operations. - Lots of code cleanup - Removed the now useless r_dir and tmp_dir options of new() - Fix for change of dir bug (RT #6724). Also fixes missing synopsis file (RT #70307) - More subtle cleanup procedure (RT #70392) 0.09 2011-08-23 - Changes in the new() method: * it automatically calls start() * it has the 'shared' option to start a shared bridge - More portable filenames (RT #70391) - Added convenience methods: * run() replaces send() and read() and checks for errors (RT #70361) * get() fetches the values in an R vector (RT #70361) * set() assigns values to an R vector - Fixed a bug in the unlock() method - Removed the R() and error() methods and renamed some other. These changes should be transparent and backward compatible - Maintenance: many more unit tests, synopsis clarification, POD work, script touchups, small code cleanups, version numbering, better README generation, Git and bug tracker URLs 0.08 2011-03-01 - Pass options in new() to Statistics::R::Bridge constructor (RT #63906) 0.07 2010-11-08 - Tidy up SYNOPSIS (RT #62776) - Fix undef warning on Win32 (RT #62776) - Fix is_started() method (RT #62776) 0.06 2010-09-17 - Fix error() when used as an accessor (RT #61335) - Silence DESTROY() when R is not found - Fix "uninitialized value" warning in read_processR() (RT #61414) 0.05 2010-09-13 - Major code refactor: - strict + warnings wherever possible - Removed some layers of abstraction - Win32/Linux classes are now simple subs - Basic syntax tidying - POD fix, plus pod test - Skip tests if R is not available 0.04 2010-08-28 - Basic code cleanup with the intention of doing major refactoring by-and-by - Fix the test suite 0.03 2008-08-16 - Fixed RT Bug #23948: bug in Statistics::R - Fixed --gui - RT Bug #17925: R --slave --vanilla --gui=none is now R --slave --vanilla --gui=X11 - RT Bug #20515: Fwd: Delivery Status Notification (Failure) - RT Bug #14324: error message with recent versions of R We used the patch from barry.moore since it correctly identifies that we probably don't want the GUI. - Fixed RT Bug #17956: Win32: log_dir is not in tmp_dir by default as advertised 0.02 2004-02-23 - Just minor changes and POD fix. 0.01 2004-01-29 23:04:46 - original version; Statistics-R-0.24/README0000644000175000017500000001446411656373051015110 0ustar flofloooflofloooNAME Statistics::R - Perl interface with the R statistical program DESCRIPTION *Statistics::R* is a module to controls the R interpreter (R project for statistical computing: ). It lets you start R, pass commands to it and retrieve the output. A shared mode allow to have several instances of *Statistics::R* talk to the same R process. The current *Statistics::R* implementation uses pipes (for stdin, stdout and and stderr) to communicate with R. This implementation should be more efficient and reliable than that in previous version, which relied on reading and writing files. As before, this module works on GNU/Linux, MS Windows and probably many more systems. SYNOPSIS use Statistics::R; # Create a communication bridge with R and start R my $R = Statistics::R->new(); # Run simple R commands my $output_file = "file.ps"; $R->run(qq`postscript("$output_file" , horizontal=FALSE , width=500 , height=500 , pointsize=1)`); $R->run(q`plot(c(1, 5, 10), type = "l")`); $R->run(q`dev.off()`); # Pass and retrieve data (scalars or arrays) my $input_value = 1; $R->set('x', $input_value); $R->run(q`y <- x^2`); my $output_value = $R->get('y'); print "y = $output_value\n"; $R->stop(); METHODS new() Build a *Statistics::R* bridge object between Perl and R. Available options are: r_bin Specify the full path to R if it is not automatically found. See INSTALLATION. shared Start a shared bridge. When using a shared bridge, several instances of Statistics::R can communicate with the same unique R instance. Example: use Statistics::R; my $R1 = Statistics::R->new( shared => 1); my $R2 = Statistics::R->new( shared => 1); $R1->set( 'x', 'pear' ); my $x = $R2->get( 'x' ); print "x = $x\n"; Do not call the *stop()* method is you still have processes that need to interact with R. run() First, start() R if it is not yet running. Then, execute R commands passed as a string and return the output as a string. If your command fails to run in R, an error message will be displayed. Example: my $out = $R->run( q`print( 1 + 2 )` ); If you intend on runnning many R commands, it may be convenient to pass an array of commands or put multiple commands in an here-doc: # Array of R commands: my $out1 = $R->run( q`a <- 2`, q`b <- 5`, q`c <- a * b`, q`print("ok")` ); # Here-doc with multiple R commands: my $cmds = <run($cmds); To run commands from a file, see the run_from_file() method. The output you get from run() is the combination of what R would display on the standard output and the standard error, but the order may differ. When loading modules, some may write numerous messages on standard error. You can disable this behavior using the following R command: suppressPackageStartupMessages(library(library_to_load)) run_from_file() Similar to run() but reads the R commands from the specified file. Internally, this method uses the R source() command to read the file. set() Set the value of an R variable (scalar or arrayref). Example: $R->set( 'x', 'pear' ); or $R->set( 'y', [1, 2, 3] ); get() Get the value of an R variable (scalar or arrayref). Example: my $x = $R->get( 'x' ); # $y is an scalar or my $y = $R->get( 'y' ); # $x is an arrayref start() Explicitly start R. Most times, you do not need to do that because the first execution of run() or set() will automatically call start(). stop() Stop a running instance of R. restart() stop() and start() R. bin() Get or set the path to the R executable. is_shared() Was R started in shared mode? is_started() Is R running? pid() Return the pid of the running R process INSTALLATION Since *Statistics::R* relies on R to work, you need to install R first. See this page for downloads, . If R is in your PATH environment variable, then it should be available from a terminal and be detected automatically by *Statistics::R*. This means that you don't have to do anything on Linux systems to get *Statistics::R* working. On Windows systems, in addition to the folders described in PATH, the usual suspects will be checked for the presence of the R binary, e.g. C:\Program Files\R. If *Statistics::R* does not find R installation, your last recourse is to specify its full path when calling new(): my $R = Statistics::R->new( r_bin => $fullpath ); You also need to have the following CPAN Perl modules installed: Text::Balanced (>= 1.97) Regexp::Common IPC::Run SEE ALSO * Statistics::R::Win32 * Statistics::R::Legacy * The R-project web site: * Statistics:: modules for Perl: AUTHORS Florent Angly (2011 rewrite) Graciliano M. P. (original code) MAINTAINER Brian Cassidy COPYRIGHT & LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. BUGS All complex software has bugs lurking in it, and this program is no exception. If you find a bug, please report it on the CPAN Tracker of Statistics::R: Bug reports, suggestions and patches are welcome. The Statistics::R code is developed on Github () and is under Git revision control. To get the latest revision, run: git clone git@github.com:bricas/statistics-r.git Statistics-R-0.24/MANIFEST0000644000175000017500000000102511656373114015346 0ustar flofloooflofloooChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/External.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Statistics/R.pm lib/Statistics/R/Legacy.pm lib/Statistics/R/Win32.pm Makefile.PL MANIFEST This list of files META.yml README t/00-load.t t/01-pod.t t/02-legacy.t t/03-run.t t/04-start-stop.t t/05-shared.t t/06-get-set.t t/07-robust.t t/08-errors.t t/data/script.R Statistics-R-0.24/META.yml0000644000175000017500000000150711656373051015473 0ustar floflooofloflooo--- abstract: 'Perl interface with the R statistical program' author: - 'Florent Angly (2011 rewrite)' build_requires: ExtUtils::MakeMaker: 6.56 Test::More: 0.47 configure_requires: ExtUtils::MakeMaker: 6.56 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.04' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Statistics-R no_index: directory: - inc - t requires: IPC::Run: 0 Regexp::Common: 0 Text::Balanced: 1.97 perl: 5.6.0 resources: bugtracker: http://rt.cpan.org/Dist/Display.html?Name=Statistics-R homepage: http://search.cpan.org/search?query=statistics%3A%3AR&mode=dist license: http://dev.perl.org/licenses/ repository: git@github.com:bricas/statistics-r.git version: 0.24 Statistics-R-0.24/inc/0000755000175000017500000000000011656373117014773 5ustar flofloooflofloooStatistics-R-0.24/inc/Module/0000755000175000017500000000000011656373117016220 5ustar flofloooflofloooStatistics-R-0.24/inc/Module/Install.pm0000644000175000017500000003013511656373050020162 0ustar floflooofloflooo#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.04'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2011 Adam Kennedy. Statistics-R-0.24/inc/Module/Install/0000755000175000017500000000000011656373117017626 5ustar flofloooflofloooStatistics-R-0.24/inc/Module/Install/External.pm0000644000175000017500000000274011656373051021746 0ustar floflooofloflooo#line 1 package Module::Install::External; # Provides dependency declarations for external non-Perl things use strict; use Module::Install::Base (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '1.04'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub requires_external_cc { my $self = shift; # We need a C compiler, use the can_cc method for this unless ( $self->can_cc ) { print "Unresolvable missing external dependency.\n"; print "This package requires a C compiler.\n"; print STDERR "NA: Unable to build distribution on this platform.\n"; exit(0); } # Unlike some of the other modules, while we need to specify a # C compiler as a dep, it needs to be a build-time dependency. 1; } sub requires_external_bin { my ($self, $bin, $version) = @_; if ( $version ) { die "requires_external_bin does not support versions yet"; } # Load the package containing can_run early, # to avoid breaking the message below. $self->load('can_run'); # Locate the bin print "Locating bin:$bin..."; my $found_bin = $self->can_run( $bin ); if ( $found_bin ) { print " found at $found_bin.\n"; } else { print " missing.\n"; print "Unresolvable missing external dependency.\n"; print "Please install '$bin' seperately and try again.\n"; print STDERR "NA: Unable to build distribution on this platform.\n"; exit(0); } # Once we have some way to specify external deps, do it here. # In the mean time, continue as normal. 1; } 1; __END__ #line 138 Statistics-R-0.24/inc/Module/Install/Makefile.pm0000644000175000017500000002701211656373051021700 0ustar floflooofloflooo#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my ($v) = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 540 Statistics-R-0.24/inc/Module/Install/Can.pm0000644000175000017500000000333311656373051020664 0ustar floflooofloflooo#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Statistics-R-0.24/inc/Module/Install/WriteAll.pm0000644000175000017500000000237611656373051021714 0ustar floflooofloflooo#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Statistics-R-0.24/inc/Module/Install/Metadata.pm0000644000175000017500000004327711656373051021716 0ustar floflooofloflooo#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Statistics-R-0.24/inc/Module/Install/Win32.pm0000644000175000017500000000340311656373051021063 0ustar floflooofloflooo#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Statistics-R-0.24/inc/Module/Install/Base.pm0000644000175000017500000000214711656373051021037 0ustar floflooofloflooo#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.04'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Statistics-R-0.24/inc/Module/Install/Fetch.pm0000644000175000017500000000462711656373051021223 0ustar floflooofloflooo#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Statistics-R-0.24/Makefile.PL0000644000175000017500000000160611656372405016176 0ustar floflooofloflooouse strict; use warnings; use inc::Module::Install; use lib 'lib'; if ( $^O =~ m/^(?:.*?win32|dos)$/i ) { require Statistics::R::Win32; } name 'Statistics-R'; all_from 'lib/Statistics/R.pm'; resources homepage 'http://search.cpan.org/search?query=statistics%3A%3AR&mode=dist'; bugtracker 'http://rt.cpan.org/Dist/Display.html?Name=Statistics-R'; repository 'git@github.com:bricas/statistics-r.git'; build_requires 'Test::More' => '0.47'; requires 'Text::Balanced' => '1.97'; requires 'Regexp::Common' => '0'; requires 'IPC::Run' => '0'; requires_external_bin 'R'; WriteAll; if ( -e 'MANIFEST.SKIP' ) { generate_readme( 'lib/Statistics/R.pm', 'README' ); } sub generate_readme { my ($in, $out) = @_; `pod2text $in $out`; warn "Warning: Could not generate $out.\n$!\n" if $? == -1; return $?; # exit status } Statistics-R-0.24/t/0000755000175000017500000000000011656373117014465 5ustar flofloooflofloooStatistics-R-0.24/t/02-legacy.t0000644000175000017500000000137611627103745016340 0ustar floflooofloflooo#! perl use strict; use warnings; use Test::More; use Statistics::R; plan tests => 20; my $R; my $file = "file.ps"; ok $R = Statistics::R->new(); ok $R->startR(); ok $R->restartR(); ok $R->send(qq`postscript("$file" , horizontal=FALSE , width=500 , height=500 , pointsize=1)`); ok $R->send( q`plot(c(1, 5, 10), type = "l")` ); ok $R->send( qq`x = 123 \n print(x)` ); my $ret = $R->read(); ok $ret =~ /^\[\d+\]\s+123\s*$/; ok $R->send( qq`x = 456 \n print(x)` ); $ret = $R->read(); ok $ret =~ /^\[\d+\]\s+456\s*$/; ok $R->lock; ok $R->unlock; is $R->is_blocked, 0; is $R->is_locked, 0; ok $R->clean_up(); ok $R->Rbin() =~ /\S+/; ok $R->stopR(); is $R->error(), ''; ok $R->start_shared(); ok $R->start_sharedR(); ok $R->stop(); unlink $file; Statistics-R-0.24/t/03-run.t0000644000175000017500000000331311644252020015660 0ustar floflooofloflooo#! perl use strict; use warnings; use Test::More; use Statistics::R; plan tests => 15; my ($R, $expected); my $file = 'file.ps'; ok $R = Statistics::R->new(); ok $R->bin() =~ /\S+/, 'Binary'; $expected = ''; is $R->run( ), $expected; $expected = ''; is $R->run( qq`postscript("$file" , horizontal=FALSE , width=500 , height=500 , pointsize=1)`), $expected, 'Basic'; $expected = ''; is $R->run( q`plot(c(1, 5, 10), type = "l")` ), $expected; $expected = 'null device 1 '; is $R->run( q`dev.off()` ), $expected; # RT bug #66190 ok -e $file; # RT bug #70307 unlink $file; $expected = 'loop iteration 1 loop iteration 2 loop iteration 3'; is $R->run( q`for (j in 1:3) { cat("loop iteration "); cat(j); cat("\n") }` ), $expected; $expected = 'Some innocuous message on stderr'; is $R->run( q`write("Some innocuous message on stderr", stderr())` ), $expected, 'IO'; $expected = 'Some innocuous message on stdout'; is $R->run( q`write("Some innocuous message on stdout", stdout())` ), $expected; $expected = '[1] 123'; is $R->run( qq`x <- 123 \n print(x)` ), $expected, 'Multi-line commands'; $expected = '456'; my $cmd1 = 'x <- 456 ; write.table(x, file="", row.names=FALSE, col.names=FALSE)'; is $R->run( $cmd1 ), $expected; # RT bug #70314 my $cmd2 = <run( $cmd2 ), $expected, 'Heredoc commands'; $expected = '456 [1] "ok"'; is $R->run( $cmd1, $cmd2 ), $expected, 'Multiple commands'; $expected = 'Some innocuous message on stderr loop iteration: [1] 1 loop iteration: [1] 2 loop iteration: [1] 3 Some innocuous message on stdout [1] 123 456 [1] "ok"'; is $R->run_from_file( './t/data/script.R' ), $expected, 'Commands from file'; Statistics-R-0.24/t/06-get-set.t0000644000175000017500000000433411652377621016451 0ustar floflooofloflooo#! perl use strict; use warnings; use Test::More; use Statistics::R; plan tests => 86; my ($R, $input, $output); ok $R = Statistics::R->new(); $input = undef; ok $R->set('x', $input), 'undef'; is $R->get('x'), undef; $input = 123; ok $R->set('x', $input); ok $output = $R->get('x'), 'integer'; is ref($output), ''; is $output, 123; # R default number of digits is 7 $input = 0.93945768644; ok $R->set('x', $input), 'real number'; ok $output = $R->get('x'); is ref($output), ''; is $output, sprintf("%.7f", $input); $input = "apocalypse"; ok $R->set('x', $input), 'string'; ok $output = $R->get('x'); is ref($output), ''; is $output, "apocalypse"; $input = "a string"; ok $R->set('x', $input), 'string with witespace'; ok $output = $R->get('x'); is ref($output), ''; is $output, "a string"; $input = 'gi|57116681|ref|NC_000962.2|'; ok $R->set('x', $input), 'number-containing string'; ok $output = $R->get('x'); is ref($output), ''; is $output, 'gi|57116681|ref|NC_000962.2|'; # Mixed arrays are considered as string arrays by R, thus there is no digit limit $input = [123, "a string", 'two strings', 0.93945768644]; ok $R->set('x', $input), 'mixed array'; ok $output = $R->get('x'); is ref($output), 'ARRAY'; is $$output[0], 123; is $$output[1], "a string"; is $$output[2], "two strings"; is $$output[3], 0.93945768644; # RT bug #71988 $input = [ q{statistics-r-0.22}, "abc 123 xyz", 'gi|57116681|ref|NC_000962.2|']; ok $R->set('x', $input), 'array of number-containing strings'; ok $output = $R->get('x'); is ref($output), 'ARRAY'; is $$output[0], q{statistics-r-0.22}; is $$output[1], "abc 123 xyz"; is $$output[2], 'gi|57116681|ref|NC_000962.2|'; $input = [123,142,147,153,145,151,165,129,133,150,142,154,131,146,151,136,147,156,141,155,147,165,168,146,148,146,142,145,161,157,154,137,130,161,130,156,140,145,154]; ok $R->set('x', $input), 'large array of integers'; ok $output = $R->get('x'); is ref($output), 'ARRAY'; for (my $i = 0; $i < scalar @$input; $i++) { is $$output[$i], $$input[$i]; } $input = [1, 2, 3]; ok $R->set('x', $input), 'data frame'; is $R->run(q`a <- data.frame(first=x)`), ''; ok $output = $R->get('a$first'); is ref($output), 'ARRAY'; is $$output[0], 1; is $$output[1], 2; is $$output[2], 3; ok $R->stop(); Statistics-R-0.24/t/01-pod.t0000644000175000017500000000024511624411262015640 0ustar floflooofloflooo#! perl use strict; use warnings; use Test::More; eval 'use Test::Pod 1.00'; plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; all_pod_files_ok(); Statistics-R-0.24/t/04-start-stop.t0000644000175000017500000000100611627102467017204 0ustar floflooofloflooo#! perl use strict; use warnings; use Test::More; use Statistics::R; use Cwd; plan tests => 16; my $R; my $initial_dir = cwd; ok $R = Statistics::R->new(); is $R->is_started, 0; is $R->is_shared, 0; ok $R->stop(); ok $R->stop(); ok $R->start(); is $R->is_started, 1; is $R->is_shared, 0; ok $R->start(); is cwd, $initial_dir; # Bug RT #6724 and #70307 ok $R->restart(); ok $R->stop(); ok $R->start( shared => 1); is $R->is_shared, 1; ok $R->stop(); is cwd, $initial_dir; # Bug RT #6724 and #70307 Statistics-R-0.24/t/07-robust.t0000644000175000017500000000070411630552204016401 0ustar floflooofloflooo#! perl use strict; use warnings; use Test::More; use Statistics::R; plan tests => 10003; # Test that the IOs are well-oiled. In Statistics::R version 0.20, a slight # imprecision in the regular expression to parse the output stream caused a # problem was apparent only once every few thousands times my ($R, $input); ok $R = Statistics::R->new(); ok $R->set('x', $input); for my $i (1 .. 10000) { is($R->get('x'), undef); } ok $R->stop(); Statistics-R-0.24/t/08-errors.t0000644000175000017500000000046411644253202016404 0ustar floflooofloflooo#! perl use strict; use warnings; use Test::More; use Statistics::R; plan tests => 3; my $R; ok $R = Statistics::R->new(); eval { $R->run( q`print "ASDF"` ); }; ok $@, 'Syntax error'; # Actual error message vary depending on locale eval { $R->run( q`print(ASDF)` ); }; ok $@, 'Runtime error'; Statistics-R-0.24/t/00-load.t0000644000175000017500000000026011624410325015770 0ustar floflooofloflooo#! perl use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'Statistics::R' ); } diag( "Testing Statistics::R $Statistics::R::VERSION, Perl $], $^X" ); Statistics-R-0.24/t/data/0000755000175000017500000000000011656373117015376 5ustar flofloooflofloooStatistics-R-0.24/t/data/script.R0000644000175000017500000000066411644255612017027 0ustar floflooofloflooopostscript("file2.ps" , horizontal=FALSE , width=500 , height=500 , pointsize=1) plot(c(1, 5, 10), type = "l") dev.off() unlink("file2.ps") for (j in 1:3) { cat("loop iteration: "); print(j); } write("Some innocuous message on stdout\n", stdout()) write("Some innocuous message on stderr\n", stderr()) x <- 123 print(x) x <- 456 ; write.table(x, file="", row.names=FALSE, col.names=FALSE) a <- 2 b <- 5 c <- a * b print('ok') Statistics-R-0.24/t/05-shared.t0000644000175000017500000000164011627062006016331 0ustar floflooofloflooo#! perl use strict; use warnings; use Test::More; use Statistics::R; plan tests => 29; my ($R1, $R2, $R3, $R4); ok $R1 = Statistics::R->new( shared => 1 ), 'Starting in shared mode'; ok $R2 = Statistics::R->new( shared => 1 ); ok $R3 = Statistics::R->new( shared => 1 ); ok $R4 = Statistics::R->new( shared => 1 ); is $R1->is_shared, 1; is $R2->is_shared, 1; is $R3->is_shared, 1; is $R4->is_shared, 1; ok $R2->start; ok $R4->start; is $R1->is_started, 1; is $R2->is_started, 1; is $R3->is_started, 1; is $R4->is_started, 1; ok $R1 =~ m/\d+/, 'PIDs'; is $R1->pid, $R2->pid; is $R1->pid, $R3->pid; is $R1->pid, $R4->pid; ok $R1->set( 'x', "string" ), 'Sharing data'; ok $R2->set( 'y', 3 ); is $R2->get( 'x' ), "string"; ok $R3->set( 'z', 10 ); is $R4->run( q`a <- y / z` ), ''; is $R4->get( 'a' ), 0.3; ok $R3->stop(); is $R1->is_started, 0; is $R2->is_started, 0; is $R3->is_started, 0; is $R4->is_started, 0;