PerlTk - Shell-alike Perl/Tk window scrolling content

Author

Shell-alike Perl/Tk window scrolling content

Markus Mohr

2004-05-17, 9:31 pm

Hi, all,

as newbie to this newsgroup please be patient if my question has been
posed around already, but I have not found any clue on how to handle
this:

I have constructed a large, HL7 / SCIPHOX / XML-based software
application in the sense of a client-server system with Perl/Tk. The
main aspect of the program is to encapsulate medical data in a secure
envelope. These data, even the enclosed binary objects, contain but
pure XML code.

When sending such an "XML string" from the client to the server, so
far I have used a "progress bar" function to display the sending's
process' progress (hehe ...).

But now, instead, I want to display a Perl/Tk window which scrolls
down the whole XML string from beginning to the end, until with the
last line a "close" button can be pressed, which means that the
sending process has been terminated.

Of course I know that this feature is merely a visual gimmick and
absolutely not necessary, and I also know that this feature can be
quite time-consuming.

On the other hand, I want to install it as a "chef feature" for those
who need to see that "there is something moving".

Can please anybody help me and provide me with the code for this
procedure? Simply open a new window, read the XML string, and scroll
the XML string down to its end, and then (or even before) a close
button shall be pressable.

Sincerely

Markus Mohr

zentara

2004-05-19, 3:32 pm

On Tue, 18 May 2004 02:15:40 +0200, Markus Mohr <markus.mohr@mazimoi.de>
wrote:

>I have constructed a large, HL7 / SCIPHOX / XML-based software
>application in the sense of a client-server system with Perl/Tk. The
>main aspect of the program is to encapsulate medical data in a secure
>envelope. These data, even the enclosed binary objects, contain but
>pure XML code.
>
>When sending such an "XML string" from the client to the server, so
>far I have used a "progress bar" function to display the sending's
>process' progress (hehe ...).
>
>But now, instead, I want to display a Perl/Tk window which scrolls
>down the whole XML string from beginning to the end, until with the
>last line a "close" button can be pressed, which means that the
>sending process has been terminated.
>
>Of course I know that this feature is merely a visual gimmick and
>absolutely not necessary, and I also know that this feature can be
>quite time-consuming.
>
>On the other hand, I want to install it as a "chef feature" for those
>who need to see that "there is something moving".
>
>Can please anybody help me and provide me with the code for this
>procedure? Simply open a new window, read the XML string, and scroll
>the XML string down to its end, and then (or even before) a close
>button shall be pressable.

Without seeing you code, I can't say how to tie into your progressbar,
but here is a simple example.

#file XML-sender for testing script below
#####################################
#!/usr/bin/perl
$|++;
for my $i ( 0 .. 100) {
print $i, "\n";
select(undef,undef,undef,.1);
}

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

#demo script
#######################################
#!/usr/bin/perl
use warnings;
use strict;
use Tk;

my $mw = new MainWindow;

my $t = $mw->Scrolled('Text',-width => 80, -height => 25, -wrap =>
'none')->pack(-expand => 1);

$mw->Button(-text=>'Start', -command=>sub {
&start_send })->pack;

$mw->Button(-text=>'Exit', -command=>sub {
Tk::exit })->pack;

MainLoop;

sub start_send{
open(CHILD, "./XML-sender 2>&1 |") or die "Can't open: $!";
$mw->fileevent(\*CHILD, 'readable', [\&fill_text_widget,$t]);
}

sub fill_text_widget {
my($widget) = @_;

$_ = <CHILD>;

if(defined $_){
$widget->insert('end', $_);
$widget->yview('end');
}else{print chr(07)}
}
__END__

--
I'm not really a human, but I play one on earth.
http://zentara.net/japh.html

zentara

2004-05-19, 4:31 pm

On Tue, 18 May 2004 02:15:40 +0200, Markus Mohr <markus.mohr@mazimoi.de>
wrote:

Hi, here is another method, which might fit into your program better.

#!/usr/bin/perl
use warnings;
use strict;
use Tk;

my $filename;
if(-f $ARGV[0]){ $filename = $ARGV[0]}
else{ die "Need input file\n"}

my $id;
my $mw=tkinit;

my $text = $mw->Scrolled('Text')->pack;

$mw->Button(-text=>'Start', -command=>sub {
&start_read })->pack;

$mw->Button(-text=>'Exit', -command=>sub {
Tk::exit })->pack;

MainLoop;

