ONO::IO
package ONO::IO;
################################################################################
# COPYRIGHT / LICENSE #
################################################################################
#
# This file is part of the ONO Software Project.
#
# Copyright (C) 2000-2025 Jos KIRPS [ www.kirps.com | jos_AT_kirps_DOT_com ]
# and The Joopita Project [ www.joopita.org | contact_AT_joopita_DOT_com ]
#
# This file, as well as other parts of the ONO Software Project or related
# elements, are FREE SOFTWARE available under the ARTISTIC LICENSE 2.0.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# For the full license, see /ono/osr/license/LICENSE.txt, or write to
# jos_AT_kirps_DOT_com or contact_AT_joopita_DOT_com.
#
################################################################################
# END OF COPYRIGHT / LICENSE, HERE COMES THE CODE ... #
################################################################################
use CGI;
use strict;
use ONO::Lib::Basic;
use ONO::Core::Kernel;
use ONO::Core::HostOS;
use ONO::Lib::DateTime::ToolBox;
use ONO::Lib::Web::Client;
###############################################################################
# ONO
###############################################################################
#: ONO::IO is responsible for all file and directory accesses, as long as they
#: are located within the ONO document root directory. All I/O should either
#: be handled by ONO::IO, or by ONO::Core::HostIO, you should not use low level
#: Perl I/O stuff in your ONO projects.
#:
#: Important I/O calls include:
#:
#; load(), list(), store(), append(), dump(), ls() / dir(), mkdir(), mkpath(), exists(), mv(), cp(), cpr(), rm(), rmdir()
#:
#: ONO::IO also allows to manage cache and configuration files for example:
#; cacheread(), cachewrite(), confread(), confwrite()
#:
#: Most ONO::IO calls respect the presence of thumbnail and preview files,
#: those can also be detected if necessary:
#; getthumbs(), getthumbs_ifexists()
#:
#: Furthermore, the module offers access to system information and allows for
#: system interaction:
#; os(), cpu(), mem(), disks(), domain(), sys(), exec(), http(), https(), http_domain_base(), sysload()
#:
#: ONO::IO also helps with software development, by detecting development
#: stations and offering appropriate tools, for example:
#; devstation(), devprint(), debug()
#:
#: For file and directory I/O outside of the ONO document root, see
#: ONO::Core::HostIO.
my @SYSLOADMSG = (
"This content cannot be displayed right now. Please try again in a few minutes – Thank you!",
"Dieser Inhalt kann momentan nicht angezeigt werden. Bitte versuche es in ein paar Minuten nochmals - Vielen Dank!",
"Ce contenu ne peut pas être affiché actuellement. Veuillez réessayer dans quelques minutes - Merci beaucoup!",
"Dëse Contenu ka momentan net ugewise ginn. Probéier w.e.g. an e puer Minutte nach eng Kéier - Villmols Merci!",
);
my $PIXEL = "Content-Type: image/gif\n\n";
open (FILE, &path."/ono/osr/images/spacer/trans.gif");
flock FILE, 1;
$PIXEL .= <FILE>;
close (FILE);
my ($devstation_file,$devstation_option);
if (&exists("","cgi-bin/devstation.txt")) {
$devstation_file = 1;
}
# make sure that devstation will run cron bots too:
if (-e "/mnt/ono/cgi-bin/devstation.txt" && !$ENV{'SERVER_NAME'}) {
$devstation_option = 1;
}
my $is_local;
if ($ENV{'SERVER_NAME'} eq "127.0.0.1" || $ENV{'SERVER_NAME'} =~ /^192\.168\./ || $ENV{'SERVER_NAME'} =~ /^172\.16\./ || $ENV{'SERVER_NAME'} =~ /\.local$/) {
$is_local = 1;
}
###############################################################################
# SUBS
###############################################################################
sub path {
#: Returns the UNIX path to the ONO document root directory. This is the
#: same as ONO::Core::Kernel->vpath, so you may simply get this info via
#: ONO::IO.
return ONO::Core::Kernel->vpath;
}
sub binary_dirs {
#: List UNIX directories that may contain useful UNIX binaries that can be
#: used by certain ONO::Lib modules for example.
return ("/usr/bin","/usr/local/bin","/opt/local/bin");
}
sub base {
#: Return the software base (if cgi-bin is not on the document root level,
#: as in www.example.com/path/lang/cgi-bin/... for example). Note that the
#: base always needs to be composed of 2 subdirectories.
my $base;
if (!$ENV{'SCRIPT_NAME'}) {
if (&exists("","etc/software_base.conf")) {
$base = &load("","etc/software_base.conf");
$base =~ s~(\n|\r|\t)~~g;
}
} else {
if ($ENV{'SCRIPT_NAME'} =~ m~/(.*?)/(.*?)/cgi-bin/~) {
$base = "/$1/$2";
}
}
return $base;
}
sub project {
#: Return the name of an ONO project, as in
#: www.example.com/cgi-bin/local/perl/project_name/... for example.
my $community;
if ($ENV{'SCRIPT_NAME'} =~ m~/cgi-bin/local/perl/(.*?)/~) {
$community = $1;
}
return $community;
}
sub community {
#: Same as project().
return &project();
}
sub path2dir {
#: Demove everything behind the last slash (including the last slash itself).
#: This will remove any file info from the directory and return the pure
#: directory path.
#:
#: Also see getdir(), getdirfile(), and getdirfileext(), which will be more
#: useful in most cases.
my $path = $_[1];
$path =~ s~/[^/]*$~~;
return $path;
}
sub cachefile {
#: Turn a file (directory/path plus filename) into a cache ID filename.
#: This is usually not required, but it's used internally by other
#: cache related functions.
my ($self,$file) = @_;
$file = ONO::Lib::Basic->remove_doubles($file,"-");
for (my $i = 0; $i < 4; $i++) {
$file =~ s~-~/~;
}
return $file;
}
sub cacheexists {
#: Check if a cache entry exists (returns 1 if yes, or 0 if not).
my ($self,$file) = @_;
$file = &cachefile("",$file);
if (&exists("","var/tmp/cache/$file.txt")) {
return 1;
} else {
return 0;
}
}
sub cacheclean {
#: Removes a cache file.
#:
#: Note that empty dirs in /var/tmp/cache are not being removed, which
#: means that some sort of garbage collection will be required some day...
my ($self,$file) = @_;
$file = &cachefile("",$file);
&rm("","var/tmp/cache/$file.txt");
}
sub cachetimestamp {
#: Get the timestamp of a cache file, which may be useful to decide
#: if it's time to remove or replace it.
my ($self,$file) = @_;
$file = &cachefile("",$file);
return ×tamp("","var/tmp/cache/$file.txt");
}
sub cachereadsimple {
#: Simplified form of cacheread(), simple and fast, supplies no useful info,
#: just returns the content of the cache, doesn't automatically manage or
#: delete anything by itself.
my ($self,$file,$verbose) = @_;
$file = &cachefile("",$file);
if ($verbose) {
return "<!-- ONOIOCacheStart -->".&load("","var/tmp/cache/$file.txt")."<!-- ONOIOCacheEnd -->";
} else {
return &load("","var/tmp/cache/$file.txt");
}
}
sub cachelistsimple {
#: Simplified form of cachelist(), simple and fast, supplies no useful info,
#: just returns the content of the cache, doesn't automatically manage or
#: delete anything by itself.
my ($self,$file) = @_;
$file = &cachefile("",$file);
return &list("","var/tmp/cache/$file.txt");
}
sub cacheread {
#: Read a cache file, and do some cache management at the same time.
#:
#: If $time is provided, then we'll only read the cache if it's not older
#: than T minutes. if it's older, then the cache file will simply be removed.
#:
#: Switches:
#:
#: -d debugging mode
#: -L list mode, allows to read arrays
#: -S silent mode
#: -v verbose (can be useful when debuggin HTML)
#: -V verbose only if not empty
#:
#: If no options and no cache management is required, then cachereadsimple()
#: will be a better and faster option here.
my ($self,$file,$time,$switches) = @_;
$file = &cachefile("",$file);
my $TIME;
if ($time) {
$TIME = ×tamp("","var/tmp/cache/$file.txt");
my $AGE = (int((time() - $TIME)/6)/10);
if ($AGE < $time) {
$time = 0;
if ($switches !~ /S/) {
$TIME = "\n<!-- ONOCacheAge:${AGE}m -->";
}
}
}
if (!$time) {
if ($switches =~ /L/) {
# return an array
my (@array,$count);
foreach my $line (&list("","var/tmp/cache/$file.txt")) {
$count++;
$line =~ s~\n$~~;
@array = (@array,$line);
}
if ($count) {
return @array;
} else {
return ();
}
} else {
# return a string
my $CACHE = &load("","var/tmp/cache/$file.txt");
if ($switches =~ /v/) {
if ($switches !~ /V/ || $CACHE) {
return "\n<!-- ONOCacheStart:$file -->$TIME\n$CACHE\n<!-- ONOCacheEnd:$file -->\n";
} else {
return $CACHE;
}
} else {
return $CACHE;
}
}
} else {
&rm("","var/tmp/cache/$file.txt");
if ($switches =~ /L/) {
return ();
} else {
return "";
}
}
}
sub cachewritesimple {
#: Simplified form of cachewrite(), simple and fast, doesn't do anything special.
#: Just writes the data, doesn't automatically manage or
#: delete anything by itself.
my ($self,$file,$data) = @_;
$file = &cachefile("",$file);
my ($path) = &getdirfile("","var/tmp/cache/$file.txt");
&mkpath("",$path);
&store_rm("","var/tmp/cache/$file.txt",$data);
}
sub cachewrite {
#: Write a cache file, and do some cache management at the same time.
#:
#: Switches:
#:
#: -D delete if empty
#: -E don't write if empty
#: -L list mode, allows to store arrays, requires $data to be a hash reference
#: -v verbose
#: -V Verbose only if not empty
#:
#: If no options and no cache management is required, then cachewritesimple()
#: will be a better and faster option here.
my ($self,$file,$data,$switches) = @_;
$file = &cachefile("",$file);
if ($switches !~ /L/ && $switches =~ /v/ && ($switches !~ /V/ || $data)) {
my $time = ONO::Lib::DateTime::ToolBox->convert("classic",time());
$data = "<!-- ONOCacheTimestamp:$time -->\n$data";
}
if ($switches =~ /L/) {
my @lines = @$data;
$data = "";
foreach my $line (@lines) {
$data .= "$line\n";
}
}
if ($switches !~ /E/ || $data) {
my ($path) = &getdirfile("","var/tmp/cache/$file.txt");
&mkpath("",$path,777);
&store("","var/tmp/cache/$file.txt",$data);
}
if ($switches =~ /D/ && !$data) {
&rm("","var/tmp/cache/$file.txt");
}
}
sub cleanup {
#: The cleanup() function will remove all special characters form a
#: filename, directory name, or a path. The override option may be
#: used for any data stored within the /servers tree.
my ($self,$file,$override) = @_;
$file =~ s~^/~~;
if ($override && $file =~ m~^servers/~) {
# server mode allows override
} else {
# cleanup will not be executed on files located on a fileserver
if ($file !~ m~^servers/~) {
$file =~ s~[^A-Za-z0-9\_\-\.\/\@\(\)]~~g;
}
}
return $file;
}
sub colread {
#: This allows to quickly read files in name:value list format,
#: data will be returned in hash format.
my %conf;
foreach my $line (&list("",$_[1])) {
$line =~ s~(\n|\r|\t)~~g;
if ($line =~ /^(.*?):(.*?)$/) {
$conf{$1} = $2;
}
}
return %conf;
}
sub confread {
my ($self,$file,$switches) = @_;
#: Read an ONO configuration file.
#:
#: Switches:
#:
#: -L make value lower case
my %conf;
foreach my $line (&list("",$file)) {
if (substr($line,0,1) ne "#" && $line =~ /[A-Za-z0-9]/) {
my @lp = split(/ /,$line);
$line =~ s~^$lp[0] ~~;
if ($switches !~ /L/) {
$lp[0] = lc $lp[0];
}
if ($line =~ /("|')/) {
my $separator = $1;
$line =~ /$separator(.*)$separator/;
$lp[1] = $1;
}
$lp[1] =~ s/\n//;
if ($lp[0]) {
$conf{"$lp[0]"} = $lp[1];
}
}
}
return %conf;
}
sub confwrite {
#: Write an ONO configuration file.
#: This is basically the same as the store() function, which means that
#: YOU will need to take care of formatting the data before sending it.
&store("",$_[1],$_[2]);
}
sub confupdate {
#: Update an ONO configuration file, which replaces the $value of the
#: $name entry. The remaining data will not be touched.
my ($self,$file,$name,$value) = @_;
my ($DATA,$exists);
foreach my $line (&list("",$file)) {
$line =~ s~(\n|\r|\t)~~g;
if ($exists == 0 && ($line =~ /^$name / || $line =~ /^$name$/ || $line =~ /^(#|# )$name / || $line =~ /^(#|# )$name$/)) {
# disable the line
if (($line =~ /^$name / || $line =~ /^$name$/) && $value eq "#") {
$line = "#$line";
$exists = 1;
}
# save an empty value, but leave activated
if (!$value) {
$line = qq~$name~;
$exists = 1;
}
# update the line
if ($value && $value ne "#") {
if ($value =~ / /) {
$value = qq~"$value"~;
}
$line = qq~$name $value~;
$exists = 1;
}
}
$DATA .= "$line\n";
}
if (!$exists) {
$DATA .= "\n$name $value\n";
}
&store("",$file,$DATA);
}
sub curl {
#: Retrieve a file from the web, return the data as a stream.
#: Be careful not to pass the input unchecked, and don't allow
#: user input to be passed to this function!
my ($self,$url) = @_;
if ($url && $url !~ /^http/) {
$url = "http://$url";
}
$url !~ s~(\`|\||\')~~g;
return `curl -k '$url'`;
}
sub curlstore {
#: Same as curl(), but dump / store the data into a file.
my ($self,$url,$file) = @_;
my $CURL = &curl("",$url);
if ($CURL) {
$file =~ s~[^A-Za-z0-9\_\-\.\/\@\(\)]~~g;
&dump("",$file,$CURL);
}
}
sub debug {
#: Append to /__debug.txt. This should not be used on production systems,
#: but only on development stations. It may be used temporarely on
#: production systems to analyze problems that need a quick fix, but
#: make sure to remove /debug.txt later on then.
my ($self,$data) = @_;
my $vpath = &path;
open (FILE,">>$vpath/__debug.txt");
print FILE $data;
close FILE;
}
sub device {
#: Return the type of device in use.
#:
#: 3 ways to use this:
#:
#: device() will return either computer, tablet or phone
#:
#: device(type) will return either 0 or 1
#:
#: device("useragent") will return the user agent
#:
#: iPad Warning:
#:
#: Note that current iPads identify themselves as Intel Macs.
#: A dirty trick is needed to identify them correcty:
#: 1. First test if it's a Mac, using ONO;;IO->device("mac")
#: 2. The use if (navigator.maxTouchPoints > 1) {...} to execute JS
my $input = $_[1];
my $device = "computer";
if ($ENV{'HTTP_USER_AGENT'} =~ /(mobile|tablet|ipad|android)/i) {
$device = "tablet";
}
if ($ENV{'HTTP_USER_AGENT'} =~ /phone/i) {
$device = "phone";
}
if ($input) {
$device = 0;
if ($input eq "computer" && $ENV{'HTTP_USER_AGENT'} !~ /(mobile|tablet|ipad|android|phone)/i) {
$device = 1;
}
if ($input eq "mac" && $ENV{'HTTP_USER_AGENT'} =~ /macintosh/i) {
$device = 1;
}
if ($input eq "tablet" && $ENV{'HTTP_USER_AGENT'} =~ /(mobile|tablet|ipad|android)/i) {
$device = 1;
}
if ($input eq "phone" && $ENV{'HTTP_USER_AGENT'} =~ /phone/i && $ENV{'HTTP_USER_AGENT'} !~ /ipad/i) {
$device = 1;
}
if ($input eq "mobile" && $ENV{'HTTP_USER_AGENT'} =~ /(mobile|tablet|ipad|android|iphone)/i) {
$device = 1;
}
if ($input eq "useragent") {
$device = $ENV{'HTTP_USER_AGENT'};
}
}
return $device;
}
sub devstation {
#: This will return 1 if we're on a devstation, or 0 if we're on a production system.
#: This will only work if...
#:
#: ... we're in a local network and a file named /cgi-bin/devstation.txt is available,
#: or ...
#:
#: ... the file /mnt/ono/cgi-bin/devstation.txt is present on the UNIX root level.
#:
#: Note that the devstation.txt file should contain the devstation client's IP
#: address as content.
if (($devstation_file && &local()) || $devstation_option) {
return &load("","cgi-bin/devstation.txt");
} else {
return 0;
}
}
sub devstation_variation {
#: This will return the variation code (if present) which will allow to test
#: different domain-based variations of a site/platform on your devstation.
#:
#: This is used by the variation call in ONO_Lib_Web_Doamin for example, which
#: should be the default method to check for variations of a platform.
#:
#: The variation code should be in /cgi-bin/devstation_variation.txt, and this
#: will only work on a devstation, not on a production system.
if (($devstation_file && &local()) || $devstation_option) {
return &load("","cgi-bin/devstation_variation.txt");
} else {
return "";
}
}
sub devstation_refresh {
#: Only refresh if devstation - probably deprecated ?
# if (&devstation) {
# my $DEVSTATION_IP = &devstation();
# if ($ENV{'SERVER_NAME'} eq "127.0.0.1" && $DEVSTATION_IP ne "127.0.0.1") {
# my $REQUEST_URI = $ENV{'REQUEST_URI'};
# return qq~<meta http-equiv="refresh" content="0; url=http://$DEVSTATION_IP$REQUEST_URI">\n~;
# } else {
# return "";
# }
# } else {
# return "";
# }
return "";
}
sub devprint {
#: Return content only if we're in devstation mode. This allows to print
#: debugging info on a web page on a development station, this info will
#: not be displayed on production systems for example.
#: Args(int): disable, replace return/linefeed by HTML br, bold
if (&devstation && !$_[2]) {
if ($ENV{'HTTP_USER_AGENT'}) {
my $DEV = $_[1];
if ($_[3]) {
$DEV =~ s~(\n|\r)~<br>~g;
}
if ($_[4]) {
return qq~<div class="bold">$DEV</div>~;
} else {
return qq~<div>$DEV</div>~;
}
} else {
return $_[1];
}
} else {
return "";
}
}
sub devstore {
#: Like store, but will only execute on a devstation, which may be useful
#: when debugging code.
if (&devstation) {
&store("",$_[1],$_[2]);
}
}
sub devdump {
#: Write to /__devdump.txt if we're on a devstation, so this can be used for
#: debugging purposes. The file will be overwritten each time, so this should
#: be used at the end of the script. Date and time will be automatically added
#: to the top of the content.
if (&devstation) {
my (
$sec,$min,$hour,
$mday,$mon,$year,
$wday,$yday,$isdst
) = ONO::Lib::DateTime::ToolBox->get;
if ($_[2]) {
&append("","__devdump.txt","$mday/$mon/$year \@ $hour:$min:$sec:\n\n$_[1]");
} else {
&store("","__devdump.txt","$mday/$mon/$year \@ $hour:$min:$sec:\n\n$_[1]");
}
return $_[1];
}
}
sub devguessuri {
#: If we're on a devstation, then guess the absolute URI, based on the name
#: of the input script. This can be use useful to debug links.
my $URI = $ENV{'REQUEST_URI'};
if (&devstation) {
$URI =~ s~^(.*)/local/perl/(.*?)/~~;
$URI =~ s~^index_~~;
$URI =~ s~\.pl(.*)$~~;
$URI = "/$URI/";
}
return $URI;
}
sub local {
#: Are we in a local network? Returns 1 = yes, 0 = no. This will only work
#: if the SERVER_NAME is an IP address, not a domain, unless the domain
#: will be of type example.local.
if ($is_local) {
return 1;
} else {
return 0;
}
}
sub dump {
#: Dump data to a file, without any processing.
#: Use this only if store() stoesn't work for some reason.
#: This may be used to store uploaded files containing special data for
#: example.
my ($self,$file,$data) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,">$vpath/$file");
print FILE $data;
close FILE;
}
sub dump_append {
#: Dump data to a file, without any processing.
#: Use this only if append() stoesn't work for some reason.
my ($self,$file,$data) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,">>$vpath/$file");
print FILE $data;
close FILE;
}
sub dump_load {
#: Load an entire file, return as string, don't process anything.
#: Use this only if load() stoesn't work for some reason.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE, "$vpath/$file");
my @DATAS = <FILE>;
close FILE;
my $DATA;
foreach my $data (@DATAS) {
$DATA .= $data;
}
return $DATA;
}
sub exists {
#: Check if file or path exists. Returns 1 if exists, or nothing if the
#: object doesn't exist.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
my $exists;
if (-e "$vpath/$file") {
$exists = 1;
}
return $exists;
}
sub exists_wait {
#: Wait until a file has been created, which is useful if complex file
#: generation tools are being used. Waiting for up to 3 secs is default,
#: higher values can be set manually.
my ($self,$file,$secs) = @_;
if (!$secs) {
$secs = 3;
}
my $whilecounter;
while ($whilecounter < $secs && !(&exists("",$file))) {
$whilecounter++;
sleep 1;
}
}
sub open {
#: This will simply open a file handle, as required by
#: ONO_Lib_Image_Check for example. Also see close().
my $file = &cleanup("",$_[1]);
my $vpath = &path;
open my $FH,"$vpath/$file";
return $FH;
}
sub close {
#: This will simply close a file handle. Also see open().
close $_[1];
}
sub load {
#: Load a file, return its content.
#:
#: Switches:
#:
#: -n remove new lines
#: -h HTML: replace \n by <br>
my (
$self,
$file,
$switches,
) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
my $dump;
foreach my $dat (@data) {
$dat =~ s~\r~~g;
if ($switches =~ /n/) {
$dat =~ s~\n~~g;
}
if ($switches =~ /h/) {
$dat =~ s~\n~<br>~g;
}
$dump .= $dat;
}
return $dump;
}
sub list {
#: List a file. Similar to load(), but returns lines as an array.
#:
#: Switches:
#:
#: -E don't return lines that don't contain numbers or letters
my (
$self,$file,$switches,
) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
my @new_data;
foreach my $dat (@data) {
if ($switches !~ /E/ || $dat =~ /[A-Za-z0-9]/) {
$dat =~ s~\r~~g;
@new_data = (@new_data,$dat);
}
}
return @new_data;
}
sub list_raw {
#: List_raw() is identical to list(), but allows to load files without
#: checking the file name, which means that it also loads files with
#: special characters.
my ($self,$file) = @_;
my $vpath = &path;
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
my @new_data;
foreach my $dat (@data) {
$dat =~ s~\r~~g;
@new_data = (@new_data,$dat);
}
return @new_data;
}
sub list_raw_fast {
#: List_raw_fast() is identical to list_raw(), but it's faster as it
#: doesn't clean up or check anything
my ($self,$file) = @_;
my $vpath = &path;
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
return @data;
}
sub list_line {
#: Like list(), but returns only one specific line from the file, which
#: must be indicated as a number.
my ($self,$file,$line) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
my ($return,$counter);
foreach my $dat (@data) {
$counter++;
if ($counter == $line) {
$dat =~ s~\r~~g;
$return = $dat;
}
}
return $return;
}
sub chomplist {
#: Similar to list(), but removes all carriage returns, lewlines and
#: tabs.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
my @new_data;
foreach my $dat (@data) {
$dat =~ s~(\r|\n|\t)~~g;
@new_data = (@new_data,$dat);
}
return @new_data;
}
sub quicklist {
#: Return file as content as an array, without doing anything else.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
return @data;
}
sub save {
# Same as store(), and you should use store() instead.
my ($self,$file,@data) = @_;
&store($self,$file,@data);
}
sub create {
#: An intelligent version of "store" that will not overwrite
#: existing files, but add a number to the filename, if the
#: file already exists.
my ($self,$dir,$file,$ext,@data) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
$file = &cleanup("",$file);
$ext = &cleanup("",$ext);
if (!$file) {
$file = "untitled";
}
if (!$ext) {
$ext = "txt";
}
my $filename = $file;
my $whilecounter;
while ($whilecounter < 8192 && &exists("","$dir/$filename.$ext")) {
$whilecounter++;
$filename = "$file\_$whilecounter";
}
open (FILE,">$vpath/$dir/$filename.$ext");
foreach my $dat (@data) {
print FILE $dat;
}
close FILE;
return $filename;
}
sub store {
#: Store a file. If the file exists, it will be overwritten.
#: Data can be a string, or an array.
my ($self,$file,@data) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,">$vpath/$file");
foreach my $dat (@data) {
print FILE $dat;
}
close FILE;
}
sub store_rm {
#: Store a file if data is provided (just like store()), remove
#: the file if data is empty. Unlinke store(), data cannot be
#: an array, online strings are supported.
my ($self,$file,$data) = @_;
if ($data) {
&store("",$file,$data);
} else {
&rm("",$file);
}
}
sub append {
#: Append data to a file, data can be a string or an array.
my ($self,$file,@data) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,">>$vpath/$file");
foreach my $dat (@data) {
print FILE $dat;
}
close FILE;
}
sub copy {
#: Create a copy of of filename.ext, at the same location. The new
#: file will be named filename_copy.ext. If filename_copy.ext exists,
#: the name will become filename_copy_X.ext, where X is a number
#: starting at 1.
#:
#: If present, thumbnails will also be copied.
my ($self,$path) = @_;
my $vpath = &path;
$path = &cleanup("",$path);
my ($dir,$file,$ext) = &getdirfileext("",$path);
my $new = "${file}_copy.$ext";
my $whilecounter;
while (&exists("","$dir/$new") && $whilecounter < 1000) {
$whilecounter++;
$new = "${file}_copy_$whilecounter.$ext";
}
`cp "$vpath/$path" "$vpath/$dir/$new"`;
my ($pr1,$tn1) = &getthumbs("",$path);
if ($pr1 && $tn1 && (-e "$vpath/$pr1" || -e "$vpath/$tn1")) {
my ($pr2,$tn2) = &getthumbs("","$dir/$new");
`cp "$vpath/$pr1" "$vpath/$dir/$pr2"`;
`cp "$vpath/$tn1" "$vpath/$dir/$tn2"`;
}
return $new;
}
sub rm {
#: Remove (aka delete) a file, including its (optional)
#: thumbnails and setup files.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
if ($file =~ /[A-Za-z0-9]/) {
if (-e "$vpath/$file") {
`rm "$vpath/$file"`;
}
my ($pr1,$tn1) = &getthumbs("",$file);
if ($pr1 && $tn1 && (-e "$vpath/$pr1" || -e "$vpath/$tn1")) {
`rm "$vpath/$pr1"`;
`rm "$vpath/$tn1"`;
}
my $setup = &getsetup("",$file);
if ($setup && -e "$vpath/$setup") {
`rm "$vpath/$setup"`;
}
}
}
sub rmimage {
#: Like rm(), but a special version that will additionally remove the
#: file with multiple possible image extensions.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
foreach my $ext (&imageexts) {
&rm("","$file.$ext");
}
}
sub renumber {
#: Renumber files and/or directories in a directory, shtml/setup
#: files as well as pt/tn files will be ignored. Note that all thumbs
#: and previews will be removed during this process.
#:
#: -d renumber directories
#: -f renumber files
#: -u keep string after underscore
#: -U collect numbering if underscore (001_x and 001_y will be kept as is)
my (
$self,
$dir,
$start,
$step,
$switches,
) = @_;
# first we rename the files that shall be renumbered
foreach my $obj (sort &ls("",$dir)) {
if ($obj !~ /^\./ && $obj !~ /\.(setup|shtml)$/) {
if ($switches =~ /f/ && $obj =~ /\./) {
&mv("","$dir/$obj","$dir/onoio_renumber_$obj");
my ($pr,$tn) = &getthumbs("",$obj);
&rm("","$dir/$pr");
&rm("","$dir/$tn");
}
if ($switches =~ /d/ && $obj !~ /\./) {
&mv("","$dir/$obj","$dir/onoio_renumber_$obj");
}
}
}
# list files, and number them back...
my $number = $start;
my ($counter,$string_mode,$last_pre);
foreach my $obj (sort &ls("",$dir)) {
if ($obj =~ /^onoio_renumber_/ && $obj !~ /\.(setup|shtml)$/) {
my ($pre,$string);
if ($switches =~ /f/ && $switches =~ /u/ && $obj =~ /^onoio_renumber_(.*?)_(.*)\./) {
$pre = $1;
$string = "_$2";
}
if ($switches =~ /d/ && $switches =~ /u/ && $obj =~ /^onoio_renumber_(.*?)_(.*)$/) {
$pre = $1;
$string = "_$2";
}
my $override;
if ($switches =~ /U/ && $string && $pre eq $last_pre) {
$override = 1;
if (!$string_mode) {
$override = 0;
}
}
if ($counter && !$override) {
$number = $number + $step;
if (length $start > length $number) {
$number = ONO::Lib::Basic->add_leading_zeroes($number,length $start);
}
}
if ($string) {
$string_mode = 1;
} else {
$string_mode = 0;
}
$counter++;
$last_pre = $pre;
if ($obj =~ /\./) {
# file
my ($file,$ext) = &getfileext("",$obj);
&mv("","$dir/$obj","$dir/$number$string.$ext");
} else {
# dir
&mv("","$dir/$obj","$dir/$number$string");
}
}
}
}
sub dirfile {
#: Is this a directory (returns 'dir') or a file (returns 'file') ?
my $type = "dir";
if ($_[1] =~ /\./) {
$type = "file";
}
if ($_[2] eq "mediaserver") {
my $vpath = &path;
if (-d "$vpath/$_[1]") {
$type = "dir";
} else {
$type = "file";
}
if (&dirisfile("",$_[1])) {
$type = "file";
}
}
return $type;
}
sub dirisfile {
#: Extensions that will always be treated as files, even if they're dirs.
if ($_[1] =~ /\.(app|jar|pkg|mpkg|logicx|fcpbundle)$/) {
return 1;
} else {
return 0;
}
}
sub fileisdir {
#: Extensions used by files that are actually not files, but dirs
if ($_[1] =~ /\.(app|logicx|fcpbundle)$/) {
return 1;
} else {
return 0;
}
}
sub ls {
#: Same as dir().
my ($self,$dir,$filter,$ext,$sort,$opts,$excluded,$prefix) = @_;
&dir("",$dir,$filter,$ext,$sort,$opts,$excluded,$prefix);
}
sub lst {
#: List directory items by timestamp. This will simply dump the UNIX
#: ls output.
my ($self,$dir) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
my @objects = `ls -lt $vpath/$dir`;
return @objects;
}
sub dir {
#: List dirs and files.
#:
#: Switches:
#:
#: -B omit Base directory from list
#: -C cleanup (remove slashes at beginning)
#: -D only directories
#: -H no hidden files (starting by a dot)
#: -L list (option list for HTML forms)
#: -O option list -> shorten names if very long
#: -R recursive (does NOT work with sort mode! -- the -H switch is automatically enabled -- use -X to improve speed and to reduce CPU load)
#: -s sort (works with both list and string)
#: -S return list as a string (useful when using the -L option for example)
#: -W RAW mode allows special characters
#: -X use UNIX ls command to get recursive directories (only affects the -R switch)
#:
#: Note that the RX modes will ONLY list directories, NOT files!
my (
$self,$dir,$filter,$ext,$sort,$opts,$excluded,$prefix
) = @_;
my $vpath = &path;
if ($opts =~ /W/) {
$dir = &cleanup("",$dir);
$filter = &cleanup("",$filter);
}
my @objects;
if ($sort eq "size" || $sort eq "time") {
if ($sort eq "size") {
foreach my $item (`ls -S $vpath/$dir | tr '\n' '\n'`) {
$item =~ s~(\n|\r|\t)~~g;
@objects = (@objects,$item);
}
}
if ($sort eq "time") {
# this ONLY works for files, not for dirs (will be omitted)
# used by apps exercise temporary storage, make sure not to
# break this when making modifications !!!
foreach my $item (`ls -lt $vpath/$dir`) {
if ($item !~ /^\./ && $item =~ /\./) {
$item =~ s~(\n|\r|\t)~~g;
$item =~ s~^(.*) ~~;
@objects = (@objects,$item);
}
}
}
} else {
opendir(DIR, "$vpath/$dir");
if (!$sort) {
if ($opts =~ /R/) {
if ($opts =~ /X/) {
@objects = &_dir_recursive_ux("",$dir,$dir);
} else {
@objects = &_dir_recursive("",$dir,$dir);
}
} else {
@objects = readdir(DIR);
}
}
if ($sort eq "date") {
@objects = sort {-M $a <=> -M $b} map {"$vpath/$dir/$_"} readdir(DIR);
}
closedir DIR;
}
if (!$sort) {
@objects = sort @objects;
}
if ($sort eq "date") {
my $counter;
foreach my $object (@objects) {
$objects[$counter] =~ s~$vpath/$dir/~~;
$counter++;
}
}
my ($string,$excluded_recursive);
if ($excluded =~ s/\*$//) {
$excluded_recursive++;
}
if ($filter || $ext || $opts || $excluded) {
my @new;
foreach my $object (@objects) {
my $fext = $object;
$fext =~ s~^(.*)\.~~;
my $exclude;
if ($opts =~ /B/ && $object eq $dir) {
$exclude++;
}
if ($opts =~ /C/) {
$object =~ s~^/~~;
}
if (($opts =~ /H/ && $object =~ /^\./) || ($opts =~ /D/ && $object =~ /\./) || $object eq $excluded || "$object/" eq $excluded) {
$exclude++;
}
if ($excluded_recursive && "$object/" =~ /^$excluded/) {
$exclude++;
}
if ((!$filter || $object =~ /$filter/) && (!$ext || $object =~ /\.$ext$/ || ":$ext:" =~ /:$fext:/) && !$exclude) {
if ($opts =~ /L/) {
my $object2 = $object;
if ($opts =~ /O/ && length $object2 > 44) {
$object2 = substr($object,0,16)." (...) ".substr($object,(length $object)-24,24);
}
$object = qq~<option value="$prefix$object">$prefix$object2</option>~;
}
@new = (@new,$object);
$string .= $object;
}
}
@objects = @new;
}
if ($opts =~ /s/) {
@objects = sort @objects;
if ($opts =~ /S/) {
$string = "";
foreach my $object (@objects) {
$string .= $object;
}
}
}
if ($opts =~ /S/) {
return $string;
} else {
return @objects;
}
}
sub _dir_recursive {
#: Do NOT use this routine if possible, we recommend using the simple 'dir' with option -R instead
#: note that this routine ignores hidden files and folders, and it does not support directories with
#: dots in their names (which would be ONO-incompatible anyway).
my (
$self,$basedir,$dir
) = @_;
my $vpath = &path;
$basedir = &cleanup("",$basedir);
$dir = &cleanup("",$dir);
opendir(DIR, "$vpath/$dir");
my @objects = readdir(DIR);
closedir DIR;
my @new;
foreach my $object (@objects) {
# add the basic object
@new = (@new,$object);
# go into the object if it's a directory
if ($object !~ /\./ && -d "$vpath/$dir/$object") {
my $display_dir = $dir;
$display_dir =~ s~$basedir~~;
foreach my $sub (&_dir_recursive("",$basedir,"$dir/$object")) {
my $use_dir = "$display_dir/$object/$sub";
$use_dir =~ s~//~/~g;
@new = (@new,$use_dir);
}
}
}
return @new;
}
sub _dir_recursive_ux {
#: Do NOT use this routine if possible, we recommend using the simple 'dir' with option -RX instead
my (
$self,$basedir,$dir
) = @_;
my $vpath = &path;
$basedir = &cleanup("",$basedir);
$dir = &cleanup("",$dir);
my @new;
foreach my $sub (`ls -R $vpath/$dir`) {
if ($sub =~ m~/(.*?):~) {
$sub = "/$1";
$sub =~ s~$vpath/~~;
$sub =~ s~$basedir/~~;
@new = (@new,"$sub");
}
}
return @new;
}
sub dirprotect {
#: Protect a directory by putting an index.shtml into it.
#: This will still allow access to files within the directory, but listing it will be prohibited.
#: Also see htaccess() for additional protection.
if (!&exists("","$_[1]/index.shtml")) {
&store("","$_[1]/index.shtml",qq~<html><head><meta name="robots" content="noindex,nofollow"></head><body><h1>403 - Forbidden</h1></body></html>~);
&chmod("","$_[1]/index.shtml","777");
}
}
sub hashread {
#: Return file data as a hash.
#: This works for lists separated by semicolon.
my %hash;
foreach my $line (&list("",&cleanup("",$_[1]))) {
$line =~ s~(\n|\r|\t)~~g;
$line =~ m~^(.*?);(.*)$~;
my $key = $1;
my $value = $2;
$key =~ s/^\s+//;
$key =~ s/\s+$//;
$value =~ s/^\s+//;
$value =~ s/\s+$//;
$hash{$key} = $value;
}
return %hash;
}
sub hashwrite {
#: Write a hash to a file, using semicolon separation.
#: Input needs to be a hash reference in this case.
my $hash_ref = $_[1];
my %hash = %$hash_ref;
my $HASH;
# this has never been tested!!!
foreach my $key (keys %hash) {
$HASH .= qq~$key;$hash{$key}\n~;
}
&store("",&cleanup("",$_[1]),$HASH);
}
sub objtype {
#: Return the type of a object:
#:
#: 'none' if object doesn't exist
#: 'dir' if object is a directory
#: 'file' if object is a file
#:
#: Also see dirfile(), which does more or less the same thing
#: (only the 'none' option is missing), only better.
my $vpath = &path;
my $obj = &cleanup("",$_[1]);
my $ret = "none";
if (-e "$vpath/$obj" && -d "$vpath/$obj") {
$ret = "dir";
}
if (-e "$vpath/$obj" && -f "$vpath/$obj") {
$ret = "file";
}
return $ret;
}
sub dirsize {
#: Return the size of a directory (including all files and
#: directories contained in it).
#:
#: Switches:
#:
#: -M machine mode in megabytes (disable human readable)
my ($self,$dir,$switches) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($switches =~ /M/) {
my $size = `du -sm $vpath/$dir`;
$size =~ s~ (.*)$~~g;
$size =~ s~(\n|\r|\t)(.*)$~~g;
return $size;
} else {
my $size = `du -sh $vpath/$dir`;
$size = ONO::Lib::Basic->remove_bad_spaces($size);
$size =~ s~( |\t)(.*)$~~;
$size =~ s~K~ kb~;
$size =~ s~M~ mb~;
$size =~ s~(\n|\r|\t)~~gi;
if ($size < 1) {
$size = "";
}
return $size;
}
}
sub disks {
#: List hard drives, display disk usage (percentage).
my @disks;
foreach my $data (`df -k`) {
$data =~ s/\s+/\^/g;
if ($data =~ m~^/~ && $data !~ /\@/) {
@disks = (@disks,"$data\n");
}
}
return sort @disks;
}
sub ip {
#: Return the IP address of the host.
my $ip;
if (&os eq "linux") {
foreach my $data (`ifconfig`) {
if (!$ip && $data =~ /inet addr:(.*?) / && $data !~ /^127\.0\.0\.1/ && $data !~ /^192\.168\./) {
$ip = $1;
}
}
}
if (&os eq "macos") {
foreach my $data (`ifconfig`) {
if (!$ip && $data =~ /inet (.*?) netmask/ && $data !~ /^127\.0\.0\.1/ && $data !~ /^192\.168\./) {
$ip = $1;
}
}
}
return $ip;
}
sub os {
#: Return the OS of the host ('linux' or 'macos'). This is similar
#: to ONO::Core::HostOS->host_os(), although the output is different.
#:
#: -v first letter is uppercase
#: -V get more detailed information
my $switches = $_[1];
my $os = "linux";
if ($switches =~ /v/) {
$os = ucfirst $os;
}
if ($switches =~ /V/) {
my $MORE = `grep 'PRETTY_NAME' /etc/os-release | cut -d= -f2 | tr -d '"'`;
if ($MORE =~ /[A-Za-z0-9]/) {
$os .= " - $MORE";
}
}
if (&uname =~ /Darwin/i) {
$os = "macos";
if ($switches =~ /v/) {
$os .= " ".`sw_vers -productVersion`;
}
}
return $os;
}
sub uname {
#: Return the host's uname string, which offers some host system information.
return `uname -a`;
}
sub cpu {
#: Return CPU info. This should display the type of processor, as well as the
#: number of available cores (multithreading is being considered).
#:
#: -b make bold
my $switches = $_[1];
my $cpu = "unknown cpu";
if (&os eq "linux") {
foreach my $dat (`/bin/cat /proc/cpuinfo`) {
if ($dat =~ /model name(.*)/) {
$cpu = $1;
}
}
}
if (&os eq "macos") {
$cpu = `sysctl -n machdep.cpu.brand_string`;
}
if ($switches =~ /b/) {
$cpu = qq~<span class="bold">$cpu</span>~;
}
my $cores = ONO::Core::HostOS->cpu_cores;
if ($cores) {
$cpu .= " ($cores cores/threads)";
}
$cpu =~ s~\((r|tm)\)~~gi;
$cpu =~ s~:~~g;
$cpu =~ s~^ ~~g;
return $cpu;
}
sub mem {
#: Return the total amount of RAM available, in GB / GigaBytes.
my $mem = "memory unknown";
if (&os eq "linux") {
foreach my $dat (`/bin/cat /proc/meminfo`) {
if ($dat =~ /MemTotal(.*)/) {
$mem = $1;
$mem =~ s~[^0-9]~~g;
# this needs to be 1000 and 1024, don't know why...
$mem = 1+int($mem/1024/1024)." GB";
}
}
}
if (&os eq "macos") {
$mem = `sysctl hw.memsize`;
$mem =~ s~[^0-9]~~g;
$mem = 1+int($mem/1024/1024/1024)." GB";
}
return $mem;
}
sub sys {
#: Direct access to the UNIX system, via ONO::Core::Kernel's sys() function.
my ($self,$mode,$opts) = @_;
return ONO::Core::Kernel->sys($mode,$opts);
}
sub sysload {
#: Returns the current system load (percent of total available),
#: CPU cores and multithreading are taken into consideration.
#:
#: This can be used to run or disable code depending on the
#: system load of the host, sysload(50) is true if current load
#: is LOWER than 50 for examaple.
#:
#: This uses cached system load info, which will be updated
#: about every 5 seconds.
#:
#: Note that the threshold feature is NOT working on development
#: stations, which makes developing under high load conditions
#: a lot easier (devstations always return 1).
# Lots of parantheses to make sure the compiler won't throw error messages...:
my $percent = int(100/((ONO::Core::HostOS->cpu_cores())*100)*(ONO::Core::HostOS->cpu_load_cached()));
if ($_[1]) {
# devstation will always return 1, which makes testing easier
if ($percent < $_[1] || &devstation) {
return 1;
} else {
return 0;
}
} else {
return $percent;
}
}
sub sysloadmsg {
#: Returns a system overload message. Note that this function only
#: dumps some text, it does not do or detect anything. It may be a
#: good idea to use this in combination with sysload().
my $MSG;
if ($_[1] eq "de") {
$MSG = $SYSLOADMSG[1];
}
if ($_[1] eq "fr") {
$MSG = $SYSLOADMSG[2];
}
if ($_[1] eq "lu") {
$MSG = $SYSLOADMSG[3];
}
if (!$MSG) {
$MSG = $SYSLOADMSG[0];
}
return qq~<div class="lh125">$MSG</div>~;
}
sub is_local_ip {
#: Is the provided IP a local IP ? Returns 1 of local, or 0 if not
#: local. Also see local().
#:
#: Not to be confused with local(), which tells you if the host's
#: IP is local.
my $res = 0;
if ($_[1] =~ /^(0|10|127)\.0/) {
$res++;
}
if ($_[1] =~ /^172\.16/) {
$res++;
}
if ($_[1] =~ /^192\.168\./) {
$res++;
}
if ($_[1] =~ /^255\.255\.255\.255$/) {
$res++;
}
return $res;
}
sub count {
#: Count objects (directories and files) inside a directory.
#: Note that this does NOT work recursively, only the first
#: level of the directory is being taken into consideration.
#:
#: Switches:
#:
#: -d only directories
#: -f only files
#: -i only images
#: -S omit .setup
#: -t only txt files
#: -T omit .thumbs and previews
my (
$self,
$dir,
$init,
$switches,
) = @_;
foreach my $file (&dir("",$dir)) {
if ($file =~ /[A-Za-z0-9]/ && $file !~ /^\./) {
$init++;
if (
($switches =~ /f/ && $file !~ /\./) ||
($switches =~ /i/ && $file !~ /\.(jpg|jpeg|gif|png|heic|webp|tiff|psd|ico|crimg)$/i) ||
($switches =~ /d/ && $file =~ /\./) ||
($switches =~ /S/ && $file =~ /\.setup$/) ||
($switches =~ /t/ && $file !~ /\.txt$/i) ||
($switches =~ /T/ && $file =~ /^\.(tn|pr)_/)
) {
$init--;
}
}
}
if (!$init) {
$init = 0;
}
return $init;
}
sub compare {
#: Compare files.
#:
#: Returns NULL if files are identical
#: Returns difference details if NOT identical
#:
#: $max: if file bigger than $max then only check file size (no diff)
#:
#: $fast: avoid using diff if possible, does not always return differences though
my ($self,$file1,$file2,$max,$fast) = @_;
my $vpath = &path;
$file1 = &cleanup("",$file1);
$file2 = &cleanup("",$file2);
if ($max && &size("",$file1) > $max) {
if (&size("",$file1) == &size("",$file2)) {
return 0;
} else {
return 1;
}
} else {
if ($fast) {
if (&size("",$file1) == &size("",$file2)) {
return `diff '$vpath/$file1' '$vpath/$file2'`;
} else {
return 1;
}
} else {
return `diff '$vpath/$file1' '$vpath/$file2'`;
}
}
}
sub mkpath {
#: Like mkdir(), but generates the entire path, including all of its subdirs.
#: Permissions may be set at the same time.
my ($self,$dir,$mode) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
$mode =~ s~[^0-7]~~g;
if ($dir) {
unless (-e "$vpath/$dir") {
my $path;
my @parts = split(/\//,$dir);
foreach my $part (@parts) {
$path .= "/$part";
unless (-e "$vpath$path") {
`mkdir $vpath$path`;
}
if (length $mode == 3) {
`chmod $mode $vpath$path`;
}
}
}
}
}
sub mkdir {
#: Create a new directory.
#: Permissions may be set at the same time.
#: Also see mkpath() for a more powerful alternative.
my ($self,$dir,$mode) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($dir) {
unless (-e "$vpath/$dir") {
`mkdir $vpath/$dir`;
}
}
$mode =~ s~[^0-7]~~g;
if (length $mode == 3) {
`chmod $mode $vpath/$dir`;
}
}
sub mkdir_new {
#: This will create a new subdir, add a number if such a subdir already exists,
#: and return the created name. The new subdir will always have permissions
#: set to 777.
my ($self,$dir,$new) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
$new = &cleanup("",$new);
my $name = $new;
my $whilecounter;
while ($whilecounter < 4096 && &exists("","$dir/$name")) {
$whilecounter++;
$name = "${new}_$whilecounter";
}
&mkdir("","$dir/$name","777");
return $name;
}
sub rmdir {
#: Remove directory, including all of its contents.
#: Recursive and with force delete enabled,
#: use rmdirsoft() for a less dangerous operation.
my ($self,$dir) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($vpath =~ /[A-Za-z0-9]/ && $dir =~ /[A-Za-z0-9]/ && $dir !~ /\.\./ && $dir !~ /(\*|\(|\)|\[|\])/ && &exists("",$dir)) {
`rm -rf $vpath/$dir`;
return "rm -rf $vpath/$dir";
} else {
return "ABORT";
}
}
sub rmdirsoft {
#: Like rmdir(), but without force.
my ($self,$dir) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($vpath =~ /[A-Za-z0-9]/ && $dir =~ /[A-Za-z0-9]/ && $dir !~ /\.\./ && $dir !~ /(\*|\(|\)|\[|\])/ && &exists("",$dir)) {
`rmdir $vpath/$dir`;
return "rmdir $vpath/$dir";
} else {
return "ABORT";
}
}
sub htaccess {
#: Password management and protection only.
#: See dirprotect to prevent directory listing.
#:
#: You need to specify $key, if this is empty then the protection
#: will be removed. To protect without any login option, simply
#: use ':' as $key.
my ($self,$dir,$key) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($key =~ /:/) {
&store("","$dir/.htaccess",qq~AuthName "Password Required"
AuthType Basic
AuthUserFile $vpath/$dir
require valid-user
~);
&store("","$dir/.htpasswd","$key\n");
&chmod("","$dir/.htaccess","777");
&chmod("","$dir/.htpasswd","777");
} else {
`rm -rf $vpath/$dir/.htaccess`;
`rm -rf $vpath/$dir/.htpasswd`;
}
}
sub htaccess_ip {
#: Restrict access to a directory only for one IP address.
my ($self,$dir,$ip) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($ip) {
&store("","$dir/.htaccess","order deny,allow\ndeny from all\nallow from $ip\n");
&chmod("","$dir/.htaccess","777");
} else {
`rm -rf $vpath/$dir/.htaccess`;
}
}
sub htaccess_rewrite {
#: Add a rewrite rule via .htaccess, simply indicate the target,
#: which must be a path to a script.
my ($self,$dir,$com) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
&store("","$dir/.htaccess","RewriteEngine on\nRewriteRule \^\(\.\*\)\$ $com \[L\]\n");
&chmod("","$dir/.htaccess","777");
}
sub htmlencode {
#: Encode a string by replacing HTML lt, gt and quot.
#: This will be useful in input fields for example.
my $input = $_[1];
$input =~ s~\<~<~g;
$input =~ s~\>~>~g;
$input =~ s~\"~"~g;
return $input;
}
sub size {
#: Return the size of a file, by default this will simply return the
#: number of bytes.
#:
#: Switches:
#:
#: -d recursive directory mode
#: -h human readable (add "bytes", "kb", or "mb")
#: -k kb
#: -l count lines
#: -w count words
my ($self,$file,$switches) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
my $size;
if ($file) {
if (!$switches || $switches =~ /(h|k)/) {
if ($switches =~ /d/ || &fileisdir("",$file)) {
# recursive dir size
$size = `du -sk "$vpath/$file"`;
$size =~ s~( |\n|\r|\t)(.*)$~~;
$size = $size * 1024;
} else {
# file size
$size = -s "$vpath/$file";
}
if ($switches =~ /h/) {
my $ext = "bytes";
if ($size > 4000000000) {
$size = 1+int($size/1024/1024/1024);
$ext = "GB";
} else {
if ($size > 4000000) {
$size = 1+int($size/1024/1024);
$ext = "MB";
} else {
if ($size > 8000) {
$size = 1+int($size/1024);
$ext = "KB";
}
}
}
$size .= " $ext";
}
if ($switches =~ /k/) {
$size = 1+int($size/1024);
}
}
if ($switches =~ /l/) {
$size = `wc -l '$vpath/$file'`;
$size =~ s~^\s+~~;
$size =~ s~ (.*)$~~;
$size =~ s~( |\n|\r|\t)~~g;
if (-s "$vpath/$file") {
$size++;
}
}
if ($switches =~ /w/) {
$size = `wc '$vpath/$file'`;
$size =~ s~(\n|\r|\t)~ ~g;
$size =~ s~\s+~ ~g;
$size =~ s~^\s+~~;
$size =~ m~^(.*?) (.*?) (.*?)~;
$size = $2;
}
}
return $size;
}
sub timestamp {
#: Return the modification (or creation) timestamp of a file or directory.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
my (
$dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
) = stat("$vpath/$file");
return $mtime;
}
sub touch {
#: Update the modification timestamp of a file or directory.
my ($self,$file,$time) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
$time =~ s~[^0-9]~~g;
if ($time =~ /[0-9]/) {
`touch -mt $time $vpath/$file`;
} else {
`touch $vpath/$file`;
}
}
sub type {
#: This is a file or a directory? Returns 'dir' or 'file'.
#: Please use dirfile() instead, or objtype(), which do
#: the same thing.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
my $type = "dir";
if (-f "$vpath/$file") {
$type = "file";
}
return $type;
}
sub stat {
#: Returns file or directory stats as an array.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
my (
$dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks
) = stat("$vpath/$file");
return ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks);
}
sub symlink {
#: Create a symlink.
my ($self,$file,$symlink) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
$symlink = &cleanup("",$symlink);
if ($file && $symlink) {
`ln -s $vpath/$file $vpath/$symlink`;
}
}
sub unlink {
#: Remove a symlink.
my ($self,$symlink) = @_;
my $vpath = &path;
$symlink = &cleanup("",$symlink);
if ($symlink) {
`unlink $vpath/$symlink`;
}
}
sub cp {
#: Copy a file to a new target.
#: Related thumbnails and setup files will also be
#: taken into consideration.
my ($self,$source,$target) = @_;
my $vpath = &path;
$source = &cleanup("",$source);
$target = &cleanup("",$target);
if ($source && $target) {
`cp $vpath/$source $vpath/$target`;
my ($pr1,$tn1) = &getthumbs("",$source);
if ($pr1 && $tn1) {
my ($pr2,$tn2) = &getthumbs("",$target);
`cp $vpath/$pr1 $vpath/$pr2`;
`cp $vpath/$tn1 $vpath/$tn2`;
}
my $setup1 = &getsetup("",$source);
if ($setup1) {
my $setup2 = &getsetup("",$target,"x");
`cp $vpath/$setup1 $vpath/$setup2`;
}
}
}
sub cpr {
#: Recursively copy a directory.
#:
#: Switches:
#:
#: -p preserve file properties
#: -n do not overwrite an existing file
my ($self,$source,$target,$switches) = @_;
my $vpath = &path;
$source = &cleanup("",$source);
$target = &cleanup("",$target);
my $flags;
if ($switches =~ /p/) {
$flags .= "p";
}
if ($switches =~ /n/) {
$flags .= "n";
}
if ($source && $target) {
`cp -r$flags $vpath/$source $vpath/$target`;
}
}
sub mv {
#: Move or rename a file or a directory.
#: Related thumbnails and setup files will also be
#: taken into consideration.
my ($self,$source,$target) = @_;
my $vpath = &path;
$source = &cleanup("",$source,1);
$target = &cleanup("",$target);
if ($source && $target) {
`mv '$vpath/$source' '$vpath/$target'`;
my ($pr1,$tn1) = &getthumbs("",$source);
if ($pr1 && $tn1) {
my ($pr2,$tn2) = &getthumbs("",$target);
`mv '$vpath/$pr1' '$vpath/$pr2'`;
`mv '$vpath/$tn1' '$vpath/$tn2'`;
}
my $setup1 = &getsetup("",$source);
if ($setup1) {
my $setup2 = &getsetup("",$target,"x");
`mv '$vpath/$setup1' '$vpath/$setup2'`;
}
}
}
sub mvdirty {
#: Like mv(), but for "dirty" sources containing
#: bad characters.
#: Related thumbnails and setup files will also be
#: taken into consideration.
my ($self,$source,$target) = @_;
my $vpath = &path;
$source =~ s~\&~\\\&~g;
$source =~ s~\(~\\\)~g;
$source =~ s~\)~\\\)~g;
$source =~ s~\'~\\\'~g;
$source =~ s~\"~\\\"~g;
if ($source && $target) {
`mv '$vpath/$source' '$vpath/$target'`;
my ($pr1,$tn1) = &getthumbs("",$source);
if ($pr1 && $tn1) {
my ($pr2,$tn2) = &getthumbs("",$target);
`mv $vpath/$pr1 $vpath/$pr2`;
`mv $vpath/$tn1 $vpath/$tn2`;
}
my $setup1 = &getsetup("",$source);
if ($setup1) {
my $setup2 = &getsetup("",$target,"x");
`mv $vpath/$setup1 $vpath/$setup2`;
}
}
return "mv '$vpath/$source' '$vpath/$target'";
}
sub split {
#: Split a file into pieces.
my ($self,$source,$target,$size) = @_;
my $vpath = &path;
$source = &cleanup("",$source);
$target = &cleanup("",$target);
if ($source && $target) {
if (!$size) {
$size = 65536;
}
`split -b $size $vpath/$source $vpath/$target`;
}
}
sub chmod {
#: Change file or directory permissions.
my ($self,$object,$mode) = @_;
my $vpath = &path;
$object = &cleanup("",$object);
$mode =~ s~[^0-7\-\r\R\ ]~~gi;
if ($object && length $mode > 2) {
`chmod $mode $vpath/$object`;
}
return "chmod $mode $vpath/$object";
}
sub exec {
#: Execure a UNIX command, via ONO::Core::Kernel's exec() function.
my ($self,$exec) = @_;
return ONO::Core::Kernel->exec($exec);
}
sub exec2 {
#: Execure a UNIX command.
#: This is a less restrictive version of exec() (allows (\',\",\@,\:,\[,\])).
my ($self,$exec) = @_;
$exec =~ s~[^A-Za-z0-9\ \-\_\.\/\'\"\@\:\[\]]~~g;
return `$exec`;
}
sub exec3 {
#: Execure a UNIX command.
#: This is a zero restrictions version of exec (allows everything)
#: THIS MAY BE DANGEROUS TO USE - especially if you're using it in a script that's running with root privileges.
my ($self,$exec) = @_;
return `$exec`;
}
sub domain {
#: Return the domain, remove stuff like 'www' and other subdomains.
my $domain = &domain_full();
$domain =~ s~^(www|en|us|uk|de|at|ch|fr|be|lu|lb|nl|es|pt|it|dk|da|fi|no|sv|se)\.~~;
return $domain;
}
sub domain_full {
#: Return the domain, including 'www' or subdomains for example.
#: The domain can also be set via a configuration file (etc/domain.conf),
#: which may be required in some proxy environments.
my $domain = $ENV{'HTTP_HOST'};
if (!$domain) {
$domain = $ENV{'SERVER_NAME'};
}
if (!$domain && &exists("","etc/domain.conf")) {
$domain = &load("","etc/domain.conf");
$domain =~ s~(\n|\r|\t)~~g;
}
return $domain;
}
sub http {
#: Returns 'http' or 'https', depending on the current SSL status of the domain.
my $HTTP = "http";
if ($ENV{'HTTPS'} || &exists("","etc/https.conf")) {
$HTTP = "https";
}
return $HTTP;
}
sub https {
#: Returns 1 if SSL is available, or 0 is SSL is not available.
#: Returning 1 can be forced, by adding a dedicated setup file
#: (etc/https.conf), which may be required in certain proxy
#: environments.
if ($ENV{'HTTPS'} || &exists("","etc/https.conf")) {
return 1;
} else {
return 0;
}
}
sub http_domain_base {
#: Returns http(s)://www.example.com/ono/path/. This basically
#: glues the http(), domain() and base() functions.
return &http()."://".&domain().&base();
}
sub refresh {
#: HTML refresh, this will simply auto-redirect to a different page.
#: In most cases, you will simply push refresh($url) to the client.
#:
#: You may specify seconds to wait, and you may also force using
#: SSL/https for the destination.
#:
#: For testing purposes, the 'auto' feature is disabled on
#: development stations, which will display a clickable link
#: displaying the entire URL instead. Using $devstation_overrule
#: will override this behaviour and enable the 'auto' features
#: on development stations too.
my (
$self,
$URL,
$SECS,
$HTTP_FORCE,
$devstation_overrule,
) = @_;
$URL =~ s~^http(|s)\://~~;
if ($SECS < 1) {
$SECS = 0;
}
my $HTTP = &http;
if ($HTTP_FORCE) {
$HTTP = $HTTP_FORCE;
}
$URL = ONO::Lib::Basic->remove_doubles($URL,"/");
if ($URL !~ /^\//) {
$URL = "${HTTP}://$URL";
}
if (&devstation && !$devstation_overrule) {
my $SHOW_URL = ONO::Lib::Basic->pathbreaks($URL);
my $chars = length $URL;
return qq~Devstation: refresh after $SECS secs, $chars chars: <a href="$URL">$SHOW_URL</a>~;
} else {
return qq~<meta http-equiv="refresh" content="$SECS; url=$URL">~;
}
}
sub upload_url {
#: Returns the rawdata.pl upload script URL.
my $RND = 9000000000 + int(rand(999999999));
my $URL = "/cgi-bin/local/perl/$_[1]/ajax/rawdata.pl?";
# $URL .= "?ono_ref_id=$RND&";
return $URL;
}
sub upload {
#: CGI upload, which allows single file upload directly via ONO::IO.
#: In most cases, you will avoid this and use ONO::ToolBox::Upload
#: and ONO::Lib::Web::Upload instead.
#:
#: $max = file size limit (absolute limit = 4 MB)
#:
#: -g only accept GIF
#: -i only accept images (JPG, PNG, GIF, WEBP)
#: -j only accept JPG
#: -p only accept PNG
#: -P only accept PDF
#: -w only accept WebP
my ($self,$handle,$dir,$file,$max,$switches) = @_;
my $vpath = &path;
$handle = &cleanup("",$handle);
$dir = &cleanup("",$dir);
$file = &cleanup("",$file);
my $cgi = new CGI;
if (!$file) {
$file = lc $cgi->param($handle);
}
my ($data,$data1);
if (my $fh = $cgi->upload($handle)) {
$data1 .= $data while read $fh, $data, 1024;
}
my $valid_file = 1;
my $ext;
my $magic = lc unpack('H8',substr($data1,0,1)).unpack('H8',substr($data1,1,1)).unpack('H8',substr($data1,2,1));
if ($switches =~ /(g|i|j|p)/) {
$valid_file = 0;
if ($switches =~ /(i|j)/ && ($data1 =~ m/JFIF/ || $magic eq "ffd8ff")) {
$valid_file = 1;
$ext = "jpg";
}
if ($switches =~ /(i|g)/ && ($data1 =~ m/GIF87a/ || $data1 =~ m/GIF89a/ || $magic eq "474946")) {
$valid_file = 1;
$ext = "gif";
}
if ($switches =~ /(i|p)/ && ($data1 =~ m/PNG/ || $magic eq "89504e")) {
$valid_file = 1;
$ext = "png";
}
if ($switches =~ /(i|w)/ && ($data1 =~ m/^RIFF/)) {
$valid_file = 1;
$ext = "webp";
}
}
if ($switches =~ /P/) {
$valid_file = 0;
if ($data1 =~ m/PDF/ || $magic eq "255044") {
$valid_file = 1;
$ext = "pdf";
}
}
if ($ext) {
# don't do this for files starting by a dot (required for /.icon.jpg)
if ($file !~ /^\./) {
$file =~ s~\.(.*)$~~;
}
$file .= ".$ext";
}
if ($data1 && $valid_file && (!$max || $max*1024 > length $data1) && length $data1 < 4096*1024) {
&mkpath("",$dir);
&dump("","$dir/$file",$data1);
return "$dir/$file";
} else {
return "";
}
}
sub which {
#: Find a UNIX binary. Accepts the binary name as input,
#: returns the path to the binary.
my ($self,$source) = @_;
$source = &cleanup("",$source);
my $res = `which $source`;
$res =~ s~[^A-Za-z0-9\/\-]~~gi;
return $res;
}
sub unzip {
#: Unzip a file or directory.
my ($self,$source,$target) = @_;
my $vpath = &path;
$source = &cleanup("",$source);
$target = &cleanup("",$target);
`unzip $vpath/$source -d $vpath/$target`;
return "unzip unzip $vpath/$source -d $vpath/$target";
}
sub tar {
# Archive a file or directory.
my ($self,$source,$target) = @_;
my $vpath = &path;
$source = &cleanup("",$source);
$target = &cleanup("",$target);
`tar -zcf $vpath/$target $vpath/$source`;
return "tar -zcf $vpath/$target $vpath/$source";
}
sub deepdir {
#: Turns 'ABCXYZ' into 'A/AB/ABC'.
my $sep = $_[2];
if (!$sep) {
$sep = "/";
}
return substr($_[1],0,1).$sep.substr($_[1],0,2).$sep.substr($_[1],0,3);
}
sub deepdirs {
#: Turns 'ABCXYZ' into ('A','AB','ABC').
return (substr($_[1],0,1),substr($_[1],0,2),substr($_[1],0,3));
}
sub deepnum {
# Like deepdir(), but this one is working with numbers, the input
# number will automatically be expanded to 10 digits.
my $id = ONO::Lib::Basic->add_leading_zeroes($_[1],9);
my $sep = $_[2];
if (!$sep) {
$sep = "/";
}
return substr($id,0,3).$sep.substr($id,3,3).$sep.substr($id,6,3);
}
sub zip {
#: Compress a file.
#: Warning: gzip only works with single files, use 'tar' to zip entire directories
my ($self,$file) = @_;
my $vpath = &path;
`gzip $vpath/$file`;
}
sub readsetup {
#: Read a setup file.
#: -H no HTML parsing (preserve <br>)
my (
$self,
$object,
$flags,
) = @_;
my $vpath = &path;
$object = &cleanup("",$object);
my $setup = &getsetup("",$object);
my %hash;
$hash{'debug'} = "FILE: $object -> $setup<br>";
if ($setup) {
foreach my $data (&list("",$setup)) {
my @dp = split(/\^/,$data);
if ($flags !~ /H/) {
$dp[1] =~ s~\<br\>~\n~g;
}
$hash{$dp[0]} = $dp[1];
}
}
return \%hash;
}
sub savesetup {
#: Save / store a setup file.
#: -m multi-line mode for meta data, replaces newline/return by HTML <br>
my (
$self,
$object,
$vars_ref,
$switches,
) = @_;
my $vpath = &path;
$object = &cleanup("",$object);
my %vars = %$vars_ref;
my $setup = &getsetup("",$object,"x");
my $DEBUG = "FILE: $object -> $setup<br>";
my $DATA;
# this does not yet check security (_locks), therefore this can't be universally used
foreach my $meta ('title','subtitle','date','sort','description','instructions','branch','rename_lock','delete_lock','system_lock') {
if ($vars{"setup_$meta"}) {
$vars{"setup_$meta"} =~ s~(\n|\r|\t)~\<br\>~g;
$DATA .= qq~$meta\^$vars{"setup_$meta"}\^\n~;
}
}
# custom data, may be used by any application:
foreach my $key (keys %vars) {
if ($key =~ /^setup_custom_(.*?)$/) {
my $meta = $1;
if ($vars{$key} =~ /[A-Za-z0-9\-]/) {
if ($switches =~ /m/) {
$vars{$key} =~ s~(\n|\r)~<br>~g;
$vars{$key} =~ s~(\t)~~g;
} else {
$vars{$key} =~ s~(\n|\r|\t)~~g;
}
$DATA .= qq~custom_$meta\^$vars{$key}\^\n~;
}
}
}
if ($DATA) {
&store("",$setup,$DATA);
} else {
&rm("",$setup);
}
return $DEBUG;
}
sub getdir {
#: Transform /my/path/to/file.ext into /my/path/to/.
#:
#: Only works correctly if the input is using a correct
#: /my/path/to/file.ext format.
my ($self,$path) = @_;
my $file = $path;
$file =~ s~^(.*)/~~;
return $1;
}
sub getdirfile {
#: Transform /my/path/to/file.ext into ('/my/path/to/','file.ext').
#:
#: Only works correctly if the input is using a correct
#: /my/path/to/file.ext format.
my ($self,$path) = @_;
my $file = $path;
$file =~ s~^(.*)/~~;
my $dir = $1;
return ($dir,$file);
}
sub getdirfileext {
# Transform /my/path/to/file.txt into ('/my/path/to/','file','ext').
#
# Only works correctly if the input is using a correct
# /my/path/to/file.ext format.
my ($self,$path) = @_;
$path =~ s~^(.*)/~~;
my $dir = $1;
$path =~ m~^(.*)\.(.*?)$~;
return ($dir,$1,$2);
}
sub getfileext {
#: Return the file and its extension, eg file.ext becomes ('file','ext').
my $file = $_[1];
$file =~ m~^(.*)\.(.*?)$~;
return ($1,$2);
}
sub getfiletype {
#: Return file type: image, audio, video or pdf.
#: Will be empty if it's none of those.
my $filetype;
if ($_[1] =~ m~\.(jpg|jpeg|png|webp|gif|tiff|psd|ico|crimg)$~i) {
$filetype = "image";
}
if ($_[1] =~ m~\.(mp3|wav|flac|ogg)$~i) {
$filetype = "audio";
}
if ($_[1] =~ m~\.(mp4|m4v|mpg|mpeg|m2ts|mov|mkv|f4v|avi|vob|wmv|flv|f4v|m4v|divx|webm|mp4c|ts)$~i) {
$filetype = "video";
}
if ($_[1] =~ m~\.(pdf)$~i) {
$filetype = "pdf";
}
return $filetype;
}
sub getthumbs {
#: Returns paths to preview and thumbnail files.
#: Returns nothing if the file type does not allow for thumbnail files.
my ($self,$path) = @_;
if ($path =~ m~\.(jpg|png|gif|webp|heic|tiff|mp4|m4v|mpg|mpeg|mov|mkv|avi|vob|wmv|flv|f4v|divx|webm|mp4c|ts|pdf)$~i) {
my $file = $path;
$file =~ s~^(.*)/~~;
my $dir = $path;
$dir =~ s~/$file~~;
$file =~ s~\.(png|gif|webp|heic|tiff|mp4|m4v|mpg|mpeg|mov|mkv|avi|vob|wmv|flv|f4v|divx|webm|mp4c|ts|pdf)$~\.jpg~i;
# $file =~ s~\.JPG$~\.jpg~;
return ("$dir/.pr_$file","$dir/.tn_$file");
} else {
return ("","");
}
}
sub getthumbs_ifexists {
#: Returns paths to preview and thumbnail files, but onyl if they exist, and if the file type supports them.
my ($self,$path) = @_;
my ($pr,$tn) = &getthumbs("",$path);
if (&exists("",$pr) && &exists("",$tn)) {
return ($pr,$tn);
} else {
return ("","");
}
}
sub rmthumbs {
#: Remove thumbs and previews from a file, leave the file intact.
my ($self,$path) = @_;
my $vpath = &path;
my $del;
my ($pr1,$tn1) = &getthumbs("",$path);
if ($pr1 && -e "$vpath/$pr1") {
`rm "$vpath/$pr1"`;
$del .= ":$pr1";
}
if ($tn1 && -e "$vpath/$tn1") {
`rm "$vpath/$tn1"`;
$del .= ":$tn1";
}
if ($del) {
return "$path$del;";
} else {
return "";
}
}
sub getsetup {
#: Returns the path to an optional setup file.
#:
#: Switches:
#:
#: -x override exists check (required for creating a new file)
my ($self,$path,$flags) = @_;
if ($path =~ /\./) {
$path =~ s~\.(.*?)$~\.setup~;
} else {
$path .= ".setup";
}
if (&exists("",$path) || $flags =~ /x/) {
return $path;
} else {
return "";
}
}
sub getimage {
#: Replace an image URL into a preview or thumbnail URL if the
#: required files exist, and if the image dimensions are adequate.
my ($self,$img,$w,$h) = @_;
my $vpath = &path;
if ($w < 241 && $h < 181) {
my ($pr,$tn) = &getthumbs("",$img);
if ($pr && -e "$vpath/$pr") {
$img = $pr;
}
if ($tn && -e "$vpath/$tn" && $w < 121 && $h < 121) {
$img = $tn;
}
}
return $img;
}
sub image {
#: Returns 1 if file extension is image, or 0 if not.
#: This works for both filenames, and directory/filename
#: combinations.
if ($_[1] =~ /\.(jpg|jpeg|gif|png|heic|webp|tiff|psd|ico|crimg)$/i) {
return 1;
} else {
return 0;
}
}
sub imagefile {
#: Same as image(), but does not work for preview and thumbnail files.
if (&image("",$_[1]) && $_[1] !~ /^\./) {
return 1;
} else {
return 0;
}
}
sub imageexts {
#: Return a list of common (not all) image extensions.
return ('jpg','jpeg','png','gif','webp');
}
sub pixel {
#: Returns a pixel image as a data stream.
return $PIXEL;
}
sub video {
#: Returns 1 if file extension is video, or 0 if not.
#: This works for both filenames, and directory/filename
#: combinations.
if ($_[1] =~ /\.(mp4|m4v|mpg|mpeg|m2ts|mov|mkv|f4v|avi|vob|wmv|flv|f4v|m4v|divx|webm|mp4c|ts)$/i) {
return 1;
} else {
return 0;
}
}
sub inputfilter {
#: Filter and return input, by removing a number of special characters
my $input = $_[1];
$input =~ s~(\"|\<|\>|\(|\)|\*|\!|\\)~~gi;
return $input;
}
sub inputfilters {
#: Like inputfilter(), but for arrays.
my (
$self,
@inputs,
) = @_;
my @new;
foreach my $input (@inputs) {
@new = (@new,&inputfilter("",$input));
}
return @new;
}
sub xmlget {
#: Get / extract XML data. This only works for very simple XML files,
#: and it will only return the first instance of the data.
my $XML = &load("",$_[1]);
$XML =~ s~(\n|\r|\t)~~g;
$XML =~ s~\<$_[2]\>(.*?)\</$_[2]\>~~i;
return $1;
}
###############################################################################
# end of script
###############################################################################
1;
__END__
################################################################################
# COPYRIGHT / LICENSE #
################################################################################
#
# This file is part of the ONO Software Project.
#
# Copyright (C) 2000-2025 Jos KIRPS [ www.kirps.com | jos_AT_kirps_DOT_com ]
# and The Joopita Project [ www.joopita.org | contact_AT_joopita_DOT_com ]
#
# This file, as well as other parts of the ONO Software Project or related
# elements, are FREE SOFTWARE available under the ARTISTIC LICENSE 2.0.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# For the full license, see /ono/osr/license/LICENSE.txt, or write to
# jos_AT_kirps_DOT_com or contact_AT_joopita_DOT_com.
#
################################################################################
# END OF COPYRIGHT / LICENSE, HERE COMES THE CODE ... #
################################################################################
use CGI;
use strict;
use ONO::Lib::Basic;
use ONO::Core::Kernel;
use ONO::Core::HostOS;
use ONO::Lib::DateTime::ToolBox;
use ONO::Lib::Web::Client;
###############################################################################
# ONO
###############################################################################
#: ONO::IO is responsible for all file and directory accesses, as long as they
#: are located within the ONO document root directory. All I/O should either
#: be handled by ONO::IO, or by ONO::Core::HostIO, you should not use low level
#: Perl I/O stuff in your ONO projects.
#:
#: Important I/O calls include:
#:
#; load(), list(), store(), append(), dump(), ls() / dir(), mkdir(), mkpath(), exists(), mv(), cp(), cpr(), rm(), rmdir()
#:
#: ONO::IO also allows to manage cache and configuration files for example:
#; cacheread(), cachewrite(), confread(), confwrite()
#:
#: Most ONO::IO calls respect the presence of thumbnail and preview files,
#: those can also be detected if necessary:
#; getthumbs(), getthumbs_ifexists()
#:
#: Furthermore, the module offers access to system information and allows for
#: system interaction:
#; os(), cpu(), mem(), disks(), domain(), sys(), exec(), http(), https(), http_domain_base(), sysload()
#:
#: ONO::IO also helps with software development, by detecting development
#: stations and offering appropriate tools, for example:
#; devstation(), devprint(), debug()
#:
#: For file and directory I/O outside of the ONO document root, see
#: ONO::Core::HostIO.
my @SYSLOADMSG = (
"This content cannot be displayed right now. Please try again in a few minutes – Thank you!",
"Dieser Inhalt kann momentan nicht angezeigt werden. Bitte versuche es in ein paar Minuten nochmals - Vielen Dank!",
"Ce contenu ne peut pas être affiché actuellement. Veuillez réessayer dans quelques minutes - Merci beaucoup!",
"Dëse Contenu ka momentan net ugewise ginn. Probéier w.e.g. an e puer Minutte nach eng Kéier - Villmols Merci!",
);
my $PIXEL = "Content-Type: image/gif\n\n";
open (FILE, &path."/ono/osr/images/spacer/trans.gif");
flock FILE, 1;
$PIXEL .= <FILE>;
close (FILE);
my ($devstation_file,$devstation_option);
if (&exists("","cgi-bin/devstation.txt")) {
$devstation_file = 1;
}
# make sure that devstation will run cron bots too:
if (-e "/mnt/ono/cgi-bin/devstation.txt" && !$ENV{'SERVER_NAME'}) {
$devstation_option = 1;
}
my $is_local;
if ($ENV{'SERVER_NAME'} eq "127.0.0.1" || $ENV{'SERVER_NAME'} =~ /^192\.168\./ || $ENV{'SERVER_NAME'} =~ /^172\.16\./ || $ENV{'SERVER_NAME'} =~ /\.local$/) {
$is_local = 1;
}
###############################################################################
# SUBS
###############################################################################
sub path {
#: Returns the UNIX path to the ONO document root directory. This is the
#: same as ONO::Core::Kernel->vpath, so you may simply get this info via
#: ONO::IO.
return ONO::Core::Kernel->vpath;
}
sub binary_dirs {
#: List UNIX directories that may contain useful UNIX binaries that can be
#: used by certain ONO::Lib modules for example.
return ("/usr/bin","/usr/local/bin","/opt/local/bin");
}
sub base {
#: Return the software base (if cgi-bin is not on the document root level,
#: as in www.example.com/path/lang/cgi-bin/... for example). Note that the
#: base always needs to be composed of 2 subdirectories.
my $base;
if (!$ENV{'SCRIPT_NAME'}) {
if (&exists("","etc/software_base.conf")) {
$base = &load("","etc/software_base.conf");
$base =~ s~(\n|\r|\t)~~g;
}
} else {
if ($ENV{'SCRIPT_NAME'} =~ m~/(.*?)/(.*?)/cgi-bin/~) {
$base = "/$1/$2";
}
}
return $base;
}
sub project {
#: Return the name of an ONO project, as in
#: www.example.com/cgi-bin/local/perl/project_name/... for example.
my $community;
if ($ENV{'SCRIPT_NAME'} =~ m~/cgi-bin/local/perl/(.*?)/~) {
$community = $1;
}
return $community;
}
sub community {
#: Same as project().
return &project();
}
sub path2dir {
#: Demove everything behind the last slash (including the last slash itself).
#: This will remove any file info from the directory and return the pure
#: directory path.
#:
#: Also see getdir(), getdirfile(), and getdirfileext(), which will be more
#: useful in most cases.
my $path = $_[1];
$path =~ s~/[^/]*$~~;
return $path;
}
sub cachefile {
#: Turn a file (directory/path plus filename) into a cache ID filename.
#: This is usually not required, but it's used internally by other
#: cache related functions.
my ($self,$file) = @_;
$file = ONO::Lib::Basic->remove_doubles($file,"-");
for (my $i = 0; $i < 4; $i++) {
$file =~ s~-~/~;
}
return $file;
}
sub cacheexists {
#: Check if a cache entry exists (returns 1 if yes, or 0 if not).
my ($self,$file) = @_;
$file = &cachefile("",$file);
if (&exists("","var/tmp/cache/$file.txt")) {
return 1;
} else {
return 0;
}
}
sub cacheclean {
#: Removes a cache file.
#:
#: Note that empty dirs in /var/tmp/cache are not being removed, which
#: means that some sort of garbage collection will be required some day...
my ($self,$file) = @_;
$file = &cachefile("",$file);
&rm("","var/tmp/cache/$file.txt");
}
sub cachetimestamp {
#: Get the timestamp of a cache file, which may be useful to decide
#: if it's time to remove or replace it.
my ($self,$file) = @_;
$file = &cachefile("",$file);
return ×tamp("","var/tmp/cache/$file.txt");
}
sub cachereadsimple {
#: Simplified form of cacheread(), simple and fast, supplies no useful info,
#: just returns the content of the cache, doesn't automatically manage or
#: delete anything by itself.
my ($self,$file,$verbose) = @_;
$file = &cachefile("",$file);
if ($verbose) {
return "<!-- ONOIOCacheStart -->".&load("","var/tmp/cache/$file.txt")."<!-- ONOIOCacheEnd -->";
} else {
return &load("","var/tmp/cache/$file.txt");
}
}
sub cachelistsimple {
#: Simplified form of cachelist(), simple and fast, supplies no useful info,
#: just returns the content of the cache, doesn't automatically manage or
#: delete anything by itself.
my ($self,$file) = @_;
$file = &cachefile("",$file);
return &list("","var/tmp/cache/$file.txt");
}
sub cacheread {
#: Read a cache file, and do some cache management at the same time.
#:
#: If $time is provided, then we'll only read the cache if it's not older
#: than T minutes. if it's older, then the cache file will simply be removed.
#:
#: Switches:
#:
#: -d debugging mode
#: -L list mode, allows to read arrays
#: -S silent mode
#: -v verbose (can be useful when debuggin HTML)
#: -V verbose only if not empty
#:
#: If no options and no cache management is required, then cachereadsimple()
#: will be a better and faster option here.
my ($self,$file,$time,$switches) = @_;
$file = &cachefile("",$file);
my $TIME;
if ($time) {
$TIME = ×tamp("","var/tmp/cache/$file.txt");
my $AGE = (int((time() - $TIME)/6)/10);
if ($AGE < $time) {
$time = 0;
if ($switches !~ /S/) {
$TIME = "\n<!-- ONOCacheAge:${AGE}m -->";
}
}
}
if (!$time) {
if ($switches =~ /L/) {
# return an array
my (@array,$count);
foreach my $line (&list("","var/tmp/cache/$file.txt")) {
$count++;
$line =~ s~\n$~~;
@array = (@array,$line);
}
if ($count) {
return @array;
} else {
return ();
}
} else {
# return a string
my $CACHE = &load("","var/tmp/cache/$file.txt");
if ($switches =~ /v/) {
if ($switches !~ /V/ || $CACHE) {
return "\n<!-- ONOCacheStart:$file -->$TIME\n$CACHE\n<!-- ONOCacheEnd:$file -->\n";
} else {
return $CACHE;
}
} else {
return $CACHE;
}
}
} else {
&rm("","var/tmp/cache/$file.txt");
if ($switches =~ /L/) {
return ();
} else {
return "";
}
}
}
sub cachewritesimple {
#: Simplified form of cachewrite(), simple and fast, doesn't do anything special.
#: Just writes the data, doesn't automatically manage or
#: delete anything by itself.
my ($self,$file,$data) = @_;
$file = &cachefile("",$file);
my ($path) = &getdirfile("","var/tmp/cache/$file.txt");
&mkpath("",$path);
&store_rm("","var/tmp/cache/$file.txt",$data);
}
sub cachewrite {
#: Write a cache file, and do some cache management at the same time.
#:
#: Switches:
#:
#: -D delete if empty
#: -E don't write if empty
#: -L list mode, allows to store arrays, requires $data to be a hash reference
#: -v verbose
#: -V Verbose only if not empty
#:
#: If no options and no cache management is required, then cachewritesimple()
#: will be a better and faster option here.
my ($self,$file,$data,$switches) = @_;
$file = &cachefile("",$file);
if ($switches !~ /L/ && $switches =~ /v/ && ($switches !~ /V/ || $data)) {
my $time = ONO::Lib::DateTime::ToolBox->convert("classic",time());
$data = "<!-- ONOCacheTimestamp:$time -->\n$data";
}
if ($switches =~ /L/) {
my @lines = @$data;
$data = "";
foreach my $line (@lines) {
$data .= "$line\n";
}
}
if ($switches !~ /E/ || $data) {
my ($path) = &getdirfile("","var/tmp/cache/$file.txt");
&mkpath("",$path,777);
&store("","var/tmp/cache/$file.txt",$data);
}
if ($switches =~ /D/ && !$data) {
&rm("","var/tmp/cache/$file.txt");
}
}
sub cleanup {
#: The cleanup() function will remove all special characters form a
#: filename, directory name, or a path. The override option may be
#: used for any data stored within the /servers tree.
my ($self,$file,$override) = @_;
$file =~ s~^/~~;
if ($override && $file =~ m~^servers/~) {
# server mode allows override
} else {
# cleanup will not be executed on files located on a fileserver
if ($file !~ m~^servers/~) {
$file =~ s~[^A-Za-z0-9\_\-\.\/\@\(\)]~~g;
}
}
return $file;
}
sub colread {
#: This allows to quickly read files in name:value list format,
#: data will be returned in hash format.
my %conf;
foreach my $line (&list("",$_[1])) {
$line =~ s~(\n|\r|\t)~~g;
if ($line =~ /^(.*?):(.*?)$/) {
$conf{$1} = $2;
}
}
return %conf;
}
sub confread {
my ($self,$file,$switches) = @_;
#: Read an ONO configuration file.
#:
#: Switches:
#:
#: -L make value lower case
my %conf;
foreach my $line (&list("",$file)) {
if (substr($line,0,1) ne "#" && $line =~ /[A-Za-z0-9]/) {
my @lp = split(/ /,$line);
$line =~ s~^$lp[0] ~~;
if ($switches !~ /L/) {
$lp[0] = lc $lp[0];
}
if ($line =~ /("|')/) {
my $separator = $1;
$line =~ /$separator(.*)$separator/;
$lp[1] = $1;
}
$lp[1] =~ s/\n//;
if ($lp[0]) {
$conf{"$lp[0]"} = $lp[1];
}
}
}
return %conf;
}
sub confwrite {
#: Write an ONO configuration file.
#: This is basically the same as the store() function, which means that
#: YOU will need to take care of formatting the data before sending it.
&store("",$_[1],$_[2]);
}
sub confupdate {
#: Update an ONO configuration file, which replaces the $value of the
#: $name entry. The remaining data will not be touched.
my ($self,$file,$name,$value) = @_;
my ($DATA,$exists);
foreach my $line (&list("",$file)) {
$line =~ s~(\n|\r|\t)~~g;
if ($exists == 0 && ($line =~ /^$name / || $line =~ /^$name$/ || $line =~ /^(#|# )$name / || $line =~ /^(#|# )$name$/)) {
# disable the line
if (($line =~ /^$name / || $line =~ /^$name$/) && $value eq "#") {
$line = "#$line";
$exists = 1;
}
# save an empty value, but leave activated
if (!$value) {
$line = qq~$name~;
$exists = 1;
}
# update the line
if ($value && $value ne "#") {
if ($value =~ / /) {
$value = qq~"$value"~;
}
$line = qq~$name $value~;
$exists = 1;
}
}
$DATA .= "$line\n";
}
if (!$exists) {
$DATA .= "\n$name $value\n";
}
&store("",$file,$DATA);
}
sub curl {
#: Retrieve a file from the web, return the data as a stream.
#: Be careful not to pass the input unchecked, and don't allow
#: user input to be passed to this function!
my ($self,$url) = @_;
if ($url && $url !~ /^http/) {
$url = "http://$url";
}
$url !~ s~(\`|\||\')~~g;
return `curl -k '$url'`;
}
sub curlstore {
#: Same as curl(), but dump / store the data into a file.
my ($self,$url,$file) = @_;
my $CURL = &curl("",$url);
if ($CURL) {
$file =~ s~[^A-Za-z0-9\_\-\.\/\@\(\)]~~g;
&dump("",$file,$CURL);
}
}
sub debug {
#: Append to /__debug.txt. This should not be used on production systems,
#: but only on development stations. It may be used temporarely on
#: production systems to analyze problems that need a quick fix, but
#: make sure to remove /debug.txt later on then.
my ($self,$data) = @_;
my $vpath = &path;
open (FILE,">>$vpath/__debug.txt");
print FILE $data;
close FILE;
}
sub device {
#: Return the type of device in use.
#:
#: 3 ways to use this:
#:
#: device() will return either computer, tablet or phone
#:
#: device(type) will return either 0 or 1
#:
#: device("useragent") will return the user agent
#:
#: iPad Warning:
#:
#: Note that current iPads identify themselves as Intel Macs.
#: A dirty trick is needed to identify them correcty:
#: 1. First test if it's a Mac, using ONO;;IO->device("mac")
#: 2. The use if (navigator.maxTouchPoints > 1) {...} to execute JS
my $input = $_[1];
my $device = "computer";
if ($ENV{'HTTP_USER_AGENT'} =~ /(mobile|tablet|ipad|android)/i) {
$device = "tablet";
}
if ($ENV{'HTTP_USER_AGENT'} =~ /phone/i) {
$device = "phone";
}
if ($input) {
$device = 0;
if ($input eq "computer" && $ENV{'HTTP_USER_AGENT'} !~ /(mobile|tablet|ipad|android|phone)/i) {
$device = 1;
}
if ($input eq "mac" && $ENV{'HTTP_USER_AGENT'} =~ /macintosh/i) {
$device = 1;
}
if ($input eq "tablet" && $ENV{'HTTP_USER_AGENT'} =~ /(mobile|tablet|ipad|android)/i) {
$device = 1;
}
if ($input eq "phone" && $ENV{'HTTP_USER_AGENT'} =~ /phone/i && $ENV{'HTTP_USER_AGENT'} !~ /ipad/i) {
$device = 1;
}
if ($input eq "mobile" && $ENV{'HTTP_USER_AGENT'} =~ /(mobile|tablet|ipad|android|iphone)/i) {
$device = 1;
}
if ($input eq "useragent") {
$device = $ENV{'HTTP_USER_AGENT'};
}
}
return $device;
}
sub devstation {
#: This will return 1 if we're on a devstation, or 0 if we're on a production system.
#: This will only work if...
#:
#: ... we're in a local network and a file named /cgi-bin/devstation.txt is available,
#: or ...
#:
#: ... the file /mnt/ono/cgi-bin/devstation.txt is present on the UNIX root level.
#:
#: Note that the devstation.txt file should contain the devstation client's IP
#: address as content.
if (($devstation_file && &local()) || $devstation_option) {
return &load("","cgi-bin/devstation.txt");
} else {
return 0;
}
}
sub devstation_variation {
#: This will return the variation code (if present) which will allow to test
#: different domain-based variations of a site/platform on your devstation.
#:
#: This is used by the variation call in ONO_Lib_Web_Doamin for example, which
#: should be the default method to check for variations of a platform.
#:
#: The variation code should be in /cgi-bin/devstation_variation.txt, and this
#: will only work on a devstation, not on a production system.
if (($devstation_file && &local()) || $devstation_option) {
return &load("","cgi-bin/devstation_variation.txt");
} else {
return "";
}
}
sub devstation_refresh {
#: Only refresh if devstation - probably deprecated ?
# if (&devstation) {
# my $DEVSTATION_IP = &devstation();
# if ($ENV{'SERVER_NAME'} eq "127.0.0.1" && $DEVSTATION_IP ne "127.0.0.1") {
# my $REQUEST_URI = $ENV{'REQUEST_URI'};
# return qq~<meta http-equiv="refresh" content="0; url=http://$DEVSTATION_IP$REQUEST_URI">\n~;
# } else {
# return "";
# }
# } else {
# return "";
# }
return "";
}
sub devprint {
#: Return content only if we're in devstation mode. This allows to print
#: debugging info on a web page on a development station, this info will
#: not be displayed on production systems for example.
#: Args(int): disable, replace return/linefeed by HTML br, bold
if (&devstation && !$_[2]) {
if ($ENV{'HTTP_USER_AGENT'}) {
my $DEV = $_[1];
if ($_[3]) {
$DEV =~ s~(\n|\r)~<br>~g;
}
if ($_[4]) {
return qq~<div class="bold">$DEV</div>~;
} else {
return qq~<div>$DEV</div>~;
}
} else {
return $_[1];
}
} else {
return "";
}
}
sub devstore {
#: Like store, but will only execute on a devstation, which may be useful
#: when debugging code.
if (&devstation) {
&store("",$_[1],$_[2]);
}
}
sub devdump {
#: Write to /__devdump.txt if we're on a devstation, so this can be used for
#: debugging purposes. The file will be overwritten each time, so this should
#: be used at the end of the script. Date and time will be automatically added
#: to the top of the content.
if (&devstation) {
my (
$sec,$min,$hour,
$mday,$mon,$year,
$wday,$yday,$isdst
) = ONO::Lib::DateTime::ToolBox->get;
if ($_[2]) {
&append("","__devdump.txt","$mday/$mon/$year \@ $hour:$min:$sec:\n\n$_[1]");
} else {
&store("","__devdump.txt","$mday/$mon/$year \@ $hour:$min:$sec:\n\n$_[1]");
}
return $_[1];
}
}
sub devguessuri {
#: If we're on a devstation, then guess the absolute URI, based on the name
#: of the input script. This can be use useful to debug links.
my $URI = $ENV{'REQUEST_URI'};
if (&devstation) {
$URI =~ s~^(.*)/local/perl/(.*?)/~~;
$URI =~ s~^index_~~;
$URI =~ s~\.pl(.*)$~~;
$URI = "/$URI/";
}
return $URI;
}
sub local {
#: Are we in a local network? Returns 1 = yes, 0 = no. This will only work
#: if the SERVER_NAME is an IP address, not a domain, unless the domain
#: will be of type example.local.
if ($is_local) {
return 1;
} else {
return 0;
}
}
sub dump {
#: Dump data to a file, without any processing.
#: Use this only if store() stoesn't work for some reason.
#: This may be used to store uploaded files containing special data for
#: example.
my ($self,$file,$data) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,">$vpath/$file");
print FILE $data;
close FILE;
}
sub dump_append {
#: Dump data to a file, without any processing.
#: Use this only if append() stoesn't work for some reason.
my ($self,$file,$data) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,">>$vpath/$file");
print FILE $data;
close FILE;
}
sub dump_load {
#: Load an entire file, return as string, don't process anything.
#: Use this only if load() stoesn't work for some reason.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE, "$vpath/$file");
my @DATAS = <FILE>;
close FILE;
my $DATA;
foreach my $data (@DATAS) {
$DATA .= $data;
}
return $DATA;
}
sub exists {
#: Check if file or path exists. Returns 1 if exists, or nothing if the
#: object doesn't exist.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
my $exists;
if (-e "$vpath/$file") {
$exists = 1;
}
return $exists;
}
sub exists_wait {
#: Wait until a file has been created, which is useful if complex file
#: generation tools are being used. Waiting for up to 3 secs is default,
#: higher values can be set manually.
my ($self,$file,$secs) = @_;
if (!$secs) {
$secs = 3;
}
my $whilecounter;
while ($whilecounter < $secs && !(&exists("",$file))) {
$whilecounter++;
sleep 1;
}
}
sub open {
#: This will simply open a file handle, as required by
#: ONO_Lib_Image_Check for example. Also see close().
my $file = &cleanup("",$_[1]);
my $vpath = &path;
open my $FH,"$vpath/$file";
return $FH;
}
sub close {
#: This will simply close a file handle. Also see open().
close $_[1];
}
sub load {
#: Load a file, return its content.
#:
#: Switches:
#:
#: -n remove new lines
#: -h HTML: replace \n by <br>
my (
$self,
$file,
$switches,
) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
my $dump;
foreach my $dat (@data) {
$dat =~ s~\r~~g;
if ($switches =~ /n/) {
$dat =~ s~\n~~g;
}
if ($switches =~ /h/) {
$dat =~ s~\n~<br>~g;
}
$dump .= $dat;
}
return $dump;
}
sub list {
#: List a file. Similar to load(), but returns lines as an array.
#:
#: Switches:
#:
#: -E don't return lines that don't contain numbers or letters
my (
$self,$file,$switches,
) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
my @new_data;
foreach my $dat (@data) {
if ($switches !~ /E/ || $dat =~ /[A-Za-z0-9]/) {
$dat =~ s~\r~~g;
@new_data = (@new_data,$dat);
}
}
return @new_data;
}
sub list_raw {
#: List_raw() is identical to list(), but allows to load files without
#: checking the file name, which means that it also loads files with
#: special characters.
my ($self,$file) = @_;
my $vpath = &path;
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
my @new_data;
foreach my $dat (@data) {
$dat =~ s~\r~~g;
@new_data = (@new_data,$dat);
}
return @new_data;
}
sub list_raw_fast {
#: List_raw_fast() is identical to list_raw(), but it's faster as it
#: doesn't clean up or check anything
my ($self,$file) = @_;
my $vpath = &path;
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
return @data;
}
sub list_line {
#: Like list(), but returns only one specific line from the file, which
#: must be indicated as a number.
my ($self,$file,$line) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
my ($return,$counter);
foreach my $dat (@data) {
$counter++;
if ($counter == $line) {
$dat =~ s~\r~~g;
$return = $dat;
}
}
return $return;
}
sub chomplist {
#: Similar to list(), but removes all carriage returns, lewlines and
#: tabs.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
my @new_data;
foreach my $dat (@data) {
$dat =~ s~(\r|\n|\t)~~g;
@new_data = (@new_data,$dat);
}
return @new_data;
}
sub quicklist {
#: Return file as content as an array, without doing anything else.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,"$vpath/$file");
my @data = <FILE>;
close FILE;
return @data;
}
sub save {
# Same as store(), and you should use store() instead.
my ($self,$file,@data) = @_;
&store($self,$file,@data);
}
sub create {
#: An intelligent version of "store" that will not overwrite
#: existing files, but add a number to the filename, if the
#: file already exists.
my ($self,$dir,$file,$ext,@data) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
$file = &cleanup("",$file);
$ext = &cleanup("",$ext);
if (!$file) {
$file = "untitled";
}
if (!$ext) {
$ext = "txt";
}
my $filename = $file;
my $whilecounter;
while ($whilecounter < 8192 && &exists("","$dir/$filename.$ext")) {
$whilecounter++;
$filename = "$file\_$whilecounter";
}
open (FILE,">$vpath/$dir/$filename.$ext");
foreach my $dat (@data) {
print FILE $dat;
}
close FILE;
return $filename;
}
sub store {
#: Store a file. If the file exists, it will be overwritten.
#: Data can be a string, or an array.
my ($self,$file,@data) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,">$vpath/$file");
foreach my $dat (@data) {
print FILE $dat;
}
close FILE;
}
sub store_rm {
#: Store a file if data is provided (just like store()), remove
#: the file if data is empty. Unlinke store(), data cannot be
#: an array, online strings are supported.
my ($self,$file,$data) = @_;
if ($data) {
&store("",$file,$data);
} else {
&rm("",$file);
}
}
sub append {
#: Append data to a file, data can be a string or an array.
my ($self,$file,@data) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
open (FILE,">>$vpath/$file");
foreach my $dat (@data) {
print FILE $dat;
}
close FILE;
}
sub copy {
#: Create a copy of of filename.ext, at the same location. The new
#: file will be named filename_copy.ext. If filename_copy.ext exists,
#: the name will become filename_copy_X.ext, where X is a number
#: starting at 1.
#:
#: If present, thumbnails will also be copied.
my ($self,$path) = @_;
my $vpath = &path;
$path = &cleanup("",$path);
my ($dir,$file,$ext) = &getdirfileext("",$path);
my $new = "${file}_copy.$ext";
my $whilecounter;
while (&exists("","$dir/$new") && $whilecounter < 1000) {
$whilecounter++;
$new = "${file}_copy_$whilecounter.$ext";
}
`cp "$vpath/$path" "$vpath/$dir/$new"`;
my ($pr1,$tn1) = &getthumbs("",$path);
if ($pr1 && $tn1 && (-e "$vpath/$pr1" || -e "$vpath/$tn1")) {
my ($pr2,$tn2) = &getthumbs("","$dir/$new");
`cp "$vpath/$pr1" "$vpath/$dir/$pr2"`;
`cp "$vpath/$tn1" "$vpath/$dir/$tn2"`;
}
return $new;
}
sub rm {
#: Remove (aka delete) a file, including its (optional)
#: thumbnails and setup files.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
if ($file =~ /[A-Za-z0-9]/) {
if (-e "$vpath/$file") {
`rm "$vpath/$file"`;
}
my ($pr1,$tn1) = &getthumbs("",$file);
if ($pr1 && $tn1 && (-e "$vpath/$pr1" || -e "$vpath/$tn1")) {
`rm "$vpath/$pr1"`;
`rm "$vpath/$tn1"`;
}
my $setup = &getsetup("",$file);
if ($setup && -e "$vpath/$setup") {
`rm "$vpath/$setup"`;
}
}
}
sub rmimage {
#: Like rm(), but a special version that will additionally remove the
#: file with multiple possible image extensions.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
foreach my $ext (&imageexts) {
&rm("","$file.$ext");
}
}
sub renumber {
#: Renumber files and/or directories in a directory, shtml/setup
#: files as well as pt/tn files will be ignored. Note that all thumbs
#: and previews will be removed during this process.
#:
#: -d renumber directories
#: -f renumber files
#: -u keep string after underscore
#: -U collect numbering if underscore (001_x and 001_y will be kept as is)
my (
$self,
$dir,
$start,
$step,
$switches,
) = @_;
# first we rename the files that shall be renumbered
foreach my $obj (sort &ls("",$dir)) {
if ($obj !~ /^\./ && $obj !~ /\.(setup|shtml)$/) {
if ($switches =~ /f/ && $obj =~ /\./) {
&mv("","$dir/$obj","$dir/onoio_renumber_$obj");
my ($pr,$tn) = &getthumbs("",$obj);
&rm("","$dir/$pr");
&rm("","$dir/$tn");
}
if ($switches =~ /d/ && $obj !~ /\./) {
&mv("","$dir/$obj","$dir/onoio_renumber_$obj");
}
}
}
# list files, and number them back...
my $number = $start;
my ($counter,$string_mode,$last_pre);
foreach my $obj (sort &ls("",$dir)) {
if ($obj =~ /^onoio_renumber_/ && $obj !~ /\.(setup|shtml)$/) {
my ($pre,$string);
if ($switches =~ /f/ && $switches =~ /u/ && $obj =~ /^onoio_renumber_(.*?)_(.*)\./) {
$pre = $1;
$string = "_$2";
}
if ($switches =~ /d/ && $switches =~ /u/ && $obj =~ /^onoio_renumber_(.*?)_(.*)$/) {
$pre = $1;
$string = "_$2";
}
my $override;
if ($switches =~ /U/ && $string && $pre eq $last_pre) {
$override = 1;
if (!$string_mode) {
$override = 0;
}
}
if ($counter && !$override) {
$number = $number + $step;
if (length $start > length $number) {
$number = ONO::Lib::Basic->add_leading_zeroes($number,length $start);
}
}
if ($string) {
$string_mode = 1;
} else {
$string_mode = 0;
}
$counter++;
$last_pre = $pre;
if ($obj =~ /\./) {
# file
my ($file,$ext) = &getfileext("",$obj);
&mv("","$dir/$obj","$dir/$number$string.$ext");
} else {
# dir
&mv("","$dir/$obj","$dir/$number$string");
}
}
}
}
sub dirfile {
#: Is this a directory (returns 'dir') or a file (returns 'file') ?
my $type = "dir";
if ($_[1] =~ /\./) {
$type = "file";
}
if ($_[2] eq "mediaserver") {
my $vpath = &path;
if (-d "$vpath/$_[1]") {
$type = "dir";
} else {
$type = "file";
}
if (&dirisfile("",$_[1])) {
$type = "file";
}
}
return $type;
}
sub dirisfile {
#: Extensions that will always be treated as files, even if they're dirs.
if ($_[1] =~ /\.(app|jar|pkg|mpkg|logicx|fcpbundle)$/) {
return 1;
} else {
return 0;
}
}
sub fileisdir {
#: Extensions used by files that are actually not files, but dirs
if ($_[1] =~ /\.(app|logicx|fcpbundle)$/) {
return 1;
} else {
return 0;
}
}
sub ls {
#: Same as dir().
my ($self,$dir,$filter,$ext,$sort,$opts,$excluded,$prefix) = @_;
&dir("",$dir,$filter,$ext,$sort,$opts,$excluded,$prefix);
}
sub lst {
#: List directory items by timestamp. This will simply dump the UNIX
#: ls output.
my ($self,$dir) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
my @objects = `ls -lt $vpath/$dir`;
return @objects;
}
sub dir {
#: List dirs and files.
#:
#: Switches:
#:
#: -B omit Base directory from list
#: -C cleanup (remove slashes at beginning)
#: -D only directories
#: -H no hidden files (starting by a dot)
#: -L list (option list for HTML forms)
#: -O option list -> shorten names if very long
#: -R recursive (does NOT work with sort mode! -- the -H switch is automatically enabled -- use -X to improve speed and to reduce CPU load)
#: -s sort (works with both list and string)
#: -S return list as a string (useful when using the -L option for example)
#: -W RAW mode allows special characters
#: -X use UNIX ls command to get recursive directories (only affects the -R switch)
#:
#: Note that the RX modes will ONLY list directories, NOT files!
my (
$self,$dir,$filter,$ext,$sort,$opts,$excluded,$prefix
) = @_;
my $vpath = &path;
if ($opts =~ /W/) {
$dir = &cleanup("",$dir);
$filter = &cleanup("",$filter);
}
my @objects;
if ($sort eq "size" || $sort eq "time") {
if ($sort eq "size") {
foreach my $item (`ls -S $vpath/$dir | tr '\n' '\n'`) {
$item =~ s~(\n|\r|\t)~~g;
@objects = (@objects,$item);
}
}
if ($sort eq "time") {
# this ONLY works for files, not for dirs (will be omitted)
# used by apps exercise temporary storage, make sure not to
# break this when making modifications !!!
foreach my $item (`ls -lt $vpath/$dir`) {
if ($item !~ /^\./ && $item =~ /\./) {
$item =~ s~(\n|\r|\t)~~g;
$item =~ s~^(.*) ~~;
@objects = (@objects,$item);
}
}
}
} else {
opendir(DIR, "$vpath/$dir");
if (!$sort) {
if ($opts =~ /R/) {
if ($opts =~ /X/) {
@objects = &_dir_recursive_ux("",$dir,$dir);
} else {
@objects = &_dir_recursive("",$dir,$dir);
}
} else {
@objects = readdir(DIR);
}
}
if ($sort eq "date") {
@objects = sort {-M $a <=> -M $b} map {"$vpath/$dir/$_"} readdir(DIR);
}
closedir DIR;
}
if (!$sort) {
@objects = sort @objects;
}
if ($sort eq "date") {
my $counter;
foreach my $object (@objects) {
$objects[$counter] =~ s~$vpath/$dir/~~;
$counter++;
}
}
my ($string,$excluded_recursive);
if ($excluded =~ s/\*$//) {
$excluded_recursive++;
}
if ($filter || $ext || $opts || $excluded) {
my @new;
foreach my $object (@objects) {
my $fext = $object;
$fext =~ s~^(.*)\.~~;
my $exclude;
if ($opts =~ /B/ && $object eq $dir) {
$exclude++;
}
if ($opts =~ /C/) {
$object =~ s~^/~~;
}
if (($opts =~ /H/ && $object =~ /^\./) || ($opts =~ /D/ && $object =~ /\./) || $object eq $excluded || "$object/" eq $excluded) {
$exclude++;
}
if ($excluded_recursive && "$object/" =~ /^$excluded/) {
$exclude++;
}
if ((!$filter || $object =~ /$filter/) && (!$ext || $object =~ /\.$ext$/ || ":$ext:" =~ /:$fext:/) && !$exclude) {
if ($opts =~ /L/) {
my $object2 = $object;
if ($opts =~ /O/ && length $object2 > 44) {
$object2 = substr($object,0,16)." (...) ".substr($object,(length $object)-24,24);
}
$object = qq~<option value="$prefix$object">$prefix$object2</option>~;
}
@new = (@new,$object);
$string .= $object;
}
}
@objects = @new;
}
if ($opts =~ /s/) {
@objects = sort @objects;
if ($opts =~ /S/) {
$string = "";
foreach my $object (@objects) {
$string .= $object;
}
}
}
if ($opts =~ /S/) {
return $string;
} else {
return @objects;
}
}
sub _dir_recursive {
#: Do NOT use this routine if possible, we recommend using the simple 'dir' with option -R instead
#: note that this routine ignores hidden files and folders, and it does not support directories with
#: dots in their names (which would be ONO-incompatible anyway).
my (
$self,$basedir,$dir
) = @_;
my $vpath = &path;
$basedir = &cleanup("",$basedir);
$dir = &cleanup("",$dir);
opendir(DIR, "$vpath/$dir");
my @objects = readdir(DIR);
closedir DIR;
my @new;
foreach my $object (@objects) {
# add the basic object
@new = (@new,$object);
# go into the object if it's a directory
if ($object !~ /\./ && -d "$vpath/$dir/$object") {
my $display_dir = $dir;
$display_dir =~ s~$basedir~~;
foreach my $sub (&_dir_recursive("",$basedir,"$dir/$object")) {
my $use_dir = "$display_dir/$object/$sub";
$use_dir =~ s~//~/~g;
@new = (@new,$use_dir);
}
}
}
return @new;
}
sub _dir_recursive_ux {
#: Do NOT use this routine if possible, we recommend using the simple 'dir' with option -RX instead
my (
$self,$basedir,$dir
) = @_;
my $vpath = &path;
$basedir = &cleanup("",$basedir);
$dir = &cleanup("",$dir);
my @new;
foreach my $sub (`ls -R $vpath/$dir`) {
if ($sub =~ m~/(.*?):~) {
$sub = "/$1";
$sub =~ s~$vpath/~~;
$sub =~ s~$basedir/~~;
@new = (@new,"$sub");
}
}
return @new;
}
sub dirprotect {
#: Protect a directory by putting an index.shtml into it.
#: This will still allow access to files within the directory, but listing it will be prohibited.
#: Also see htaccess() for additional protection.
if (!&exists("","$_[1]/index.shtml")) {
&store("","$_[1]/index.shtml",qq~<html><head><meta name="robots" content="noindex,nofollow"></head><body><h1>403 - Forbidden</h1></body></html>~);
&chmod("","$_[1]/index.shtml","777");
}
}
sub hashread {
#: Return file data as a hash.
#: This works for lists separated by semicolon.
my %hash;
foreach my $line (&list("",&cleanup("",$_[1]))) {
$line =~ s~(\n|\r|\t)~~g;
$line =~ m~^(.*?);(.*)$~;
my $key = $1;
my $value = $2;
$key =~ s/^\s+//;
$key =~ s/\s+$//;
$value =~ s/^\s+//;
$value =~ s/\s+$//;
$hash{$key} = $value;
}
return %hash;
}
sub hashwrite {
#: Write a hash to a file, using semicolon separation.
#: Input needs to be a hash reference in this case.
my $hash_ref = $_[1];
my %hash = %$hash_ref;
my $HASH;
# this has never been tested!!!
foreach my $key (keys %hash) {
$HASH .= qq~$key;$hash{$key}\n~;
}
&store("",&cleanup("",$_[1]),$HASH);
}
sub objtype {
#: Return the type of a object:
#:
#: 'none' if object doesn't exist
#: 'dir' if object is a directory
#: 'file' if object is a file
#:
#: Also see dirfile(), which does more or less the same thing
#: (only the 'none' option is missing), only better.
my $vpath = &path;
my $obj = &cleanup("",$_[1]);
my $ret = "none";
if (-e "$vpath/$obj" && -d "$vpath/$obj") {
$ret = "dir";
}
if (-e "$vpath/$obj" && -f "$vpath/$obj") {
$ret = "file";
}
return $ret;
}
sub dirsize {
#: Return the size of a directory (including all files and
#: directories contained in it).
#:
#: Switches:
#:
#: -M machine mode in megabytes (disable human readable)
my ($self,$dir,$switches) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($switches =~ /M/) {
my $size = `du -sm $vpath/$dir`;
$size =~ s~ (.*)$~~g;
$size =~ s~(\n|\r|\t)(.*)$~~g;
return $size;
} else {
my $size = `du -sh $vpath/$dir`;
$size = ONO::Lib::Basic->remove_bad_spaces($size);
$size =~ s~( |\t)(.*)$~~;
$size =~ s~K~ kb~;
$size =~ s~M~ mb~;
$size =~ s~(\n|\r|\t)~~gi;
if ($size < 1) {
$size = "";
}
return $size;
}
}
sub disks {
#: List hard drives, display disk usage (percentage).
my @disks;
foreach my $data (`df -k`) {
$data =~ s/\s+/\^/g;
if ($data =~ m~^/~ && $data !~ /\@/) {
@disks = (@disks,"$data\n");
}
}
return sort @disks;
}
sub ip {
#: Return the IP address of the host.
my $ip;
if (&os eq "linux") {
foreach my $data (`ifconfig`) {
if (!$ip && $data =~ /inet addr:(.*?) / && $data !~ /^127\.0\.0\.1/ && $data !~ /^192\.168\./) {
$ip = $1;
}
}
}
if (&os eq "macos") {
foreach my $data (`ifconfig`) {
if (!$ip && $data =~ /inet (.*?) netmask/ && $data !~ /^127\.0\.0\.1/ && $data !~ /^192\.168\./) {
$ip = $1;
}
}
}
return $ip;
}
sub os {
#: Return the OS of the host ('linux' or 'macos'). This is similar
#: to ONO::Core::HostOS->host_os(), although the output is different.
#:
#: -v first letter is uppercase
#: -V get more detailed information
my $switches = $_[1];
my $os = "linux";
if ($switches =~ /v/) {
$os = ucfirst $os;
}
if ($switches =~ /V/) {
my $MORE = `grep 'PRETTY_NAME' /etc/os-release | cut -d= -f2 | tr -d '"'`;
if ($MORE =~ /[A-Za-z0-9]/) {
$os .= " - $MORE";
}
}
if (&uname =~ /Darwin/i) {
$os = "macos";
if ($switches =~ /v/) {
$os .= " ".`sw_vers -productVersion`;
}
}
return $os;
}
sub uname {
#: Return the host's uname string, which offers some host system information.
return `uname -a`;
}
sub cpu {
#: Return CPU info. This should display the type of processor, as well as the
#: number of available cores (multithreading is being considered).
#:
#: -b make bold
my $switches = $_[1];
my $cpu = "unknown cpu";
if (&os eq "linux") {
foreach my $dat (`/bin/cat /proc/cpuinfo`) {
if ($dat =~ /model name(.*)/) {
$cpu = $1;
}
}
}
if (&os eq "macos") {
$cpu = `sysctl -n machdep.cpu.brand_string`;
}
if ($switches =~ /b/) {
$cpu = qq~<span class="bold">$cpu</span>~;
}
my $cores = ONO::Core::HostOS->cpu_cores;
if ($cores) {
$cpu .= " ($cores cores/threads)";
}
$cpu =~ s~\((r|tm)\)~~gi;
$cpu =~ s~:~~g;
$cpu =~ s~^ ~~g;
return $cpu;
}
sub mem {
#: Return the total amount of RAM available, in GB / GigaBytes.
my $mem = "memory unknown";
if (&os eq "linux") {
foreach my $dat (`/bin/cat /proc/meminfo`) {
if ($dat =~ /MemTotal(.*)/) {
$mem = $1;
$mem =~ s~[^0-9]~~g;
# this needs to be 1000 and 1024, don't know why...
$mem = 1+int($mem/1024/1024)." GB";
}
}
}
if (&os eq "macos") {
$mem = `sysctl hw.memsize`;
$mem =~ s~[^0-9]~~g;
$mem = 1+int($mem/1024/1024/1024)." GB";
}
return $mem;
}
sub sys {
#: Direct access to the UNIX system, via ONO::Core::Kernel's sys() function.
my ($self,$mode,$opts) = @_;
return ONO::Core::Kernel->sys($mode,$opts);
}
sub sysload {
#: Returns the current system load (percent of total available),
#: CPU cores and multithreading are taken into consideration.
#:
#: This can be used to run or disable code depending on the
#: system load of the host, sysload(50) is true if current load
#: is LOWER than 50 for examaple.
#:
#: This uses cached system load info, which will be updated
#: about every 5 seconds.
#:
#: Note that the threshold feature is NOT working on development
#: stations, which makes developing under high load conditions
#: a lot easier (devstations always return 1).
# Lots of parantheses to make sure the compiler won't throw error messages...:
my $percent = int(100/((ONO::Core::HostOS->cpu_cores())*100)*(ONO::Core::HostOS->cpu_load_cached()));
if ($_[1]) {
# devstation will always return 1, which makes testing easier
if ($percent < $_[1] || &devstation) {
return 1;
} else {
return 0;
}
} else {
return $percent;
}
}
sub sysloadmsg {
#: Returns a system overload message. Note that this function only
#: dumps some text, it does not do or detect anything. It may be a
#: good idea to use this in combination with sysload().
my $MSG;
if ($_[1] eq "de") {
$MSG = $SYSLOADMSG[1];
}
if ($_[1] eq "fr") {
$MSG = $SYSLOADMSG[2];
}
if ($_[1] eq "lu") {
$MSG = $SYSLOADMSG[3];
}
if (!$MSG) {
$MSG = $SYSLOADMSG[0];
}
return qq~<div class="lh125">$MSG</div>~;
}
sub is_local_ip {
#: Is the provided IP a local IP ? Returns 1 of local, or 0 if not
#: local. Also see local().
#:
#: Not to be confused with local(), which tells you if the host's
#: IP is local.
my $res = 0;
if ($_[1] =~ /^(0|10|127)\.0/) {
$res++;
}
if ($_[1] =~ /^172\.16/) {
$res++;
}
if ($_[1] =~ /^192\.168\./) {
$res++;
}
if ($_[1] =~ /^255\.255\.255\.255$/) {
$res++;
}
return $res;
}
sub count {
#: Count objects (directories and files) inside a directory.
#: Note that this does NOT work recursively, only the first
#: level of the directory is being taken into consideration.
#:
#: Switches:
#:
#: -d only directories
#: -f only files
#: -i only images
#: -S omit .setup
#: -t only txt files
#: -T omit .thumbs and previews
my (
$self,
$dir,
$init,
$switches,
) = @_;
foreach my $file (&dir("",$dir)) {
if ($file =~ /[A-Za-z0-9]/ && $file !~ /^\./) {
$init++;
if (
($switches =~ /f/ && $file !~ /\./) ||
($switches =~ /i/ && $file !~ /\.(jpg|jpeg|gif|png|heic|webp|tiff|psd|ico|crimg)$/i) ||
($switches =~ /d/ && $file =~ /\./) ||
($switches =~ /S/ && $file =~ /\.setup$/) ||
($switches =~ /t/ && $file !~ /\.txt$/i) ||
($switches =~ /T/ && $file =~ /^\.(tn|pr)_/)
) {
$init--;
}
}
}
if (!$init) {
$init = 0;
}
return $init;
}
sub compare {
#: Compare files.
#:
#: Returns NULL if files are identical
#: Returns difference details if NOT identical
#:
#: $max: if file bigger than $max then only check file size (no diff)
#:
#: $fast: avoid using diff if possible, does not always return differences though
my ($self,$file1,$file2,$max,$fast) = @_;
my $vpath = &path;
$file1 = &cleanup("",$file1);
$file2 = &cleanup("",$file2);
if ($max && &size("",$file1) > $max) {
if (&size("",$file1) == &size("",$file2)) {
return 0;
} else {
return 1;
}
} else {
if ($fast) {
if (&size("",$file1) == &size("",$file2)) {
return `diff '$vpath/$file1' '$vpath/$file2'`;
} else {
return 1;
}
} else {
return `diff '$vpath/$file1' '$vpath/$file2'`;
}
}
}
sub mkpath {
#: Like mkdir(), but generates the entire path, including all of its subdirs.
#: Permissions may be set at the same time.
my ($self,$dir,$mode) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
$mode =~ s~[^0-7]~~g;
if ($dir) {
unless (-e "$vpath/$dir") {
my $path;
my @parts = split(/\//,$dir);
foreach my $part (@parts) {
$path .= "/$part";
unless (-e "$vpath$path") {
`mkdir $vpath$path`;
}
if (length $mode == 3) {
`chmod $mode $vpath$path`;
}
}
}
}
}
sub mkdir {
#: Create a new directory.
#: Permissions may be set at the same time.
#: Also see mkpath() for a more powerful alternative.
my ($self,$dir,$mode) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($dir) {
unless (-e "$vpath/$dir") {
`mkdir $vpath/$dir`;
}
}
$mode =~ s~[^0-7]~~g;
if (length $mode == 3) {
`chmod $mode $vpath/$dir`;
}
}
sub mkdir_new {
#: This will create a new subdir, add a number if such a subdir already exists,
#: and return the created name. The new subdir will always have permissions
#: set to 777.
my ($self,$dir,$new) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
$new = &cleanup("",$new);
my $name = $new;
my $whilecounter;
while ($whilecounter < 4096 && &exists("","$dir/$name")) {
$whilecounter++;
$name = "${new}_$whilecounter";
}
&mkdir("","$dir/$name","777");
return $name;
}
sub rmdir {
#: Remove directory, including all of its contents.
#: Recursive and with force delete enabled,
#: use rmdirsoft() for a less dangerous operation.
my ($self,$dir) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($vpath =~ /[A-Za-z0-9]/ && $dir =~ /[A-Za-z0-9]/ && $dir !~ /\.\./ && $dir !~ /(\*|\(|\)|\[|\])/ && &exists("",$dir)) {
`rm -rf $vpath/$dir`;
return "rm -rf $vpath/$dir";
} else {
return "ABORT";
}
}
sub rmdirsoft {
#: Like rmdir(), but without force.
my ($self,$dir) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($vpath =~ /[A-Za-z0-9]/ && $dir =~ /[A-Za-z0-9]/ && $dir !~ /\.\./ && $dir !~ /(\*|\(|\)|\[|\])/ && &exists("",$dir)) {
`rmdir $vpath/$dir`;
return "rmdir $vpath/$dir";
} else {
return "ABORT";
}
}
sub htaccess {
#: Password management and protection only.
#: See dirprotect to prevent directory listing.
#:
#: You need to specify $key, if this is empty then the protection
#: will be removed. To protect without any login option, simply
#: use ':' as $key.
my ($self,$dir,$key) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($key =~ /:/) {
&store("","$dir/.htaccess",qq~AuthName "Password Required"
AuthType Basic
AuthUserFile $vpath/$dir
require valid-user
~);
&store("","$dir/.htpasswd","$key\n");
&chmod("","$dir/.htaccess","777");
&chmod("","$dir/.htpasswd","777");
} else {
`rm -rf $vpath/$dir/.htaccess`;
`rm -rf $vpath/$dir/.htpasswd`;
}
}
sub htaccess_ip {
#: Restrict access to a directory only for one IP address.
my ($self,$dir,$ip) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
if ($ip) {
&store("","$dir/.htaccess","order deny,allow\ndeny from all\nallow from $ip\n");
&chmod("","$dir/.htaccess","777");
} else {
`rm -rf $vpath/$dir/.htaccess`;
}
}
sub htaccess_rewrite {
#: Add a rewrite rule via .htaccess, simply indicate the target,
#: which must be a path to a script.
my ($self,$dir,$com) = @_;
my $vpath = &path;
$dir = &cleanup("",$dir);
&store("","$dir/.htaccess","RewriteEngine on\nRewriteRule \^\(\.\*\)\$ $com \[L\]\n");
&chmod("","$dir/.htaccess","777");
}
sub htmlencode {
#: Encode a string by replacing HTML lt, gt and quot.
#: This will be useful in input fields for example.
my $input = $_[1];
$input =~ s~\<~<~g;
$input =~ s~\>~>~g;
$input =~ s~\"~"~g;
return $input;
}
sub size {
#: Return the size of a file, by default this will simply return the
#: number of bytes.
#:
#: Switches:
#:
#: -d recursive directory mode
#: -h human readable (add "bytes", "kb", or "mb")
#: -k kb
#: -l count lines
#: -w count words
my ($self,$file,$switches) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
my $size;
if ($file) {
if (!$switches || $switches =~ /(h|k)/) {
if ($switches =~ /d/ || &fileisdir("",$file)) {
# recursive dir size
$size = `du -sk "$vpath/$file"`;
$size =~ s~( |\n|\r|\t)(.*)$~~;
$size = $size * 1024;
} else {
# file size
$size = -s "$vpath/$file";
}
if ($switches =~ /h/) {
my $ext = "bytes";
if ($size > 4000000000) {
$size = 1+int($size/1024/1024/1024);
$ext = "GB";
} else {
if ($size > 4000000) {
$size = 1+int($size/1024/1024);
$ext = "MB";
} else {
if ($size > 8000) {
$size = 1+int($size/1024);
$ext = "KB";
}
}
}
$size .= " $ext";
}
if ($switches =~ /k/) {
$size = 1+int($size/1024);
}
}
if ($switches =~ /l/) {
$size = `wc -l '$vpath/$file'`;
$size =~ s~^\s+~~;
$size =~ s~ (.*)$~~;
$size =~ s~( |\n|\r|\t)~~g;
if (-s "$vpath/$file") {
$size++;
}
}
if ($switches =~ /w/) {
$size = `wc '$vpath/$file'`;
$size =~ s~(\n|\r|\t)~ ~g;
$size =~ s~\s+~ ~g;
$size =~ s~^\s+~~;
$size =~ m~^(.*?) (.*?) (.*?)~;
$size = $2;
}
}
return $size;
}
sub timestamp {
#: Return the modification (or creation) timestamp of a file or directory.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
my (
$dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
) = stat("$vpath/$file");
return $mtime;
}
sub touch {
#: Update the modification timestamp of a file or directory.
my ($self,$file,$time) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
$time =~ s~[^0-9]~~g;
if ($time =~ /[0-9]/) {
`touch -mt $time $vpath/$file`;
} else {
`touch $vpath/$file`;
}
}
sub type {
#: This is a file or a directory? Returns 'dir' or 'file'.
#: Please use dirfile() instead, or objtype(), which do
#: the same thing.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
my $type = "dir";
if (-f "$vpath/$file") {
$type = "file";
}
return $type;
}
sub stat {
#: Returns file or directory stats as an array.
my ($self,$file) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
my (
$dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks
) = stat("$vpath/$file");
return ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks);
}
sub symlink {
#: Create a symlink.
my ($self,$file,$symlink) = @_;
my $vpath = &path;
$file = &cleanup("",$file);
$symlink = &cleanup("",$symlink);
if ($file && $symlink) {
`ln -s $vpath/$file $vpath/$symlink`;
}
}
sub unlink {
#: Remove a symlink.
my ($self,$symlink) = @_;
my $vpath = &path;
$symlink = &cleanup("",$symlink);
if ($symlink) {
`unlink $vpath/$symlink`;
}
}
sub cp {
#: Copy a file to a new target.
#: Related thumbnails and setup files will also be
#: taken into consideration.
my ($self,$source,$target) = @_;
my $vpath = &path;
$source = &cleanup("",$source);
$target = &cleanup("",$target);
if ($source && $target) {
`cp $vpath/$source $vpath/$target`;
my ($pr1,$tn1) = &getthumbs("",$source);
if ($pr1 && $tn1) {
my ($pr2,$tn2) = &getthumbs("",$target);
`cp $vpath/$pr1 $vpath/$pr2`;
`cp $vpath/$tn1 $vpath/$tn2`;
}
my $setup1 = &getsetup("",$source);
if ($setup1) {
my $setup2 = &getsetup("",$target,"x");
`cp $vpath/$setup1 $vpath/$setup2`;
}
}
}
sub cpr {
#: Recursively copy a directory.
#:
#: Switches:
#:
#: -p preserve file properties
#: -n do not overwrite an existing file
my ($self,$source,$target,$switches) = @_;
my $vpath = &path;
$source = &cleanup("",$source);
$target = &cleanup("",$target);
my $flags;
if ($switches =~ /p/) {
$flags .= "p";
}
if ($switches =~ /n/) {
$flags .= "n";
}
if ($source && $target) {
`cp -r$flags $vpath/$source $vpath/$target`;
}
}
sub mv {
#: Move or rename a file or a directory.
#: Related thumbnails and setup files will also be
#: taken into consideration.
my ($self,$source,$target) = @_;
my $vpath = &path;
$source = &cleanup("",$source,1);
$target = &cleanup("",$target);
if ($source && $target) {
`mv '$vpath/$source' '$vpath/$target'`;
my ($pr1,$tn1) = &getthumbs("",$source);
if ($pr1 && $tn1) {
my ($pr2,$tn2) = &getthumbs("",$target);
`mv '$vpath/$pr1' '$vpath/$pr2'`;
`mv '$vpath/$tn1' '$vpath/$tn2'`;
}
my $setup1 = &getsetup("",$source);
if ($setup1) {
my $setup2 = &getsetup("",$target,"x");
`mv '$vpath/$setup1' '$vpath/$setup2'`;
}
}
}
sub mvdirty {
#: Like mv(), but for "dirty" sources containing
#: bad characters.
#: Related thumbnails and setup files will also be
#: taken into consideration.
my ($self,$source,$target) = @_;
my $vpath = &path;
$source =~ s~\&~\\\&~g;
$source =~ s~\(~\\\)~g;
$source =~ s~\)~\\\)~g;
$source =~ s~\'~\\\'~g;
$source =~ s~\"~\\\"~g;
if ($source && $target) {
`mv '$vpath/$source' '$vpath/$target'`;
my ($pr1,$tn1) = &getthumbs("",$source);
if ($pr1 && $tn1) {
my ($pr2,$tn2) = &getthumbs("",$target);
`mv $vpath/$pr1 $vpath/$pr2`;
`mv $vpath/$tn1 $vpath/$tn2`;
}
my $setup1 = &getsetup("",$source);
if ($setup1) {
my $setup2 = &getsetup("",$target,"x");
`mv $vpath/$setup1 $vpath/$setup2`;
}
}
return "mv '$vpath/$source' '$vpath/$target'";
}
sub split {
#: Split a file into pieces.
my ($self,$source,$target,$size) = @_;
my $vpath = &path;
$source = &cleanup("",$source);
$target = &cleanup("",$target);
if ($source && $target) {
if (!$size) {
$size = 65536;
}
`split -b $size $vpath/$source $vpath/$target`;
}
}
sub chmod {
#: Change file or directory permissions.
my ($self,$object,$mode) = @_;
my $vpath = &path;
$object = &cleanup("",$object);
$mode =~ s~[^0-7\-\r\R\ ]~~gi;
if ($object && length $mode > 2) {
`chmod $mode $vpath/$object`;
}
return "chmod $mode $vpath/$object";
}
sub exec {
#: Execure a UNIX command, via ONO::Core::Kernel's exec() function.
my ($self,$exec) = @_;
return ONO::Core::Kernel->exec($exec);
}
sub exec2 {
#: Execure a UNIX command.
#: This is a less restrictive version of exec() (allows (\',\",\@,\:,\[,\])).
my ($self,$exec) = @_;
$exec =~ s~[^A-Za-z0-9\ \-\_\.\/\'\"\@\:\[\]]~~g;
return `$exec`;
}
sub exec3 {
#: Execure a UNIX command.
#: This is a zero restrictions version of exec (allows everything)
#: THIS MAY BE DANGEROUS TO USE - especially if you're using it in a script that's running with root privileges.
my ($self,$exec) = @_;
return `$exec`;
}
sub domain {
#: Return the domain, remove stuff like 'www' and other subdomains.
my $domain = &domain_full();
$domain =~ s~^(www|en|us|uk|de|at|ch|fr|be|lu|lb|nl|es|pt|it|dk|da|fi|no|sv|se)\.~~;
return $domain;
}
sub domain_full {
#: Return the domain, including 'www' or subdomains for example.
#: The domain can also be set via a configuration file (etc/domain.conf),
#: which may be required in some proxy environments.
my $domain = $ENV{'HTTP_HOST'};
if (!$domain) {
$domain = $ENV{'SERVER_NAME'};
}
if (!$domain && &exists("","etc/domain.conf")) {
$domain = &load("","etc/domain.conf");
$domain =~ s~(\n|\r|\t)~~g;
}
return $domain;
}
sub http {
#: Returns 'http' or 'https', depending on the current SSL status of the domain.
my $HTTP = "http";
if ($ENV{'HTTPS'} || &exists("","etc/https.conf")) {
$HTTP = "https";
}
return $HTTP;
}
sub https {
#: Returns 1 if SSL is available, or 0 is SSL is not available.
#: Returning 1 can be forced, by adding a dedicated setup file
#: (etc/https.conf), which may be required in certain proxy
#: environments.
if ($ENV{'HTTPS'} || &exists("","etc/https.conf")) {
return 1;
} else {
return 0;
}
}
sub http_domain_base {
#: Returns http(s)://www.example.com/ono/path/. This basically
#: glues the http(), domain() and base() functions.
return &http()."://".&domain().&base();
}
sub refresh {
#: HTML refresh, this will simply auto-redirect to a different page.
#: In most cases, you will simply push refresh($url) to the client.
#:
#: You may specify seconds to wait, and you may also force using
#: SSL/https for the destination.
#:
#: For testing purposes, the 'auto' feature is disabled on
#: development stations, which will display a clickable link
#: displaying the entire URL instead. Using $devstation_overrule
#: will override this behaviour and enable the 'auto' features
#: on development stations too.
my (
$self,
$URL,
$SECS,
$HTTP_FORCE,
$devstation_overrule,
) = @_;
$URL =~ s~^http(|s)\://~~;
if ($SECS < 1) {
$SECS = 0;
}
my $HTTP = &http;
if ($HTTP_FORCE) {
$HTTP = $HTTP_FORCE;
}
$URL = ONO::Lib::Basic->remove_doubles($URL,"/");
if ($URL !~ /^\//) {
$URL = "${HTTP}://$URL";
}
if (&devstation && !$devstation_overrule) {
my $SHOW_URL = ONO::Lib::Basic->pathbreaks($URL);
my $chars = length $URL;
return qq~Devstation: refresh after $SECS secs, $chars chars: <a href="$URL">$SHOW_URL</a>~;
} else {
return qq~<meta http-equiv="refresh" content="$SECS; url=$URL">~;
}
}
sub upload_url {
#: Returns the rawdata.pl upload script URL.
my $RND = 9000000000 + int(rand(999999999));
my $URL = "/cgi-bin/local/perl/$_[1]/ajax/rawdata.pl?";
# $URL .= "?ono_ref_id=$RND&";
return $URL;
}
sub upload {
#: CGI upload, which allows single file upload directly via ONO::IO.
#: In most cases, you will avoid this and use ONO::ToolBox::Upload
#: and ONO::Lib::Web::Upload instead.
#:
#: $max = file size limit (absolute limit = 4 MB)
#:
#: -g only accept GIF
#: -i only accept images (JPG, PNG, GIF, WEBP)
#: -j only accept JPG
#: -p only accept PNG
#: -P only accept PDF
#: -w only accept WebP
my ($self,$handle,$dir,$file,$max,$switches) = @_;
my $vpath = &path;
$handle = &cleanup("",$handle);
$dir = &cleanup("",$dir);
$file = &cleanup("",$file);
my $cgi = new CGI;
if (!$file) {
$file = lc $cgi->param($handle);
}
my ($data,$data1);
if (my $fh = $cgi->upload($handle)) {
$data1 .= $data while read $fh, $data, 1024;
}
my $valid_file = 1;
my $ext;
my $magic = lc unpack('H8',substr($data1,0,1)).unpack('H8',substr($data1,1,1)).unpack('H8',substr($data1,2,1));
if ($switches =~ /(g|i|j|p)/) {
$valid_file = 0;
if ($switches =~ /(i|j)/ && ($data1 =~ m/JFIF/ || $magic eq "ffd8ff")) {
$valid_file = 1;
$ext = "jpg";
}
if ($switches =~ /(i|g)/ && ($data1 =~ m/GIF87a/ || $data1 =~ m/GIF89a/ || $magic eq "474946")) {
$valid_file = 1;
$ext = "gif";
}
if ($switches =~ /(i|p)/ && ($data1 =~ m/PNG/ || $magic eq "89504e")) {
$valid_file = 1;
$ext = "png";
}
if ($switches =~ /(i|w)/ && ($data1 =~ m/^RIFF/)) {
$valid_file = 1;
$ext = "webp";
}
}
if ($switches =~ /P/) {
$valid_file = 0;
if ($data1 =~ m/PDF/ || $magic eq "255044") {
$valid_file = 1;
$ext = "pdf";
}
}
if ($ext) {
# don't do this for files starting by a dot (required for /.icon.jpg)
if ($file !~ /^\./) {
$file =~ s~\.(.*)$~~;
}
$file .= ".$ext";
}
if ($data1 && $valid_file && (!$max || $max*1024 > length $data1) && length $data1 < 4096*1024) {
&mkpath("",$dir);
&dump("","$dir/$file",$data1);
return "$dir/$file";
} else {
return "";
}
}
sub which {
#: Find a UNIX binary. Accepts the binary name as input,
#: returns the path to the binary.
my ($self,$source) = @_;
$source = &cleanup("",$source);
my $res = `which $source`;
$res =~ s~[^A-Za-z0-9\/\-]~~gi;
return $res;
}
sub unzip {
#: Unzip a file or directory.
my ($self,$source,$target) = @_;
my $vpath = &path;
$source = &cleanup("",$source);
$target = &cleanup("",$target);
`unzip $vpath/$source -d $vpath/$target`;
return "unzip unzip $vpath/$source -d $vpath/$target";
}
sub tar {
# Archive a file or directory.
my ($self,$source,$target) = @_;
my $vpath = &path;
$source = &cleanup("",$source);
$target = &cleanup("",$target);
`tar -zcf $vpath/$target $vpath/$source`;
return "tar -zcf $vpath/$target $vpath/$source";
}
sub deepdir {
#: Turns 'ABCXYZ' into 'A/AB/ABC'.
my $sep = $_[2];
if (!$sep) {
$sep = "/";
}
return substr($_[1],0,1).$sep.substr($_[1],0,2).$sep.substr($_[1],0,3);
}
sub deepdirs {
#: Turns 'ABCXYZ' into ('A','AB','ABC').
return (substr($_[1],0,1),substr($_[1],0,2),substr($_[1],0,3));
}
sub deepnum {
# Like deepdir(), but this one is working with numbers, the input
# number will automatically be expanded to 10 digits.
my $id = ONO::Lib::Basic->add_leading_zeroes($_[1],9);
my $sep = $_[2];
if (!$sep) {
$sep = "/";
}
return substr($id,0,3).$sep.substr($id,3,3).$sep.substr($id,6,3);
}
sub zip {
#: Compress a file.
#: Warning: gzip only works with single files, use 'tar' to zip entire directories
my ($self,$file) = @_;
my $vpath = &path;
`gzip $vpath/$file`;
}
sub readsetup {
#: Read a setup file.
#: -H no HTML parsing (preserve <br>)
my (
$self,
$object,
$flags,
) = @_;
my $vpath = &path;
$object = &cleanup("",$object);
my $setup = &getsetup("",$object);
my %hash;
$hash{'debug'} = "FILE: $object -> $setup<br>";
if ($setup) {
foreach my $data (&list("",$setup)) {
my @dp = split(/\^/,$data);
if ($flags !~ /H/) {
$dp[1] =~ s~\<br\>~\n~g;
}
$hash{$dp[0]} = $dp[1];
}
}
return \%hash;
}
sub savesetup {
#: Save / store a setup file.
#: -m multi-line mode for meta data, replaces newline/return by HTML <br>
my (
$self,
$object,
$vars_ref,
$switches,
) = @_;
my $vpath = &path;
$object = &cleanup("",$object);
my %vars = %$vars_ref;
my $setup = &getsetup("",$object,"x");
my $DEBUG = "FILE: $object -> $setup<br>";
my $DATA;
# this does not yet check security (_locks), therefore this can't be universally used
foreach my $meta ('title','subtitle','date','sort','description','instructions','branch','rename_lock','delete_lock','system_lock') {
if ($vars{"setup_$meta"}) {
$vars{"setup_$meta"} =~ s~(\n|\r|\t)~\<br\>~g;
$DATA .= qq~$meta\^$vars{"setup_$meta"}\^\n~;
}
}
# custom data, may be used by any application:
foreach my $key (keys %vars) {
if ($key =~ /^setup_custom_(.*?)$/) {
my $meta = $1;
if ($vars{$key} =~ /[A-Za-z0-9\-]/) {
if ($switches =~ /m/) {
$vars{$key} =~ s~(\n|\r)~<br>~g;
$vars{$key} =~ s~(\t)~~g;
} else {
$vars{$key} =~ s~(\n|\r|\t)~~g;
}
$DATA .= qq~custom_$meta\^$vars{$key}\^\n~;
}
}
}
if ($DATA) {
&store("",$setup,$DATA);
} else {
&rm("",$setup);
}
return $DEBUG;
}
sub getdir {
#: Transform /my/path/to/file.ext into /my/path/to/.
#:
#: Only works correctly if the input is using a correct
#: /my/path/to/file.ext format.
my ($self,$path) = @_;
my $file = $path;
$file =~ s~^(.*)/~~;
return $1;
}
sub getdirfile {
#: Transform /my/path/to/file.ext into ('/my/path/to/','file.ext').
#:
#: Only works correctly if the input is using a correct
#: /my/path/to/file.ext format.
my ($self,$path) = @_;
my $file = $path;
$file =~ s~^(.*)/~~;
my $dir = $1;
return ($dir,$file);
}
sub getdirfileext {
# Transform /my/path/to/file.txt into ('/my/path/to/','file','ext').
#
# Only works correctly if the input is using a correct
# /my/path/to/file.ext format.
my ($self,$path) = @_;
$path =~ s~^(.*)/~~;
my $dir = $1;
$path =~ m~^(.*)\.(.*?)$~;
return ($dir,$1,$2);
}
sub getfileext {
#: Return the file and its extension, eg file.ext becomes ('file','ext').
my $file = $_[1];
$file =~ m~^(.*)\.(.*?)$~;
return ($1,$2);
}
sub getfiletype {
#: Return file type: image, audio, video or pdf.
#: Will be empty if it's none of those.
my $filetype;
if ($_[1] =~ m~\.(jpg|jpeg|png|webp|gif|tiff|psd|ico|crimg)$~i) {
$filetype = "image";
}
if ($_[1] =~ m~\.(mp3|wav|flac|ogg)$~i) {
$filetype = "audio";
}
if ($_[1] =~ m~\.(mp4|m4v|mpg|mpeg|m2ts|mov|mkv|f4v|avi|vob|wmv|flv|f4v|m4v|divx|webm|mp4c|ts)$~i) {
$filetype = "video";
}
if ($_[1] =~ m~\.(pdf)$~i) {
$filetype = "pdf";
}
return $filetype;
}
sub getthumbs {
#: Returns paths to preview and thumbnail files.
#: Returns nothing if the file type does not allow for thumbnail files.
my ($self,$path) = @_;
if ($path =~ m~\.(jpg|png|gif|webp|heic|tiff|mp4|m4v|mpg|mpeg|mov|mkv|avi|vob|wmv|flv|f4v|divx|webm|mp4c|ts|pdf)$~i) {
my $file = $path;
$file =~ s~^(.*)/~~;
my $dir = $path;
$dir =~ s~/$file~~;
$file =~ s~\.(png|gif|webp|heic|tiff|mp4|m4v|mpg|mpeg|mov|mkv|avi|vob|wmv|flv|f4v|divx|webm|mp4c|ts|pdf)$~\.jpg~i;
# $file =~ s~\.JPG$~\.jpg~;
return ("$dir/.pr_$file","$dir/.tn_$file");
} else {
return ("","");
}
}
sub getthumbs_ifexists {
#: Returns paths to preview and thumbnail files, but onyl if they exist, and if the file type supports them.
my ($self,$path) = @_;
my ($pr,$tn) = &getthumbs("",$path);
if (&exists("",$pr) && &exists("",$tn)) {
return ($pr,$tn);
} else {
return ("","");
}
}
sub rmthumbs {
#: Remove thumbs and previews from a file, leave the file intact.
my ($self,$path) = @_;
my $vpath = &path;
my $del;
my ($pr1,$tn1) = &getthumbs("",$path);
if ($pr1 && -e "$vpath/$pr1") {
`rm "$vpath/$pr1"`;
$del .= ":$pr1";
}
if ($tn1 && -e "$vpath/$tn1") {
`rm "$vpath/$tn1"`;
$del .= ":$tn1";
}
if ($del) {
return "$path$del;";
} else {
return "";
}
}
sub getsetup {
#: Returns the path to an optional setup file.
#:
#: Switches:
#:
#: -x override exists check (required for creating a new file)
my ($self,$path,$flags) = @_;
if ($path =~ /\./) {
$path =~ s~\.(.*?)$~\.setup~;
} else {
$path .= ".setup";
}
if (&exists("",$path) || $flags =~ /x/) {
return $path;
} else {
return "";
}
}
sub getimage {
#: Replace an image URL into a preview or thumbnail URL if the
#: required files exist, and if the image dimensions are adequate.
my ($self,$img,$w,$h) = @_;
my $vpath = &path;
if ($w < 241 && $h < 181) {
my ($pr,$tn) = &getthumbs("",$img);
if ($pr && -e "$vpath/$pr") {
$img = $pr;
}
if ($tn && -e "$vpath/$tn" && $w < 121 && $h < 121) {
$img = $tn;
}
}
return $img;
}
sub image {
#: Returns 1 if file extension is image, or 0 if not.
#: This works for both filenames, and directory/filename
#: combinations.
if ($_[1] =~ /\.(jpg|jpeg|gif|png|heic|webp|tiff|psd|ico|crimg)$/i) {
return 1;
} else {
return 0;
}
}
sub imagefile {
#: Same as image(), but does not work for preview and thumbnail files.
if (&image("",$_[1]) && $_[1] !~ /^\./) {
return 1;
} else {
return 0;
}
}
sub imageexts {
#: Return a list of common (not all) image extensions.
return ('jpg','jpeg','png','gif','webp');
}
sub pixel {
#: Returns a pixel image as a data stream.
return $PIXEL;
}
sub video {
#: Returns 1 if file extension is video, or 0 if not.
#: This works for both filenames, and directory/filename
#: combinations.
if ($_[1] =~ /\.(mp4|m4v|mpg|mpeg|m2ts|mov|mkv|f4v|avi|vob|wmv|flv|f4v|m4v|divx|webm|mp4c|ts)$/i) {
return 1;
} else {
return 0;
}
}
sub inputfilter {
#: Filter and return input, by removing a number of special characters
my $input = $_[1];
$input =~ s~(\"|\<|\>|\(|\)|\*|\!|\\)~~gi;
return $input;
}
sub inputfilters {
#: Like inputfilter(), but for arrays.
my (
$self,
@inputs,
) = @_;
my @new;
foreach my $input (@inputs) {
@new = (@new,&inputfilter("",$input));
}
return @new;
}
sub xmlget {
#: Get / extract XML data. This only works for very simple XML files,
#: and it will only return the first instance of the data.
my $XML = &load("",$_[1]);
$XML =~ s~(\n|\r|\t)~~g;
$XML =~ s~\<$_[2]\>(.*?)\</$_[2]\>~~i;
return $1;
}
###############################################################################
# end of script
###############################################################################
1;
__END__