initial xerl import to utils

1 files changed, 186 insertions, 0 deletions

diff --git a/Xerl/Tools/FileIO.pm b/Xerl/Tools/FileIO.pm
new file mode 100644
index 0000000..6117bd0
--- /dev/null
+++ b/Xerl/Tools/FileIO.pm
@@ -0,0 +1,186 @@
+# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow
+#
+# 	E-Mail: xerl@dev.buetow.org 	WWW: http://xerl.buetow.org
+#
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are met:
+#     * Redistributions of source code must retain the above copyright
+#       notice, this list of conditions and the following disclaimer.
+#     * Redistributions in binary form must reproduce the above copyright
+#       notice, this list of conditions and the following disclaimer in the
+#       documentation and/or other materials provided with the distribution.
+#     * Neither the name of P. B. Labs nor the names of its contributors may
+# 	  be used to endorse or promote products derived from this software
+# 	  without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR
+# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT,
+# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+#  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
+# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+package Xerl::Tools::FileIO;
+
+use strict;
+use warnings;
+
+use Xerl::Base;
+use Xerl::Main::Global;
+
+sub dslurp($;$) {
+    my Xerl::Tools::FileIO $self = $_[0];
+
+    my $path = $self->get_path();
+
+    $path .= '/' unless $path =~ /\/$/;
+    opendir my $dir, $path or Xerl::Main::Global::ERROR( $!, $path, caller() );
+
+    my @dir = sort
+      map  { $path . $_ }
+      grep { /^[^\.]/o } readdir($dir);
+
+    @dir = map { s#.*/([^/]+\..+)$#$1#o; $_ } @dir
+      if $self->basename_exists();
+
+    closedir $dir;
+    $self->set_array( \@dir );
+
+    return undef;
+}
+
+sub fslurp($) {
+    my Xerl::Tools::FileIO $self = $_[0];
+    my $path = SECUREPATH( $self->get_path() );
+
+    Xerl::Main::Global::HTTP( 404, "Not found: $path" )
+      unless -f $path;
+
+    open my $file, $path or Xerl::Main::Global::ERROR( $!, $path, caller() );
+    flock $file, 2;
+
+    my @slurp = <$file>;
+
+    flock $file, 3;
+    close $file;
+
+    $self->set_array( \@slurp );
+
+    return undef;
+}
+
+sub exists($) {
+    my Xerl::Tools::FileIO $self = $_[0];
+    my $path = SECUREPATH( $self->get_path() );
+
+    return -e $path;
+}
+
+sub fwrite($) {
+    my Xerl::Tools::FileIO $self = $_[0];
+    $self->_fwrite(0);
+
+    return undef;
+}
+
+sub fwriteappend($) {
+    my Xerl::Tools::FileIO $self = $_[0];
+
+    $self->_fwrite(1);
+
+    return undef;
+}
+
+sub _fwrite($;$) {
+    my Xerl::Tools::FileIO $self = $_[0];
+    my $append = $_[1];
+
+    my ( $path, $filename ) =
+      ( SECUREPATH( $self->get_path() ), SECUREPATH( $self->get_filename() ) );
+
+    my $path_ = '';
+    for ( split /\//, $path ) {
+        $path_ .= $_ . '/';
+        mkdir $path_
+          or Xerl::Main::Global::ERROR( $!, $path_, caller() )
+          unless -d $path_;
+    }
+
+    my $f;
+    if ( $append == 0 ) {
+        open $f, ">$path$filename"
+          or Xerl::Main::Global::ERROR( $!, $path . $filename, caller() );
+
+    }
+    else {
+        open $f, ">>$path$filename"
+          or Xerl::Main::Global::ERROR( $!, $path . $filename, caller() );
+    }
+
+    flock $f, 2;
+    print $f @{ $self->get_array() };
+    flock $f, 3;
+    close $f;
+
+    return undef;
+}
+
+sub print($) {
+    my Xerl::Tools::FileIO $self = $_[0];
+
+    print @{ $self->get_array() };
+
+    return undef;
+}
+
+sub reverse_array($) {
+    my Xerl::Tools::FileIO $self = $_[0];
+
+    my @array = reverse @{ $self->get_array() };
+    $self->set_array( \@array );
+
+    return undef;
+}
+
+sub merge($$) {
+    my Xerl::Tools::FileIO( $self, $other ) = @_;
+
+    my @merged = ( @{ $self->get_array() }, @{ $other->get_array() } );
+    my Xerl::Tools::FileIO $fio = Xerl::Tools::FileIO->new();
+
+    $fio->set_array( \@merged );
+    return $fio;
+}
+
+sub shift($) {
+    my Xerl::Tools::FileIO $self = $_[0];
+    chomp( my $shift = shift @{ $self->get_array() } );
+
+    return $shift;
+}
+
+sub pop($) {
+    my Xerl::Tools::FileIO $self = $_[0];
+    chomp( my $pop = pop @{ $self->get_array() } );
+
+    return $pop;
+}
+
+use overload '+' => \&merge;
+
+sub SECUREPATH($) {
+    my $path = $_[0];
+
+    $path =~ s/\.\.+\/?//g;
+
+    return $path;
+}
+
+1;