File Coverage

blib/lib/WWW/HyperGlossary/Base.pm

Criterion	Covered	Total	%
statement	27	152	17.7
branch	0	46	0.0
condition	0	9	0.0
subroutine	9	31	29.0
pod	0	7	0.0
total	36	245	14.6

package WWW::HyperGlossary::Base;
use Class::Std;
use Class::Std::Utils;
use DBI;
use DBIx::MySperql qw(DBConnect SQLExec $dbh);
use Digest::MD5 qw (md5_hex);

use warnings;
use strict;
use Carp;

use version; our $VERSION = qv('0.0.2');

{
	my %data_of        : ATTR( );

	sub BUILD {
		my ($self, $ident, $arg_ref) = @_;

#		my $data = IOSea::Hyperglossary::Words->new();
#		$data_of{$ident} = $data->get_data();

		return;
	}

	sub get_languages  {
	    my ( $self ) = @_;
	    my $sql = "select language_id, language from hg_languages order by language asc";
	    return SQLExec( $sql, '\@@' );
	}

	sub get_definition_types  {
	    my ( $self ) = @_;
	    my $sql = "select definition_type_id, definition_type from hg_definition_types order by definition_type asc";
	    return SQLExec( $sql, '\@@' );
	}

	sub get_categories  {
	    my ( $self ) = @_;
	    my $sql = "select category_id, category from hg_categories order by category asc";
	    return SQLExec( $sql, '\@@' );
	}

	sub get_category_words  {
	    my ( $self, $category_id ) = @_;
	    my $sql = "select hg_category_words.category_word_id, hg_words.word from hg_category_words, hg_words where hg_category_words.category_id = $category_id and hg_category_words.word_id = hg_words.word_id";
	    return SQLExec( $sql, '\@@' );
	}

	sub get_set_words  {
	    my ( $self, $category_id, $set_id ) = @_;
	    my $sql = "select hg_category_words.category_word_id, hg_words.word from hg_category_words, hg_words where hg_category_words.category_id = $category_id and hg_category_words.word_id = hg_words.word_id and hg_category_words.set_id = '$set_id' order by length(hg_words.word) desc";
	    return SQLExec( $sql, '\@@' );
	}

	sub fill_url  {
	    my ( $self, $url ) = @_;

	    # Fix up url so it doesn't cause an error message
	    # add http:// if the user didn't
	    # add trailing slash if bare domain e.g. www.google.com
	    # todo: See if URI library makes this all trivial
	    if ( !($url =~ /http:/) ) { $url = 'http://'.$url;}
	    if (! ($url =~ /\/.*\..*$/) ) {if ( $url =~ /\.\w*$/ ) { $url = $url.'/';}}

	    return $url;
	}


	sub _sql_escape {
		my ( $self, $string ) = @_;
		if ($string) { $string =~ s/(['"\\])/\\$1/g; }
		return $string;
	}

	sub _html_to_sql {
		my ( $self, $string ) = @_;
		$string = $self->_html_unescape( $string );
		$string = $self->_sql_escape( $string );
		return $string;
	}

	sub _html_escape {
		my ( $self, $string ) = @_;
		$string =~ s/'/'/g;
		$string =~ s/"/"/g;
		return $string;
	}

	sub _html_encode {
		my ( $self, $string ) = @_;
		$string =~ s/ /%20/g;
		$string =~ s/'/%27/g;
		$string =~ s/\{/%7B/g;
		$string =~ s/\}/%7D/g;
		return $string;
	}

	sub _html_unescape {
		my ( $self, $string ) = @_;
		$string =~ s/'/'/g;
		$string =~ s/"/"/g;
		$string =~ s/%20/ /g;
		return $string;
	}

	sub _phone_format {
		my ( $self, $string ) = @_;
		$string =~ s/(\d{3})(\d{3})(\d{4})/($1) $2-$3/;
		return $string;
	}

	sub _phone_unformat {
		my ( $self, $string ) = @_;
		$string =~ s/[^\d]//g;
		return $string;
	}

	sub _commify { # Perl Cookbook 2.17
		my ( $self, $string ) = @_;
		my $text = reverse $string;
		$text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
		return scalar reverse $text;
	}

	sub _build_html_select_options {
		my ($self, $data, $current_id) = @_;
		my ($html, $selected);

		if (! $current_id) { $current_id = 0; $html .= "	 "; }

		foreach my $datum (@{ $data }) {
			my ($id, $label) = @$datum;
			if ($id == $current_id) { $selected = ' selected'; } else { $selected = ''; }
			$html .= "	 $label ";
		}

		return $html;
	}

	sub _get_files {
		my ( $self, $root_dir ) = @_;
		if (opendir(DIR, $root_dir)) {
			my (@files);
			my (@nodes) = (readdir(DIR));

			foreach my $node (@nodes) {
				if ($node =~ m/^\./) { next; }

	          		my $pathnode = $root_dir . "/" . $node;
				my @stat = stat($pathnode);

				my $value = defined $stat[2] ? $stat[2] : '';
				if ($value =~ /^[^1]/) {
					push(@files, $node);
			  	}
			}
			return @files;
		} else {
			return 0;
		}
	}

	sub _get_dirs {
		my ( $self, $path, $nestedflag) = @_;

		# If the directory opens
		if (opendir(DIR, $path)) {
			# Read it
			my (@dirs);
			my (@nodes) = sort (readdir(DIR));

			foreach my $node (@nodes) {
			  # Drop any dirs (or files) that start with a period
			  if ($node =~ m/^\./) { next; }

			  # Get file system node status
			  my @stat = stat($path . '/' . $node);

			  # if the first character of $mode is 1, then it is a dir
			  if ($stat[2] =~ /^1/) {
			    my $newpath = $path . "/" . $node;
			    push(@dirs, $newpath);

			    if ($nestedflag) {
			      my @subnodes = &GetDirs($newpath, $nestedflag);
			      push(@dirs, @subnodes);
			    }
			  }
			}
			return @dirs;
		} else {
			return 0;
		}
	}

	sub _get_file_text {
		my ( $self, $path_file_name ) = @_;
		my ($text, $line);
		if (-e $path_file_name) {
			open  (my $IN, '<', $path_file_name) || $self->_status( "(Get) Cannot open $path_file_name: $!" );
			while ($line = <$IN>) { $text .= $line; }
			close ($IN)                          || $self->_status( "(Get) Cannot close $path_file_name: $!" );
		}
		return $text;
	}

	sub _set_file_text {
		my ( $self, $path_file_name, $text ) = @_;
		open  (my $OUT, '>', $path_file_name)        || $self->_status( "(Set) Cannot open $path_file_name: $!" );
		print {$OUT} $text                           || $self->_status( "(Set) Cannot write $path_file_name: $!" );
		close ($OUT)                                 || $self->_status( "(Set) Cannot close $path_file_name: $!" );
	}

	sub _add_file_text {
		my ( $self, $path_file_name, $text ) = @_;
		open  (my $OUT, '>>', $path_file_name)       || $self->_status( "(Add) Cannot open $path_file_name: $!" );
		print {$OUT} $text                           || $self->_status( "(Add) Cannot write $path_file_name: $!" );
		close ($OUT)                                 || $self->_status( "(Add) Cannot close $path_file_name: $!" );
	}

	sub _status {
		my ( $self, $msg ) = @_;
		my $status_file = $self->get_status_filename();
		open  (my $OUT, '>>', $status_file)          || croak( "(Status) Cannot open $status_file: $!" );
		print {$OUT} "  STATUS: $msg \n"             || croak( "(Status) Cannot write $status_file: $!" );
		close ($OUT)                                 || croak( "(Status) Cannot close $status_file: $!" );
		return;
	}

}

1; # Magic true value required at end of module
__END__