The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

package Prima::CodeManager::Misc;

use strict;
use warnings;

use POSIX;

################################################################################

sub read_file_at_once {
    my( $self, $file ) = @_ ;

	return unless -f $file;

    my $content;

    local *FH;
    sysopen( FH, $file, O_RDONLY ) or $self->{ERROR} = "Can't open $file: $!";

	-f FH and sysread FH, $content, -s FH;

	return $content;
}

################################################################################

sub read_ini_file {
	my ( $self, $ini_file, $global ) = @_;

	my $group = '';

	if ( open ( my $FH, "<$ini_file" )) {

		while ( my $wiersz = <$FH> ) {
			next if $wiersz =~ /^(;|#|--)/;

			$wiersz =~ s/\n*//g;
			$wiersz =~ s/\r*//g;
			$wiersz =~ s/\t*//g;
			next unless $wiersz;

			$wiersz =~ s/^([^#]*)#.*$/$1/;

			if ( $wiersz =~ /^\s*\[(.+)\]/ ) {
				$group = $1;
			} else {

				if ( $wiersz =~ /^([^=]+?)\s*=\s*(.*)$/ ) {
					my $name   = $1;
					my $object = $2;
					$object =~ s/%\[([^%]*)\]([^%]*)%/$global->{$1}->{$2}/g;
					$global->{$group}->{$name} = $object if $group && $name;
				}
			}
		}
		close ($FH);
	}

	return 0;
}

################################################################################

sub write_ini_file {
	my ( $self, $ini_file ) = @_;

	foreach my $group (sort keys %::_GLOBAL ) {
		my %hasz = %{$::_GLOBAL{$group}};

		foreach my $name (sort keys %hasz ) {
			print "$group\[$name\]=",$hasz{$name},"\n";
		}

	}

	return 1;
}

################################################################################

sub read_one_row {
	my ( $self, $FH ) = ( shift, shift );

	my $wiersz = <$FH>;
	$wiersz = '' unless $wiersz;
	if ( $wiersz =~ /\\/ ) {
		$wiersz =~  s/^(.*)\\.*/$1/;
		$wiersz =~  s/^(.*)#.*/$1/;
		$wiersz .= ' ' unless $wiersz =~ /(,|;|`)\t*$/;	#`
		$wiersz .= $self-> read_one_row( $FH )
	}
	return $wiersz;
}

################################################################################

sub write_to_file {
	my ( $self, $file, $content ) = ( shift, shift, shift );

	if ( open (my $FH , ">>$file" )) {
		print $FH $content if $content;
		close $FH;
	}
}

#-------------------------------------------------------------------------------

sub read_file {
	my ( $self, $file, $content ) = ( shift, shift, '' );

	if ( open (my $FH , "<$file" )) {
		while ( my $row = <$FH> ) { $content .= $row }
		close $FH;
	}

	return $content;
}

################################################################################

sub czas {
	my ( $self, $format, $time ) = ( shift, shift, shift );
	my ($s,$m,$h,$D,$M,$Y) = localtime;
	($s,$m,$h,$D,$M,$Y) = localtime $time if defined $time;

	$s = substr('00'.$s,-2);
	$m = substr('00'.$m,-2);
	$h = substr('00'.$h,-2);
	$format =~ s/s/$s/g;
	$format =~ s/m/$m/g;
	$format =~ s/h/$h/g;

	$D = substr('00'.$D,-2);
	$M = substr('00'.($M+1),-2);
	$Y+= 1900;
	$format =~ s/DD/$D/g;
#	if ( $format =~ /MR/ ) {
#		$M = roman($M);
#		$M =~  tr/a-z/A-Z/;
#	}
#	$format =~ s/MR/$M/g;
	$format =~ s/MM/$M/g;
	$format =~ s/YYYY/$Y/g;
	$format =~ s/YY/substr($Y,-2)/ge;

	return $format;
}

################################################################################

sub licz_kolor
{
	my ( $self, $col1, $col2, $l1, $inw ) = @_;

	$l1  = 0 unless $l1; $l1 += 0; $l1 = 0 if $l1 < 0; $l1 = 1 if $l1 > 1;

	my $l2 = 1 - $l1;

	$inw =   0 unless $inw;
	$inw = 255 if     $inw;

	my @c1;
	my @c2;
	my @re;

	$c1[2] = $col1 % 256; $col1 = ( $col1 - $c1[2] ) / 256;
	$c1[1] = $col1 % 256; $col1 = ( $col1 - $c1[1] ) / 256;
	$c1[0] = $col1 % 256;

	$c2[2] = $col2 % 256; $col2 = ( $col2 - $c2[2] ) / 256;
	$c2[1] = $col2 % 256; $col2 = ( $col2 - $c2[1] ) / 256;
	$c2[0] = $col2 % 256;

	$re[0] = int( $l1 * $c1[0] + $l2 * $c2[0] );
	$re[0] =   0 if $re[0] <   0;
	$re[0] = 255 if $re[0] > 255;

	$re[1] = int( $l1 * $c1[1] + $l2 * $c2[1] );
	$re[1] =   0 if $re[1] <   0;
	$re[1] = 255 if $re[1] > 255;

	$re[2] = int( $l1 * $c1[2] + $l2 * $c2[2] );
	$re[2] =   0 if $re[2] <   0;
	$re[2] = 255 if $re[2] > 255;

	if ( $inw ) {
		return 256 * 256 * (255-$re[0]) + 256 * (255-$re[1]) + (255-$re[2]);
	} else {
		return 256 * 256 * $re[0] + 256 * $re[1] + $re[2];
	}
}

################################################################################

sub create_user_home_directory
{
	my ( $self, $home_directory, $CodeManager_directory ) = @_;

	return if -e $home_directory;

	mkdir "$home_directory";
	$self-> write_to_file ( "$home_directory/.exists" , '' );

my $CodeManager_CodeManager =<< "_CODE_MANAGER_";
[GLOBAL]
#group of projects (future)
group = System

#name of project
name = CodeManager

############## PROJECT TREE CONFIGURATION #############
#main project encoding
#can be redefined in each sub-project [DIRECTORY]
CodeManager_encoding= UTF8
#this is the height of one tree project branch:
#if none or less than 16 then tree_itemHeight = 16
tree_itemHeight		= 18
#the indent of next level branch relative to the parent one.
#if none or less than 16 then tree_itemIndent = 16
tree_itemIndent		= 16
#font name of the branches description
#if none then DejaVu Sans Mono is taken
tree_fontName		= DejaVu Sans Mono
#size and height of branch description font.
#only one is taken; height - if > 0 - has higher rank than size
#if none then tree_fontSize = 0.625 * tree_itemHeight
tree_fontSize		= 10
#tree_fontHeight	= 30

############## EDITOR PANEL #############
#additional space between lines. Can be negative!
#It is possible to dynamically change by pressing AltDown/AltUp keys
editor_lineSpace	=  2

#editor font size or height (similar rules to the tree configuration ones)
#It is possible to dynamically change by pressing CtrlDown/CtrlUp keys
editor_fontSize		= 11
#editor_fontHeight	= 12

#Font family should be chosen the mono type, but whatever!
editor_fontName		= DejaVu Sans Mono

############## NOTEBOOK CONFIGURATION #############

notebook_fontSize	=  9
notebook_fontName	= Arial

[EXTERNAL_EDITORS]
png	=	gimp
exe	=	no edit!

[DIRECTORY]
name		= My projects
image		= cm.png
linux		= ~/projects
windows		= ~/projects
extensions	= cm

[DIRECTORY]
name		= My templates
image		= pl.png
linux		= ~/templates
windows		= ~/templates
extensions	= pl|pm|ini
directories	= all

[DIRECTORY]
name		= CodeManager
image		= cm.png
linux		= %CodeManager%
windows		= %CodeManager%
extensions	= all
ext_exclude	= \\.exists\$
directories	= all
dir_exclude	= \\.svn\$

_CODE_MANAGER_

	mkdir "$home_directory/projects";
	$self-> write_to_file ( "$home_directory/projects/.exists" , '' );
	$self-> write_to_file ( "$home_directory/projects/CodeManager.cm" , $CodeManager_CodeManager );

	mkdir "$home_directory/templates";
	$self-> write_to_file ( "$home_directory/templates/.exists" , '' );
	$self-> write_to_file ( "$home_directory/templates/templates.ini" , '' );

	mkdir "$home_directory/templates/default";
	$self-> write_to_file ( "$home_directory/templates/default/.exists" , '' );

	mkdir "$home_directory/templates/list";
	$self-> write_to_file ( "$home_directory/templates/list/.exists" , '' );

	return;
}

################################################################################

1;

__END__

=pod

=head1 NAME

Prima::CodeManager::Misc

=head1 DESCRIPTION

This is part of CodeManager project - not for direct use.

=head1 AUTHOR

Waldemar Biernacki, E<lt>wb@sao.plE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2009-2012 by Waldemar Biernacki.

L<http://CodeManager.sao.pl>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut