view release on metacpan or  search on metacpan

lib/Data/Rlist.pm  view on Meta::CPAN

    $opts = { %$opts };
    $opts->{_base} = ref($base) ? 'some hash' : $base;
    while (my($k, $v) = each %$base) {
        $opts->{$k} = $v unless exists $opts->{$k}
    }

    # Finally complete $opts with "default" and return the new hash.
    $opts = complete_options($opts) unless $using_default;
    $opts
}

sub write($;$$$);
sub write($;$$$)
{
    my($data, $output) = (shift, shift);
    my($options, $header) = @_;
    local $| = 1 if $DEBUG;

    if (ref($data) eq __PACKAGE__) {
        $data->dock(sub {
						$output ||= $data->get('-output');
						$options ||= $data->get('-options');
						$header ||= $data->get('-header');
						Data::Rlist::write($data->get('-data'), $output, $options, $header) });
    } else {
        # $data is any Perl data or undef.  Reset package globals, validate $options, then compile
        # $data.

        my $to_string = ref $output || not defined $output;
        my($result, $optname, $fast, $perl);
        $options ||= ($to_string ? 'string' : 'fast');
        unless (ref $options) {
            $fast = 1 if $options eq 'fast';
            $perl = 1 if $options eq 'perl';
            $optname = "'$options'";
            $options = predefined_options($options) unless $fast || $perl;
        } else {
            $optname = "custom, based on '${\($options->{_base} || 'default')}'";
        }
        unless ($fast || $perl) {
            $options->{auto_quote} = 1 unless defined $options->{auto_quote};
        }

        unless ($to_string) {
            # Compile $data into a file named $output.  Create a new file, exclusively lock it. It
            # is guaranteed that no other process will be able to run flock(FH,2) on the same file
            # while we hold the lock. (Because the OS suspends and blocks other processes.)

            confess $output if not defined $output or ref $output; # or not_valid_pathname($output)
            my($to_stdout, $fh) = $output eq '-';
            if ($to_stdout) {
                open($fh, ">$output") or confess("\nERROR: $!");
            } else {
                (open($fh, ">$output") and flock($fh, 2)) or
                confess("\nERROR: $output: can't create and lock Rlist-file: $!");
            }

            # Build file header.  Compile $data to file $fh, return undef.  

            my $host = eval { use Sys::Hostname; hostname; } || 'some unknown machine';
            my $uid = getlogin || getpwuid($<);
            my $tm = localtime;
            my $prec; $prec = $options->{precision} if ref $options and defined $options->{precision};
            my $eol = $/; $eol = $options->{eol_space} if ref $options and defined $options->{eol_space};
            my @header = 
            map { (length) ? "# $_\n" : "#\n" }
            (($to_stdout ? () : 
              ("-*-rlist-generic-*-", "", $output, "",
               "Created $tm on <$host> by user <$uid>.",
               "Random Lists (Rlist) file (see Data::Rlist on CPAN and <http://www.visualco.de>).")),
             ((defined $prec) ? 
              sprintf('Numerical precision: fixed-point, rounded to %d decimal places.', $prec) :
              sprintf('Numerical precision: floating-point.')),
             "Compile options: $optname.", 
             ($header ? ("", @$header) : ("")));
            print $fh @header, $eol;

            unless ($fast || $perl) {
                $result = 1 if compile($data, $options, $fh);
            } else {
                # Note that we return $Data::Rlist::R here.
                $result = 1;
                print $fh ${compile_fast($data)}.$eol if $fast;
                print $fh ${compile_Perl($data)}.$eol if $perl;
            } close $fh;
        } else {
            # Compile $data into string and return a reference.  Here $output has to be undef or a
            # string-ref (buffer).
            confess $output unless not defined $output or ref $output eq 'SCALAR';
            unless ($fast || $perl) {
                $result = compile($data, $options);
                $output = $result if ref $output;
            } else {
                $result = compile_fast($data) if $fast;
                $result = compile_Perl($data) if $perl;
                $$output = $$result if ref $output; # copy it -> $result is $Data::Rlist::R
            }
        } return $result;
    }
}

sub write_csv($;$$$$);
sub write_csv($;$$$$)
{
    my($data, $output) = (shift, shift);
    my($options, $columns, $header) = @_;
    return 0 unless defined $data;

    if (ref($data) eq __PACKAGE__) {
        $data->dock(sub {
						$output ||= $data->get('-output');
						$options ||= $data->get('-options');
						$columns ||= $data->get('-columns');
						$header ||= $data->get('-header');
						Data::Rlist::write_csv($data->get('-data'), $output, $options, $columns, $header) });
    } else {
        # $data is anything.  In case of undef returns 0.  When the file could not be created,
        # dies. Otherwise returns 1.
        #
        # Unless a value looks like a number the value is quoted (strings may have commas).
        # read_csv uses split_quoted which keeps quotes and backslashes, then maybe_unquote7()s