view release on metacpan or  search on metacpan

examples/Tkwic.perl  view on Meta::CPAN

my $FileTypes = [["Text Files", ['.txt', '.text']],
                 ["All Files", "*"]];

# if (@ARGV > 0) {
#     $Font = '-*-helvetica-medium-r-normal--20-*-*-*-*-*-iso8859-1';
#     $MatchWidgetHeight = 14;
#     $MatchWidgetWidth = 70;
#     $ContextWidgetHeight = 6;
#     $NumberOfQueryEntries = 3;
# }

my $Apptitle;
my $UseTextWidget = ($QueryEntryHeight > 1);
my $NormalBackgroundColor;
my $NormalForegroundColor;

sub new {
    my ($class, %args) = @_;
    
    my $self = {};
    bless $self, $class;

    $self->{show_word} = 1;
    $self->{show_pos} = 0;
    $self->{show_lemma} = 0;
    $self->{show_noun_chunks} = 1;
    $self->{connected} = 0;
    $self->{corpus} = '';
    $self->{positional_attributes} = [];
    $self->{structural_attributes} = [];
    $self->{query_history} = [];

    my $main_window = $self->create_main_window();

    $main_window->bind('<Visibility>', [\&_visibility_cb, $self]);

    return $self;
}

sub _visibility_cb {
    my ($widget, $self) = @_;

    my $main_window = $self->{main_window};
    $main_window->bind('<Visibility>', '');
    $main_window->afterIdle([\&connect, $self]);
}

sub busy {
    my ($self) = @_;

    my $main_window = $self->{main_window};
    $main_window->Busy(-recurse => 1);
    my @kids = $main_window->children();
    foreach (@kids) {
        if ($_->class() eq 'Toplevel') {
            # Wenn man hier Busy() verwendet, kann es passieren, dass
            # einige Fenster trotz Unbusy() gesperrt bleiben. Damit
            # der Benutzer trotzdem ein Feedback bekommt, wird eine
            # Uhr als Mauszeiger verwendet.
            #$_->Busy(-recurse => 1);
            $_->configure(-cursor => 'watch');
        }
    }
}

sub unbusy {
    my ($self) = @_;

    my $main_window = $self->{main_window};
    my @kids = $main_window->children();
    foreach (@kids) {
        if ($_->class() eq 'Toplevel') {
            #$_->Unbusy();
            $_->configure(-cursor => 'left_ptr');
        }
    }
    $main_window->Unbusy();
}

sub bell {
    my ($self) = @_;

    $self->{main_window}->bell();
}

sub connect {
    my ($self) = @_;

    $self->busy();
    $self->set_status_message("Connecting to server");
    my ($host, $port, $user, $passwd);
    if (@ARGV) {
        unless (@ARGV >=2 and @ARGV <= 4) {
          print STDERR "Usage:  Tkwic.perl [<user> <password> [<host> [<port>]]]\n";
          exit 1;
        }
        $user = shift @ARGV;
        $passwd = shift @ARGV;
        $host = (@ARGV) ? shift @ARGV : "localhost";
        $port = (@ARGV) ? shift @ARGV : $CWB::CQI::PORT;
        $self->set_status_message("Connecting to $host on port $port");
        cqi_connect($user, $passwd, $host, $port);
    }
    else {
        # if $CQI_HOST is not set, start local server
        unless (cqi_server_available()) {
          print STDERR "CQPserver binary is not available on local machine, please specify login details for remote server.\n";
          print STDERR "Usage:  Tkwic.perl <user> <password> [<host> [<port>]]\n";
          exit 1;
        }
        ($user, $passwd, $host, $port) = cqi_server();
        $self->set_status_message("Connecting to $host on port $port");
        cqi_connect($user, $passwd, $host, $port);
    }
    $self->{connected} = 1;
    $Corpora = $self->get_corpora();
    # Use the first corpus by default.
    $self->{corpus} = $Corpora->[0];
    $self->switch_corpus();
    $self->set_status_message("Connected to $host on port $port");
    $self->unbusy();
}

sub disconnect {
    my ($self) = @_;

    $self->busy();
    if ($self->{connected}) {
        $self->set_status_message("Disconnecting");
        cqi_bye();
        $self->{connected} = 0;
    }
    $self->unbusy();
}

examples/Tkwic.perl  view on Meta::CPAN

            } else {
                my @list = /MACRO\s+(.*)\((.*)\)/o;
                if (@list) {
                    push @macros, {name => $list[0], body => []};
                    $state = 'macro';
                } else {
                    my $p = basename($0);
                    print STDERR "$p:$filename:$.: Syntax error near to `$_´\n";
                }
            }
        }
        close FILE;
    } else {
        my $p = basename($0);
        print STDERR "$p:$filename: Cannot open file\n";
    }
    return \@macros;
}

sub update_history_menu {
    my ($self) = @_;
    my ($menu, $history, $label);

    $menu = $self->{history_menu};
    $history = $self->{query_history};
    $menu->delete(1, 'end');
    foreach my $query (@$history) {
        $label = substr($query, 0, 40);
        $label =~ s/\n/ /go; 
        $menu->add('command', -label => $label,
                    -command => [\&copy_query, $self, $query]);
    } 
}

sub create_query_area {
    my ($self) = @_;

    my $main_window = $self->{main_window};
    my $vbox = $main_window->Frame(-relief => 'groove', -borderwidth => 2);
    my $popup = $self->{query_popup} =
        $vbox->Menu(-menuitems => [['command' => "Clear query",
                                    -command => [\&clear_query, $self]]],
                    -tearoff => 0);
    my $query_entry;
    for (my $i = 0; $i < $NumberOfQueryEntries; $i++) {
        if ($UseTextWidget) {
            my $scrolled = $vbox->Scrolled('Text', -scrollbars => 'osoe',
                                           -height => $QueryEntryHeight,
                                           -wrap => 'word');
            $query_entry = $scrolled->Subwidget('scrolled');
            $query_entry->tagConfigure('argument', -foreground => $ArgumentColor);
            $query_entry->tagConfigure('info', -foreground => $InfoColor);
            $query_entry->bind('Tk::Text', '<3>', '');
            $scrolled->pack(-fill => 'x', -expand => 1);
        } else {
            $query_entry = $vbox->Entry();
            $query_entry->pack(-fill => 'x', -expand => 1);
        }
        $query_entry->bind('<FocusIn>', [ \&query_focus_in, $self, $i ]);
        $query_entry->bind('<Button-3>',
                           sub { $popup->Popup(-popover => 'cursor', -popanchor => 'nw'); });
        $self->{query_entry}[$i] = $query_entry;
    }
    $self->{query_entry}[0]->focus();
    my $hbox = $vbox->Frame();
    my $history_button =
        $hbox->Menubutton(-text => "History", -indicatoron => 1,
                          -relief => 'raised', -pady => 5);
    $self->{history_menu} = $history_button->menu;
    my $execute_query_button = $hbox->Button(-text => "Start query",
                                          -command => [\&execute_query, $self]);
    $history_button->grid($execute_query_button, -sticky => 'ew');
    $hbox->gridColumnconfigure(1, -weight => 1);
    $hbox->pack(-fill => 'x', -expand => 1);
    return $vbox;
}

sub query_focus_in {
    my ($widget, $self, $n) = @_;

    for (my $i = 0; $i < $NumberOfQueryEntries; $i++) {
        if ($i != $n) {
            $self->{query_entry}[$i]->configure(-background =>
                                                $BackgroundColor);
        }
    }
    $widget->configure(-background => $SelectedQueryColor);
    $self->{current_query_entry} = $widget;
}

sub clear_query_area {
    my ($self) = @_;
    for (my $i = 0; $i < $NumberOfQueryEntries; $i++) {
        $self->set_query($self->{query_entry}[$i], '');
    }
}

sub create_output_area {
    my ($self) = @_;

    my $main_window = $self->{main_window};

    my $vbox = $main_window->Frame(-relief => 'groove', -borderwidth => 2);

    # Word, POS etc. buttons
    my $hbox1 = $vbox->Frame(-relief => 'groove', -borderwidth => 2);
    my $command = [sub {$self->show_matches($self->{query_first});}];
    my $word_button = $hbox1->Checkbutton(-text => "Word",
                                          -variable => \$self->{show_word},
                                          -command => $command);
    my $pos_button = $hbox1->Checkbutton(-text => "POS",
                                         -variable => \$self->{show_pos},
                                         -command => $command);
    my $lemma_button = $hbox1->Checkbutton(-text => "Lemma",
                                           -variable => \$self->{show_lemma},
                                           -command => $command);
    my $noun_chunks_button = $hbox1->Checkbutton(-text => "Noun chunks",
                                        -variable => \$self->{show_noun_chunks},
                                        -command => $command);
    $self->{noun_chunks_button} = $noun_chunks_button;
    if ($ManageNounChunksButton) {