sub start_read {
open( FH, "< $filename") or warn "Can't open file\n $!";
$id = $mw->repeat(50, sub{&fill_text} );
}

sub fill_text{
my $line = readline(*FH);
if(! defined $line){$id->cancel, print chr(07)}
$text->insert('end',$line);
$text->see('end');
$mw->idletasks;

}
__END__

--
I'm not really a human, but I play one on earth.
http://zentara.net/japh.html

Markus Mohr

2004-05-21, 8:31 am

On Wed, 19 May 2004 15:16:44 -0400, zentara <zentara@highstream.net>
wrote:

>On Tue, 18 May 2004 02:15:40 +0200, Markus Mohr <markus.mohr@mazimoi.de>
>wrote:
>
>Hi, here is another method, which might fit into your program better.
>
>#!/usr/bin/perl
>use warnings;
>use strict;
>use Tk;
>
>my $filename;
>if(-f $ARGV[0]){ $filename = $ARGV[0]}
> else{ die "Need input file\n"}
>
>my $id;
>my $mw=tkinit;
>
>my $text = $mw->Scrolled('Text')->pack;
>
>$mw->Button(-text=>'Start', -command=>sub {
> &start_read })->pack;
>
>$mw->Button(-text=>'Exit', -command=>sub {
> Tk::exit })->pack;
>
>MainLoop;
>
>
>sub start_read {
> open( FH, "< $filename") or warn "Can't open file\n $!";
> $id = $mw->repeat(50, sub{&fill_text} );
>}
>
>sub fill_text{
> my $line = readline(*FH);
> if(! defined $line){$id->cancel, print chr(07)}
> $text->insert('end',$line);
> $text->see('end');
> $mw->idletasks;
>
>}

the code enlisted is excellent and works very fine. Thank you very
much for this idea.

Can you go on showing me a way in which this window opens up and
automatically displays the file's content by scrolling it down in the
fastest speed possible?

The reason why I ask this is that the user merely gets raw XML data
displayed. So there is no readable text in it, and I just want to show
him the "Matrix"-like bits and bytes flowing by which symbolize the
content he has created and now sends from point A to point B.

Sincerely and many thanks again,

Markus Mohr

zentara

2004-05-21, 10:39 am

On Fri, 21 May 2004 13:19:22 +0200, Markus Mohr <markus.mohr@mazimoi.de>
wrote:

>On Wed, 19 May 2004 15:16:44 -0400, zentara <zentara@highstream.net>
>wrote:
>
>
>the code enlisted is excellent and works very fine. Thank you very
>much for this idea.
>
>Can you go on showing me a way in which this window opens up and
>automatically displays the file's content by scrolling it down in the
>fastest speed possible?

The line:
$id = $mw->repeat(50, sub{&fill_text} );

has the delay in it. The 50 represents 50 milli-seconds, lower it
to 1.

There are also other ways to tie into your program, I did the
delay method because otherwise it would scroll so fast as
to be instantaneous.

What you should probably do, is as you send each line out the socket,
also send the same line to the textbox to be printed. But I can't
demonstrate that without seeing your code.

--
I'm not really a human, but I play one on earth.
http://zentara.net/japh.html

Ala Qumsieh

2004-05-21, 12:34 pm

zentara wrote:

....
> $mw->Button(-text=>'Start', -command=>sub {
> &start_read })->pack;

-command => \&start_read

> $mw->Button(-text=>'Exit', -command=>sub {
> Tk::exit })->pack;

-command => \&Tk::exit,

> $id = $mw->repeat(50, sub{&fill_text} );

$id = $mw->repeat(50, \&fill_text );

It is generally better to use this form of callback since the one you
are using can lead to memory leaks. You also get to type less :)

--Ala

Randal L. Schwartz

2004-05-21, 1:31 pm

>>>>> "Ala" == Ala Qumsieh <notvalid@email.com> writes:
[color=darkred]

Ala> $id = $mw->repeat(50, \&fill_text );

Ala> It is generally better to use this form of callback since the one you
Ala> are using can lead to memory leaks. You also get to type less :)

Is that a superstition, or are all anon coderefs subject to leaks?

I thought it was only a leak if the coderef refers to a closure
variable that in turn refers to the coderef (the classic reference
counting problem).

Are you talking about something other than that?

And, I would have just emailed you, BUT YOU DIDN'T INCLUDE YOUR EMAIL.
{sigh}

print "Just another Perl hacker,"; # the original

--
Randal L. Schwartz - Stonehenge Consulting Services, Inc. - +1 503 777 0095
<merlyn@stonehenge.com> <URL:http://www.stonehenge.com/merlyn/>
Perl/Unix/security consulting, Technical writing, Comedy, etc. etc.
See PerlTraining.Stonehenge.com for onsite and open-enrollment Perl training!

Markus Mohr

2004-05-21, 1:31 pm

On Fri, 21 May 2004 09:59:01 -0400, zentara <zentara@highstream.net>
wrote:

>On Fri, 21 May 2004 13:19:22 +0200, Markus Mohr <markus.mohr@mazimoi.de>
>wrote:
>
>
>
>The line:
> $id = $mw->repeat(50, sub{&fill_text} );
>
>has the delay in it. The 50 represents 50 milli-seconds, lower it
>to 1.
>
>There are also other ways to tie into your program, I did the
>delay method because otherwise it would scroll so fast as
>to be instantaneous.
>
>What you should probably do, is as you send each line out the socket,
>also send the same line to the textbox to be printed. But I can't
>demonstrate that without seeing your code.

Here you are:

[....]

#------------------------------------------------------------------------------#
# Subroutine, um die Anfrage mit der uebergebenen ID auf den Server
# aufzuspielen
#------------------------------------------------------------------------------#
sub put($$) {
my ($self, $anfrage, $konfiguration) = @_;

my $leng = length($anfrage);
my $sock = server_connect($konfiguration);
return unless defined $sock;

print $sock "PUT_ANF $leng\n";
my ($reply, $id);
$reply = <$sock>;
if ($reply =~ /OK/) { $sock->send("$anfrage\n"); } else {
server_disconnect ($sock); return; }

my $idid;
my $mw = tkinit;

my $text = $mw->Scrolled('Text',
-scrollbars => 'se',
)->pack;

$mw->Button(
-text => 'Start',
-command => sub {
open( FH, "< $anfrage") or warn "Can't open
file\n $!";
$idid = $mw->repeat(100, sub {
my $line = readline(*FH);
if(! defined $line) {
$idid->cancel, print chr(07);
}
$text->insert('end',$line);
$text->see('end');
$mw->idletasks;
}
);
}
)->pack;

$mw->Button(
-text => 'Exit',
-command => sub {
$mw->destroy();
}
)->pack;

($reply, $id) = split(/ /, <$sock> );
unless ($reply =~ /OK/) { server_disconnect ($sock); return; }
server_disconnect ($sock);

chop($id);

return $id;
}

[....]

Sincerely

Markus Mohr

Markus Mohr

2004-05-21, 1:31 pm

On Fri, 21 May 2004 15:07:57 GMT, Ala Qumsieh <notvalid@email.com>
wrote:

>zentara wrote:
>
>...
>
> -command => \&start_read
>
>
> -command => \&Tk::exit,
>
>
> $id = $mw->repeat(50, \&fill_text );
>
>It is generally better to use this form of callback since the one you
>are using can lead to memory leaks. You also get to type less :)

Thank you, this was something, I already had done upon importing
zentara's code, since I have to build up internal subroutines.

Sincerely

Markus Mohr

Ala Qumsieh

2004-05-21, 3:32 pm

Randal L. Schwartz wrote:
>
>
>
>
> Ala> $id = $mw->repeat(50, \&fill_text );
>
> Ala> It is generally better to use this form of callback since the one you
> Ala> are using can lead to memory leaks. You also get to type less :)
>
> Is that a superstition, or are all anon coderefs subject to leaks?

A bit of both :)
Jack Dunnigan reported a while ago the following (http://tinyurl.com/297vz):

$mw->repeat(50,sub{print "This Leaks\n"});
$mw->repeat(50,[sub{print "This doesn't leak\n"} ] );

The same behavior extends to bind() calls. I tried to reproduce the
problem with "-command => sub {}" syntax for buttons but couldn't
(unless you're destroying and creating objects, but that's a different
issue).

> I thought it was only a leak if the coderef refers to a closure
> variable that in turn refers to the coderef (the classic reference
> counting problem).

Circular references are a problem, but not Tk-specific. I wasn't talking
about those.

> Are you talking about something other than that?
>
> And, I would have just emailed you, BUT YOU DIDN'T INCLUDE YOUR EMAIL.
> {sigh}

Please don't shout at me, I read your books :)

But, I'm getting waaaay too much spam and thought I would reduce
unnecessary visibility of my contact info. I can always be reached at
aqumsieh at cpan dot org .. or more recently at qumsieh at perltk dot
org ;-D

(thanks Didier)

--Ala

zentara

2004-05-22, 9:31 am

On Fri, 21 May 2004 18:16:56 +0200, Markus Mohr <markus.mohr@mazimoi.de>
wrote:

>On Fri, 21 May 2004 09:59:01 -0400, zentara <zentara@highstream.net>
>wrote:

[color=darkred]
>Here you are:

Yeah, it dosn't look like you are doing it right, since you already
have the $anfrage data as a scalar, there is no need to open it as a
file. And you
definitely don't want to make a new window everytime you come into the
sub. I would put the tk stuff in a separate subroutine for clarity. It
looks to me like you are sending the $anfrage data as 1 long scalar
string, be aware that you could send it line by line, in that case the
code would be a little different.
This is untested , but should give you the idea. You might want to
make the $mw and $text box earlier in the program, so you can withdraw
it, and reuse it, in case you need to make multiple tries getting the
socket.

#somewhere at the beginning of your program
########################################
#########
my $mw = tkinit;
$mw -> withdraw; #hide the display window

my $text = $mw->Scrolled('Text',
-scrollbars => 'se',
)->pack;

$mw->Button(
-text => 'Exit',
-command => sub {
$mw->withdraw;
}
)->pack;
########################################
######

[..]

sub put($$) {
my ($self, $anfrage, $konfiguration) = @_;

my $leng = length($anfrage);
my $sock = server_connect($konfiguration);
return unless defined $sock;

print $sock "PUT_ANF $leng\n";
my ($reply, $id);
$reply = <$sock>;
if ($reply =~ /OK/) {
$sock->send("$anfrage\n");

&display_sent($anfrage);

} else {
server_disconnect ($sock);

&display_sent("Sorry not OK at Socket , no data sent !");

return; }

($reply, $id) = split(/ /, <$sock> );
unless ($reply =~ /OK/) { server_disconnect ($sock); return; }
server_disconnect ($sock);

&display_sent("\n\nFINISHED\n\n");

chop($id);
return $id;
}
[..]

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

sub display_sent() {
my $data = shift;

$mw->deiconify( );
$mw->raise( );

$text->insert('end',$data);
$text->see('end');
$mw->idletasks;
}
########################################
################

__END__

--
I'm not really a human, but I play one on earth.
http://zentara.net/japh.html

Markus Mohr

2004-05-22, 9:31 am

On Sat, 22 May 2004 08:45:55 -0400, zentara <zentara@highstream.net>
wrote:

>On Fri, 21 May 2004 18:16:56 +0200, Markus Mohr <markus.mohr@mazimoi.de>
>wrote:
>
>
>
>
>Yeah, it dosn't look like you are doing it right, since you already
>have the $anfrage data as a scalar, there is no need to open it as a
>file. And you
>definitely don't want to make a new window everytime you come into the
>sub. I would put the tk stuff in a separate subroutine for clarity. It
>looks to me like you are sending the $anfrage data as 1 long scalar
>string, be aware that you could send it line by line, in that case the
>code would be a little different.
>This is untested , but should give you the idea. You might want to
>make the $mw and $text box earlier in the program, so you can withdraw
>it, and reuse it, in case you need to make multiple tries getting the
>socket.

thank you very much, indeed, will try this out over the w

end and
give you a report.

Sincerely

Markus Mohr

Markus Mohr

2004-05-24, 6:36 am

On Sat, 22 May 2004 08:45:55 -0400, zentara <zentara@highstream.net>
wrote:

> [....]

>#somewhere at the beginning of your program
> ########################################
#########
>my $mw = tkinit;
>$mw -> withdraw; #hide the display window
>
>my $text = $mw->Scrolled('Text',
> -scrollbars => 'se',
> )->pack;
>
>$mw->Button(
> -text => 'Exit',
> -command => sub {
> $mw->withdraw;
> }
> )->pack;
> ########################################
######
>
>[..]
>
>sub put($$) {
> my ($self, $anfrage, $konfiguration) = @_;
>
> my $leng = length($anfrage);
> my $sock = server_connect($konfiguration);
> return unless defined $sock;
>
> print $sock "PUT_ANF $leng\n";
> my ($reply, $id);
> $reply = <$sock>;
> if ($reply =~ /OK/) {
> $sock->send("$anfrage\n");
>
> &display_sent($anfrage);
>
> } else {
> server_disconnect ($sock);
>
> &display_sent("Sorry not OK at Socket , no data sent !");
>
> return; }
>
> ($reply, $id) = split(/ /, <$sock> );
> unless ($reply =~ /OK/) { server_disconnect ($sock); return; }
> server_disconnect ($sock);
>
> &display_sent("\n\nFINISHED\n\n");
>
> chop($id);
> return $id;
>}
>[..]
>
> ########################################
################
>
>sub display_sent() {
> my $data = shift;
>
> $mw->deiconify( );
> $mw->raise( );
>
> $text->insert('end',$data);
> $text->see('end');
> $mw->idletasks;
>}
> ########################################
################
>
>__END__

yes, this code works fine for me, but now the content of $anfrage is
being displayed at once, and no longer scrolled a high speed. Is there
an additional method to get is scrolled?

Sincerely

Markus

zentara

2004-05-24, 7:32 pm

On Mon, 24 May 2004 11:17:54 +0200, Markus Mohr <markus.mohr@mazimoi.de>
wrote:

>On Sat, 22 May 2004 08:45:55 -0400, zentara <zentara@highstream.net>
>wrote:
>
>

[color=darkred]
>
>yes, this code works fine for me, but now the content of $anfrage is
>being displayed at once, and no longer scrolled a high speed. Is there
>an additional method to get is scrolled?

Remember when I said that you were sending the $anfrage as a slurped
scalar, and you could send it line by line instead?
Well now you see why.

The way you are sending the data, I think it's going to block further
processing until the send is complete. When the send is complete,
it can move on and display the $anfrage in the text box. Now, if you
want to put an "artificial delay" in the textbox printout, you can, but
that would only be "faking it", and would be a disservice to the user.
If you wanted to go that route, you just need to put a slight delay in
the display sub, like:

#faking the scroll

sub display_sent() {
my $data = shift;
$mw->deiconify( );
$mw->raise( );

#first split the data into lines
my @data = split( "\n ", $data);

while(@data){
$text->insert('end',$_);
$text->see('end');
$mw->after(50); # a 50 msec delay
$mw->idletasks;
}
}
########################################
######
Now if you want to do it so that the scroll actually
reflects the data as it's being sent out of the socket,
try something like this. Untested (and I'm not a socket details expert).
Split your $anfrage into lines and send it line by line, then
the textbox will show each line as it's sent.

sub put($$) {
my ($self, $anfrage, $konfiguration) = @_;

#split to lines
my @anfrage = split( "\n ", $anfrage);

# my $leng = length($anfrage);
my $sock = server_connect($konfiguration);
return unless defined $sock;

while(@anfrage){

my $leng = length($_);

print $sock "PUT_ANF $leng\n";
my ($reply, $id);
$reply = <$sock>;
if ($reply =~ /OK/) {
$sock->send("$_\n");
&display_sent($_);
}

} else {
server_disconnect ($sock);

&display_sent("Sorry not OK at Socket , no data sent !");

return; }

($reply, $id) = split(/ /, <$sock> );
unless ($reply =~ /OK/) { server_disconnect ($sock); return; }
server_disconnect ($sock);

&display_sent("\n\nFINISHED\n\n");

chop($id);
return $id;
}
[..]

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

The above is untested, and there may be some unforseen glitch
due to the extra newlines being sent to the socket, but I think
it should work.

--
I'm not really a human, but I play one on earth.
http://zentara.net/japh.html

Markus Mohr

2004-06-03, 7:10 pm

On Mon, 24 May 2004 18:11:49 -0400, zentara <zentara@highstream.net>
wrote:
[color=darkred]
>On Mon, 24 May 2004 11:17:54 +0200, Markus Mohr <markus.mohr@mazimoi.de>
>wrote:
>

Hello zentara,

here is the whole code. Seems to be something with the brackets
depending on while with the "if .. else" statement and the inclusion
of "my ($reply, $id);" under the while conditional statement.

Sincerely

Markus
#!/usr/bin/perl -w

#------------------------------------------------------------------------------#
# CNetwork.pm #
# #
# Modul fuer die Client-Network Funktionen #
#------------------------------------------------------------------------------#

package CNetwork;

#------------------------------------------------------------------------------#
# Interne Versionierung #
#------------------------------------------------------------------------------#
use vars qw/$VERSION $TIMESTAMP/;
$VERSION = "1.5.5";
$TIMESTAMP = 20040521;

#------------------------------------------------------------------------------#
# Laden der internen Module (2) #
#------------------------------------------------------------------------------#
use Tk;
use IO::Socket;

#------------------------------------------------------------------------------#
# Laden der externen Module (0) #
#------------------------------------------------------------------------------#

#------------------------------------------------------------------------------#
# Pragmata #
#------------------------------------------------------------------------------#
use diagnostics;
use strict;

# use open ':utf8';

return 1;

#------------------------------------------------------------------------------#
# Subroutine, um die Anfrage mit der uebergebenen ID auf den Server #
# aufzuspielen #
#------------------------------------------------------------------------------#
sub put($$) {
my ( $self, $anfrage, $konfiguration ) = @_;

my $gui = $konfiguration->get_value('gui');

# XML-Ausgabe in einem Fenster
my $bgcolor = $konfiguration->get_value('bgcolor');
my $fgcolor = $konfiguration->get_value('fgcolor');
my $fncolor = $konfiguration->get_value('fncolor');
my $font12 = $konfiguration->get_value('font12');
my $font14 = $konfiguration->get_value('font14');
my $font16 = $konfiguration->get_value('font16');
my $font18 = $konfiguration->get_value('font18');
my $font20 = $konfiguration->get_value('font20');
my $font22 = $konfiguration->get_value('font22');
my $font24 = $konfiguration->get_value('font24');
my $font30 = $konfiguration->get_value('font30');

my @anfrage = split("\n", $anfrage);
# my $leng = length($anfrage);
my $sock = server_connect($konfiguration);
return unless defined $sock;

my ( $reply, $id );
while(@anfrage) {
my $leng = length($_);
print $sock "PUT_ANF $leng\n";
#my ( $reply, $id );
$reply = <$sock>;
if ($reply =~ /OK/ ) {
$sock->send("$_\n");
&display_sent($_);
#}
#}

# PUT_ANF Request senden und Länge der Daten übermitteln
#print $sock "PUT_ANF $leng\n";

# Auf Antwort vom Server warten
#my ( $reply, $id );
#$reply = <$sock>;

# Falls Senden OK ist, Daten schicken - ansonsten Connection schliessen und
# abbrechen
#if ( $reply =~ /OK/ ) {
#$sock->send("$anfrage\n");
#&display_sent($anfrage);
}
else {
server_disconnect($sock);
&display_sent("Sorry not OK at Socket, no data sent!");
return;
} }

=begin
my $idid;
my $send_scroll = MainWindow->new();
$send_scroll->title("Dump der versendeten Daten");
$send_scroll->minsize( "400", "300" );
$send_scroll->packPropagate(0);
$send_scroll->configure( -background => $bgcolor );

my $text = $send_scroll->Scrolled(
"Text",
-scrollbars => 'e',
-wrap => 'word',
-font => $font18,
-relief => 'sunken',
-foreground => 'darkblue',
-background => 'lightgray'
)->pack( -anchor => "center", -padx => 0, -pady => 0 );

my $xmldump_file = IO::File->new_tmpfile or die "IO::File->new_tmpfile: $!";
$xmldump_file->autoflush(1);
print $xmldump_file $konfiguration->get_value('xml')->{'root'}->toString;
s

( $xmldump_file, 0, 0 );

# $send_scroll->repeat(
# 1,
# sub {
$text->insert( 'end', <$xmldump_file> );
$text->see('end');
$send_scroll->idletasks;

# }
# );

$send_scroll->Button(
-text => CText->get( $konfiguration, 80 ),
-font => $font18,
-background => $bgcolor,
-foreground => $fncolor,
-activebackground => $fgcolor,
-activeforeground => $fncolor,
-command => sub { $konfiguration->set_value( 'win_send_scroll', '' ); $send_scroll->destroy; }
)->pack( -side => "bottom", -pady => 10 );

$mw->Button(
-text => 'Start',
-command => sub {
open( FH, "< $anfrage" ) or warn "Can't open file\n $!";
$idid = $mw->repeat(
100,
sub {
my $line = readline(*FH);
if ( !defined $line ) {
$idid->cancel, print chr(07);
}
$text->insert( 'end', $line );
$text->see('end');
$mw->idletasks;
}
);
}
)->pack;
=cut

# Warten, welche ID wir bekommen
( $reply, $id ) = split ( / /, <$sock> );

# Falls etwas nicht funtioniert hat, Connection schliessen und abbrechen
unless ( $reply =~ /OK/ ) { server_disconnect($sock); return; }

# Ansonsten Verbindung schliessen und ID zurückgeben
server_disconnect($sock);

# &display_sent("\n\nFINISHED\n\n");

chop($id);

return $id;
}

#------------------------------------------------------------------------------#
# Subroutine, um die Anfrage in einem kleinen Fenster auszugeben #
#------------------------------------------------------------------------------#
sub display_sent() {
my $data = shift;
my $mw = tkinit;
$mw->withdraw; #hide the display window

# $konfiguration->set_value( 'win_send_scroll', $mw );
# $mw->title( CText->get( $konfiguration, 118, -font => $font18 ) );
# $mw->configure( -background => $bgcolor );

my $text = $mw->Scrolled( 'Text', -scrollbars => 'se', )->pack;

=begin Alternative 0
$mw->Button(
-text => CText->get( $konfiguration, 80 ),
-font => $font18,
-background => $bgcolor,
-foreground => $fncolor,
-activebackground => $fgcolor,
-activeforeground => $fncolor,
-command => sub { $mw->withdraw; $konfiguration->set_value( 'win_send_scroll', '' ); $mw->destroy; }
)->pack( -side => "bottom", -pady => 10 );
=cut

$mw->Button(
-text => "Schliessen",
-command => sub { $mw->withdraw; }
)->pack( -side => "bottom", -pady => 10 );

$mw->deiconify();
$mw->raise();

=begin Alternative 1
my @data = split("\n", $data);
while(@data) {
$text->insert('end',$_);
$text->see('end');
$mw->after(25);
$mw->idletasks;
}
=cut

$text->insert( 'end', $data );
$text->see('end');
$mw->idletasks;
}

#------------------------------------------------------------------------------#
# Subroutine, um eine Anfrage mit der übergebenen ID vom Server abzuholen #
#------------------------------------------------------------------------------#
sub get($$) {
my ( $self, $anfrageid, $konfiguration ) = @_;

my $sock = server_connect($konfiguration);
return unless defined $sock;
my $uid = $konfiguration->get_value('uid');

# GET_ANF Request senden und Anfrage-ID übermitteln
print $sock "GET_ANF $anfrageid|$uid\n";

# Auf Antwort vom Server warten
my $reply = <$sock>;
chop($reply) if $reply =~ /[\n|\r]$/;
$reply =~ s/�/\n/g;

# Falls Fehlermeldung zurückkommt Socket schliessen und abbrechen
if ( $reply =~ /^ANA/ ) { server_disconnect($sock); return; }

# Ansonsten Verbindung schliessen und Daten übernehmen
server_disconnect($sock);

CFilter->import_anfrage( $reply, $konfiguration );

return 1;
}

#------------------------------------------------------------------------------#
# Subroutine, um eine Antwort mit der uebergebenen ID vom Server abzuholen #
#------------------------------------------------------------------------------#
sub rep($$) {
my ( $self, $antwortid, $konfiguration ) = @_;

my $sock = server_connect($konfiguration);
return unless defined $sock;
my $uid = $konfiguration->get_value('uid');

# GET_ANT Request senden und Antwort-ID übermitteln
print $sock "GET_ANT $antwortid|$uid\n";

# Auf Antwort vom Server warten
print "LESE ANTWORT\n";
my $reply = <$sock>;
chop($reply) if $reply =~ /[\n|\r]$/;
print "ERSETZE CR\n";
$reply =~ s/�/\n/g;

# Falls Fehlermeldung zurückkommt Socket schliessen und abbrechen
if ( $reply =~ /^ANA/ ) { server_disconnect($sock); return; }

# Ansonsten Verbindung schliessen und Daten übernehmen
server_disconnect($sock);
print "FERTIG\n";

return $reply;
}

#------------------------------------------------------------------------------#
# Subroutine, um beim Server anzufragen, ob Antworten auf dem Server #
# vorhanden sind #
#------------------------------------------------------------------------------#
sub query($) {
my ( $self, $anfrageid, $konfiguration ) = @_;

my $sock = server_connect($konfiguration);
return unless defined $sock;
my $uid = $konfiguration->get_value('uid');

# CHK_ANF Request senden und Anfrage-ID übermitteln
print $sock "CHK_ANF $anfrageid|$uid\n";

# Auf Antwort vom Server warten
my $reply = <$sock>;
chop($reply);

# Verbindung schliessen
server_disconnect($sock);

return $reply;
}

#------------------------------------------------------------------------------#
# Subroutine, um nach abgeschlossener Untersuchung die komplette Akte #
# auf den Server zu ueberspielen #
#------------------------------------------------------------------------------#
sub completed($) {
my ( $self, $akte, $konfiguration ) = @_;

my $leng = length($akte);
my $sock = server_connect($konfiguration);
return unless defined $sock;

# PUT_EPA Request senden und Laenge der Daten uebermitteln
print $sock "PUT_EPA $leng\n";

# Auf Antwort vom Server warten
my ( $reply, $id );
$reply = <$sock>;

# Falls Senden OK ist, Daten schicken - ansonsten Connection schliessen
# und abbrechen
if ( $reply =~ /OK/ ) { $sock->send("$akte\n"); }
else { server_disconnect($sock); return; }

# Warten, welche ID wir bekommen
( $reply, $id ) = split ( / /, <$sock> );

# Falls etwas nicht funtioniert hat, Connection schliessen und abbrechen
unless ( $reply =~ /OK/ ) { server_disconnect($sock); return; }

# Ansonsten Verbindung schliessen und ID zurueckgegen
server_disconnect($sock);

chop($id);

return $id;
}

#------------------------------------------------------------------------------#
# Subroutine, um eine Verbindung zum Server herzustellen #
#------------------------------------------------------------------------------#
sub server_connect ($) {
my $konfiguration = shift;
my $host = $konfiguration->get_value('server');
my $port = $konfiguration->get_value('server_port');

my $sock = IO::Socket::INET->new(
PeerAddr => $host,
PeerPort => $port,
Proto => 'tcp'
);
return unless defined $sock;
$sock->autoflush(1);
return $sock;
}

#------------------------------------------------------------------------------#
# Subroutine, um die Verbindung zum Server zu beenden #
#------------------------------------------------------------------------------#
sub server_disconnect ($) {
my $sock = shift;
close $sock;
return;
}

#------------------------------------------------------------------------------#
# Subroutine, um den Server zu connecten #
#------------------------------------------------------------------------------#
sub c_server_connect ($) {
my ( $self, $konfiguration ) = @_;

# Nur Benutzer aus dem Formenkreis der "admin"-Gruppe duerfen diese
# Funktion ausueben
if ( $konfiguration->get_value('user_role') =~ /user/ ) {

# Bestaetigung, dass es nicht moeglich ist, diese Funktion auszuueben,
# wenn der Benutzer nicht zu der "admin"-Gruppe gehoert
if ( $konfiguration->get_value('gui') ) {
return if $konfiguration->get_value('gui')->create_agreed( CText->get( $konfiguration, 975 ), $konfiguration );
}

print "Sie m\x81ssen Administrator-Rechte besitzen, um diese Funktion ausf\x81hren zu k\x94nnen!";
return;
}

print "Die Verbindung vom Client zum Server wird manuell gestartet.\n";
return;
}

#------------------------------------------------------------------------------#
# Subroutine, um den Server zu dekonnektieren #
#------------------------------------------------------------------------------#
sub c_server_disconnect ($) {
my ( $self, $konfiguration ) = @_;

# Nur Benutzer aus dem Formenkreis der "admin"-Gruppe duerfen diese
# Funktion ausueben
if ( $konfiguration->get_value('user_role') =~ /user/ ) {

# Bestaetigung, dass es nicht moeglich ist, diese Funktion auszuueben,
# wenn der Benutzer nicht zu der "admin"-Gruppe gehoert
if ( $konfiguration->get_value('gui') ) {
return if $konfiguration->get_value('gui')->create_agreed( CText->get( $konfiguration, 975 ), $konfiguration );
}

print "Sie m\x81ssen Administrator-Rechte besitzen, um diese Funktion ausf\x81hren zu k\x94nnen!";
return;
}

print "Die Verbindung vom Client zum Server wird manuell getrennt.\n";
return;
}

#------------------------------------------------------------------------------#
# Subroutine, um den Wert einer Option auszugeben #
#------------------------------------------------------------------------------#
sub get_value($) {
my ( $self, $option ) = @_;
return $self->{$option};
}

#------------------------------------------------------------------------------#
# Subroutine, um den Wert einer Option zu setzen #
#------------------------------------------------------------------------------#
sub set_value($$) {
my ( $self, $option, $value ) = @_;
$self->{$option} = $value;
return;
}

Sponsored Links