summaryrefslogtreecommitdiffstats
path: root/perl-install
diff options
context:
space:
mode:
Diffstat (limited to 'perl-install')
-rw-r--r--perl-install/standalone/net_applet489
1 files changed, 0 insertions, 489 deletions
diff --git a/perl-install/standalone/net_applet b/perl-install/standalone/net_applet
deleted file mode 100644
index a0c9efe40..000000000
--- a/perl-install/standalone/net_applet
+++ /dev/null
@@ -1,489 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use lib qw(/usr/lib/libDrakX);
-use c;
-use common;
-use standalone;
-use network::network;
-use network::tools;
-use run_program;
-use mygtk2 qw(gtknew);
-use dbus_object;
-use network::ifw;
-use network::monitor;
-use detect_devices;
-
-use Gtk2::TrayIcon;
-use Gtk2::NotificationBubble;
-
-use ugtk2 qw(:create :helpers :wrappers :dialogs);
-
-my $onstartupfile = "$ENV{HOME}/.net_applet";
-shouldStart() or die "$onstartupfile should be set to TRUE or use net_applet --force";
-#- Allow multiple instances, but only one per user:
-is_running('net_applet') and die "net_applet already running\n";
-
-my ($eventbox, $img, $bubble);
-my ($current_state, $current_interface, $menu, $wireless_device, $wireless_menu, $timeout, $update_timeout);
-add_icon_path("/usr/share/libDrakX/pixmaps/");
-
-my $net = {};
-my $watched_interface;
-
-my %pixbufs =
- (
- firewall => gtkcreate_pixbuf('/usr/lib/libDrakX/icons/drakfirewall.png'),
- firewall_icon => gtkcreate_pixbuf('/usr/lib/libDrakX/icons/drakfirewall.png')->scale_simple(24, 24, 'hyper'),
- state => { map { $_ => gtkcreate_pixbuf($_) } qw(connected disconnected) },
- link_level => { map {
- $_ => gtkcreate_pixbuf('wifi-' . sprintf('%03d', $_) . '.png')->scale_simple(24, 24, 'hyper');
- } qw(20 40 60 80 100) },
- keyring => gtkcreate_pixbuf("/usr/share/pixmaps/keyring-small.png")->scale_simple(24, 24, 'hyper'), #- provided by usermode, required by drakxtools
- );
-my %wireless_networks;
-my %tooltips =
- (
- connected => N_("Network is up on interface %s"),
- disconnected =>
- #-PO: keep the "Configure Network" substring synced with the "Configure Network" message below
- N_("Network is down on interface %s. Click on \"Configure Network\""),
- notconfigured => N_("You do not have any configured Internet connection.
-Run the \"%s\" assistant from the Mandriva Linux Control Center", N("Set up a new network interface (LAN, ISDN, ADSL, ...)")),
- );
-
-my %actions = (
- 'upNetwork' => { name => sub { N("Connect %s", $_[0]) }, launch => sub { network::tools::start_interface($_[0], 1) } },
- 'downNetwork' => { name => sub { N("Disconnect %s", $_[0]) }, launch => sub { network::tools::stop_interface($_[0], 1) } },
- 'monitorNetwork' => { name => N("Monitor Network"), launch => \&run_net_monitor },
- 'monitorIFW' => { name => N("Interactive Firewall"), launch => \&run_drakids },
- 'wireless' => { name => N("Manage wireless networks"), launch => sub { run_drakroam() } },
- 'confNetwork' => { name => N("Configure Network"), launch => sub { system("/usr/sbin/drakconnect --skip-wizard &") } },
- 'chooseInterface' => {
- name => N("Watched interface"),
- choices => sub { N("Auto-detect"), sort keys %{$net->{ifcfg}} },
- choice_selected => sub { $watched_interface ? $_[0] eq $watched_interface : $_[0] eq N("Auto-detect") },
- launch => sub {
- $watched_interface = $_[0] eq N("Auto-detect") ? undef : $_[0];
- checkNetworkForce();
- }
- },
- 'setInterface' => {
- name => N("Active interfaces"),
- use_checkbox => 1,
- choices => sub { sort keys %{$net->{ifcfg}} },
- choice_selected => sub {
- my ($is_up, $_gw) = network::tools::get_interface_status($_[0]);
- $is_up;
- },
- launch => sub {
- my ($is_up, $_gw) = network::tools::get_interface_status($_[0]);
- if ($is_up) {
- network::tools::stop_interface($_[0], 1);
- } else {
- network::tools::start_interface($_[0], 1);
- }
- checkNetworkForce();
- }
- },
- 'chooseProfile' => {
- name => N("Profiles"),
- choices => sub { network::network::netprofile_list() },
- choice_selected => sub { $_[0] eq $net->{PROFILE} },
- launch => sub {
- require run_program;
- $net->{PROFILE} = $_[0];
- run_program::raw({ detach => 1 }, network::tools::wrap_command_for_root('/sbin/set-netprofile', $net->{PROFILE}));
- }
- },
- 'help' => { name => N("Get Online Help"), launch => sub { system("drakhelp --id internet-connection &") } },
- 'quit' => { name => N("Quit"), launch => \&mainQuit },
- );
-
-gtkadd(my $icon = Gtk2::TrayIcon->new("Net_Applet"),
- gtkadd($eventbox = Gtk2::EventBox->new,
- gtkpack($img = Gtk2::Image->new)
- )
- );
-$icon->show_all;
-
-my ($dbus, $monitor, $ifw, $interactive_cb, @attacks_queue, $ifw_alert);
-eval { $dbus = dbus_object::system_bus() };
-eval { $monitor = network::monitor->new($dbus) } if $dbus;
-eval {
- $ifw = network::ifw->new($dbus, sub {
- my ($_con, $msg) = @_;
- my $member = $msg->get_member;
- if ($member eq 'Attack') {
- handle_attack($msg->get_args_list);
- } elsif ($member eq 'Init') {
- $ifw->attach_object;
- checkNetworkForce();
- } elsif ($member eq 'AlertAck') {
- $ifw_alert = 0;
- }
- });
-} if $dbus;
-
-$bubble = Gtk2::NotificationBubble->new;
-$bubble->attach($icon);
-$bubble->signal_connect(timeout => sub {
- set_verdict($attacks_queue[0], \&apply_verdict_ignore);
-});
-$bubble->signal_connect(clicked => sub {
- $bubble->hide;
- eval { $ifw->send_alert_ack };
- $ifw_alert = 0;
- update_tray_icon();
- ask_attack_verdict($attacks_queue[0]);
-});
-
-$eventbox->signal_connect(button_press_event => sub {
- $_[1]->button == 1 and ($ifw_alert ? run_drakids() : run_net_monitor());
- $_[1]->button == 3 && $menu and $menu->popup(undef, undef, undef, undef, $_[1]->button, $_[1]->time);
-});
-
-checkNetworkForce();
-cronNetwork();
-get_unprocessed_attacks();
-
-$SIG{HUP} = sub {
- print "received SIGHUP, reloading network configuration\n";
- checkNetworkForce();
-};
-
-Gtk2->main;
-
-ugtk2::exit(0);
-
-sub is_running {
- my ($name) = @_;
- any {
- my ($ppid, $pid, $n) = /^\s*(\d+)\s+(\d+)\s+(.*)/;
- $pid != $$ && $n eq $name;
- } `ps -o '%P %p %c' -u $ENV{USER}`;
-}
-sub shouldStart() {
- my ($opt) = @ARGV;
- if ($opt eq '--force' || $opt eq '-f') {
- return 1;
- }
- return getAutoStart();
-}
-sub run_net_monitor() {
- run_program::raw({ detach => 1 }, '/usr/sbin/net_monitor', '--defaultintf', $current_interface) unless is_running('net_monitor');
-}
-sub run_drakroam {
- my ($o_ap) = @_;
- run_program::raw({ detach => 1 }, '/usr/sbin/drakroam', if_($o_ap, "--ap=$o_ap")) unless is_running('drakroam');
-}
-sub run_drakids() {
- $ifw_alert = 0;
- if (is_running('drakids')) {
- eval { $ifw->send_manage_request };
- } else {
- run_program::raw({ detach => 1 }, '/usr/sbin/drakids');
- }
-}
-sub generate_wireless_menuitem {
- my ($wnet, $ap) = @_;
- $wnet->{menuitem} = Gtk2::CheckMenuItem->new;
- $wnet->{menuitem}->set_draw_as_radio(1);
- $wnet->{menuitem}->add(gtkpack_(gtkshow(Gtk2::HBox->new),
- 1, gtkset_alignment($wnet->{ssid_label} = Gtk2::Label->new, 0, 0),
- 0, $wnet->{keyring_image} = Gtk2::Image->new_from_pixbuf($pixbufs{keyring}),
- 0, $wnet->{level_image} = Gtk2::Image->new));
- $wnet->{activate} = $wnet->{menuitem}->signal_connect('activate' => sub {
- if (exists $wnet->{id}) {
- eval { $monitor->select_network($wnet->{id}) };
- $@ and err_dialog(N("Interactive Firewall"), N("Unable to contact daemon"));
- } else {
- run_drakroam($ap);
- }
- checkNetworkForce();
- });
- undef $current_state; #- force menu redraw
-}
-sub update_wireless_item {
- my ($wnet, $ap_address) = @_;
- $wnet->{ssid_label}->set_text($wnet->{essid} || "[$ap_address]");
- $wnet->{keyring_image}->visible(to_bool($wnet->{flags}));
- $wnet->{level_image}->set_from_pixbuf($pixbufs{link_level}{$wnet->{approx_level}});
-
- $wnet->{menuitem}->signal_handler_block($wnet->{activate});
- $wnet->{menuitem}->set_active($wnet->{current});
- $wnet->{menuitem}->signal_handler_unblock($wnet->{activate});
-}
-sub checkWireless() {
- $wireless_device or return;
- my ($networks) = network::monitor::list_wireless($monitor, $wireless_device);
- foreach (keys %$networks) {
- my $wnet = $wireless_networks{$_} ||= {};
- put_in_hash($wnet, $networks->{$_});
- exists $wnet->{menuitem} or generate_wireless_menuitem($wnet, $_);
- update_wireless_item($wnet, $_);
- }
- $wireless_networks{$_}{menuitem}->visible(exists $networks->{$_}) foreach keys %wireless_networks;
-}
-sub checkNetwork() {
- my ($gw_intf, $_is_up, $gw_address) = $watched_interface ?
- ($watched_interface, network::tools::get_interface_status($watched_interface)) :
- network::tools::get_internet_connection($net);
- go2State($gw_address ? 'connected' : $gw_intf ? 'disconnected' : 'notconfigured', $gw_intf);
-}
-sub checkNetworkForce() {
- $net = {};
- network::network::read_net_conf($net);
- undef $current_state;
- $wireless_device = detect_devices::get_wireless_interface();
- checkWireless();
- checkNetwork();
-}
-sub cronNetwork() {
- my $i;
- $timeout = Glib::Timeout->add(2000, sub {
- checkWireless() if !($i++%30);
- checkNetwork();
- 1;
- });
-}
-sub go2State {
- my ($state_type, $interface) = @_;
- if ($current_state ne $state_type || $current_interface ne $interface) {
- $current_state = $state_type;
- $current_interface = $interface;
- $wireless_device = detect_devices::get_wireless_interface();
- if ($menu) {
- if (my $m = $wireless_menu && $wireless_menu->get_submenu) {
- $_->{menuitem}->get_parent and $m->remove($_->{menuitem}) foreach values %wireless_networks;
- }
- $menu->destroy;
- }
- $menu = generate_menu($interface);
- }
-}
-sub update_tray_icon() {
- if (!$ifw_alert || $img->get_storage_type ne 'pixbuf') {
- my $pixbuf;
- if ($current_state eq 'connected') {
- if (detect_devices::is_wireless_interface($current_interface)) {
- my $wnet = find { $_->{current} } values %wireless_networks;
- $pixbuf = $pixbufs{link_level}{$wnet->{approx_level}} if $wnet;
- }
- $pixbuf ||= $pixbufs{state}{connected};
- } else {
- $pixbuf = $pixbufs{state}{disconnected};
- }
- $img->set_from_pixbuf($pixbuf);
- } else {
- $img->set_from_stock('gtk-dialog-warning', 'small-toolbar');
- }
-}
-sub generate_menu {
- my ($interface) = @_;
-
- update_tray_icon();
- gtkset_tip(Gtk2::Tooltips->new, $eventbox, formatAlaTeX(sprintf(translate($tooltips{$current_state}), $interface)));
-
- my $menu = Gtk2::Menu->new;
- my $create_item = sub {
- my ($action) = @_;
- my $name = ref($actions{$action}{name}) eq 'CODE' ? $actions{$action}{name}->($interface) : $actions{$action}{name};
- my $launch = $actions{$action}{launch};
- my @choices = exists $actions{$action}{choices} ? $actions{$action}{choices}->() : ();
- my $w;
- if (@choices == 0) {
- $w = gtksignal_connect(gtkshow(Gtk2::MenuItem->new_with_label($name)), activate => sub { $launch->($interface) });
- } elsif (@choices > 1) {
- my $selected = $actions{$action}{choice_selected};
- my $format = $actions{$action}{format_choice};
- $w = gtkshow(create_menu($name, map {
- my $choice = $_;
- my $w = gtkshow(gtkset_active(Gtk2::CheckMenuItem->new_with_label($format ? $format->($choice) : $choice), $selected->($choice)));
- gtksignal_connect($w, activate => sub { $launch->($choice) });
- $w->set_draw_as_radio(!$actions{$action}{use_checkbox});
- $w;
- } $actions{$action}{choices}->()));
- }
- #- don't add submenu if only one choice exists
- $w;
- };
-
- my (@settings);
- my $interactive;
- eval { $interactive = $ifw->get_interactive };
-
- if ($current_state eq 'connected') {
- $menu->append($create_item->($_)) foreach qw(downNetwork monitorNetwork);
- } elsif ($current_state eq 'disconnected') {
- $menu->append($create_item->('upNetwork'));
- }
- $menu->append($create_item->('monitorIFW')) if $current_state ne 'notconfigured' && defined $interactive;
-
- $menu->append($create_item->('confNetwork'));
-
- if ($current_state ne 'notconfigured') {
- $menu->append($create_item->('wireless')) if $wireless_device;
- push @settings, $create_item->('chooseInterface');
- }
-
- push @settings, $create_item->('chooseProfile');
- if (defined $interactive) {
- $interactive_cb = gtkshow(gtksignal_connect(gtkset_active(Gtk2::CheckMenuItem->new_with_label(N("Interactive Firewall automatic mode")),
- !$interactive),
- toggled => sub { eval { $ifw->set_interactive(to_bool(!$_[0]->get_active)) } }));
- push @settings, $interactive_cb;
- }
- push @settings, gtkshow(gtksignal_connect(gtkset_active(Gtk2::CheckMenuItem->new_with_label(N("Always launch on startup")), getAutoStart()),
- toggled => sub { setAutoStart(uc(bool2text($_[0]->get_active))) }));
-
- $menu->append(gtkshow(Gtk2::SeparatorMenuItem->new));
- $wireless_device and $menu->append(gtkshow($wireless_menu = create_menu(N("Wireless networks"),
- map { $_->{menuitem} } values %wireless_networks)));
- if (my $set = $current_state ne 'notconfigured' && $create_item->('setInterface')) { $menu->append($set) }
- $menu->append(gtkshow(create_menu(N("Settings"), grep { $_ } @settings)));
- $menu->append(gtkshow(Gtk2::SeparatorMenuItem->new));
- $menu->append($create_item->('help'));
- $menu->append($create_item->('quit'));
- $menu;
-}
-sub mainQuit() {
- Glib::Source->remove($timeout) if $timeout;
- Glib::Source->remove($update_timeout) if $update_timeout;
- Gtk2->main_quit;
-}
-sub getAutoStart() {
- my %p = getVarsFromSh($onstartupfile);
- return to_bool($p{AUTOSTART} ne 'FALSE');
-}
-sub setAutoStart {
- my $state = shift;
- output_p $onstartupfile,
- qq(AUTOSTART=$state
-);
-}
-
-sub get_unprocessed_attacks() {
- my @packets = eval { $ifw->get_reports };
- while (my @attack = splice(@packets, 0, 10)) {
- handle_attack(@attack);
- }
-}
-
-sub handle_attack {
- my $attack = network::ifw::attack_to_hash(\@_);
- push @attacks_queue, $attack;
- @attacks_queue == 1 and notify_attack($attacks_queue[0]);
-}
-
-sub set_verdict {
- my ($attack, $apply_verdict) = @_;
- eval { $apply_verdict->($attack) };
- $@ and err_dialog(N("Interactive Firewall"), N("Unable to contact daemon"));
-
- shift @attacks_queue;
- #- wait for some time so that the new bubble is noticeable
- @attacks_queue and Glib::Timeout->add(500, sub { notify_attack($attacks_queue[0]); 0 });
-}
-
-sub apply_verdict_blacklist {
- my ($attack) = @_;
- $ifw->set_blacklist_verdict($attack->{seq}, 1);
-}
-
-sub apply_verdict_ignore {
- my ($attack) = @_;
- $ifw->set_blacklist_verdict($attack->{seq}, 0);
-}
-
-sub apply_verdict_whitelist {
- my ($attack) = @_;
- $ifw->whitelist($attack->{addr});
- apply_verdict_ignore($attack);
-}
-
-sub notify_attack {
- my ($attack) = @_;
- unless ($attack->{msg}) {
- print "unhandled attack type, skipping\n";
- return;
- }
- unless ($ifw_alert) {
- $ifw_alert = 1;
- update_tray_icon();
- Glib::Timeout->add(1000, sub {
- update_tray_icon();
- $ifw_alert;
- });
- }
- $bubble->set(N("Interactive Firewall"), Gtk2::Image->new_from_pixbuf($pixbufs{firewall}), $attack->{msg});
- $bubble->show(5000);
-}
-
-sub ask_attack_verdict {
- my ($attack) = @_;
-
- my $w = ugtk2->new(N("Interactive Firewall: intrusion detected"),
- icon => "/usr/lib/libDrakX/icons/drakfirewall.png");
- my ($blacklist, $whitelist, $ignore, $auto);
-
- my $update_automatic_mode = sub { $auto->get_active and $interactive_cb->set_active(1) };
-
- gtkadd($w->{window},
- gtknew('VBox', spacing => 5, children_loose => [
- gtknew('HBox', children => [
- 0, Gtk2::Image->new_from_stock('gtk-dialog-warning', 'dialog'),
- 0, gtknew('Label', text => " "),
- 1, gtknew('VBox', children => [
- 0, $attack->{msg},
- 0, N("What do you want to do with this attacker?")
- ])
- ]),
- gtksignal_connect(gtkadd(Gtk2::Expander->new(N("Attack details")),
- gtknew('HBox', children => [
- 0, gtknew('Label', text => " "),
- 1, gtknew('VBox', children_loose => [
- N("Attack time: %s", $attack->{date}),
- N("Network interface: %s", $attack->{indev}),
- N("Attack type: %s", $attack->{prefix}),
- if_($attack->{protocol}, N("Protocol: %s", $attack->{protocol})),
- N("Attacker IP address: %s", $attack->{ip_addr}),
- if_($attack->{hostname} ne $attack->{ip_addr}, N("Attacker hostname: %s", $attack->{hostname})),
- (
- $attack->{service} ne $attack->{port} ?
- N("Service attacked: %s", $attack->{service}) :
- N("Port attacked: %s", $attack->{port}),
- ),
- if_($attack->{icmp_type}, N("Type of ICMP attack: %s", $attack->{icmp_type}))
- ]),
- ])),
- activate => sub { $_[0]->get_expanded and $w->shrink_topwindow }
- ),
- $auto = gtknew('CheckButton', text => N("Always blacklist (do not ask again)"), toggled => sub {
- $whitelist->set_sensitive(!$_[0]->get_active);
- $ignore->set_sensitive(!$_[0]->get_active);
- }),
- gtknew('HButtonBox', layout => 'edge', children_loose => [
- $blacklist = gtknew('Button', text => N("Blacklist"), clicked => sub {
- $w->destroy;
- $update_automatic_mode->();
- set_verdict($attack, \&apply_verdict_blacklist);
- }),
- $whitelist = gtknew('Button', text => N("Whitelist"), clicked => sub {
- $w->destroy;
- $update_automatic_mode->();
- set_verdict($attack, \&apply_verdict_whitelist);
- }),
- $ignore = gtknew('Button', text => N("Ignore"), clicked => sub {
- $w->destroy;
- set_verdict($attack, \&apply_verdict_ignore);
- }),
- ]),
- ]));
- eval { $auto->set_active(!$ifw->get_interactive) };
- $blacklist->grab_focus;
- gtksignal_connect($w->{window}, delete_event => sub {
- set_verdict($attack, \&apply_verdict_ignore);
- });
- $w->{window}->show_all;
-}
generated by cgit v1.2.1 (git 2.21.0) at 2024-07-09 01:34:49 +0000
} SLang_free_slstring (sls); return 0; } /*}}}*/ int SLang_pop_slstring (char **s) /*{{{*/ { return SLclass_pop_ptr_obj (SLANG_STRING_TYPE, (VOID_STAR *)s); } /*}}}*/ /* if *data != 0, string should be freed upon use. */ int SLang_pop_string(char **s, int *data) /*{{{*/ { if (SLpop_string (s)) return -1; *data = 1; return 0; } /*}}}*/ int _SLang_push_slstring (char *s) { if (0 == SLclass_push_ptr_obj (SLANG_STRING_TYPE, (VOID_STAR)s)) return 0; SLang_free_slstring (s); return -1; } int _SLpush_alloced_slstring (char *s, unsigned int len) { if (NULL == (s = _SLcreate_via_alloced_slstring (s, len))) return -1; return _SLang_push_slstring (s); } int SLang_push_string (char *t) /*{{{*/ { if (t == NULL) return SLang_push_null (); if (NULL == (t = SLang_create_slstring (t))) return -1; return _SLang_push_slstring (t); } /*}}}*/ int _SLang_dup_and_push_slstring (char *s) { if (NULL == (s = _SLstring_dup_slstring (s))) return SLang_push_null (); return _SLang_push_slstring (s); } /* This function _always_ frees the malloced string */ int SLang_push_malloced_string (char *c) /*{{{*/ { int ret; ret = SLang_push_string (c); SLfree (c); return ret; } /*}}}*/ #if 0 static int int_int_power (int a, int b) { int r, s; if (a == 0) return 0; if (b < 0) return 0; if (b == 0) return 1; s = 1; if (a < 0) { if ((b % 2) == 1) s = -1; a = -a; } /* FIXME: Priority=low * This needs optimized */ r = 1; while (b) { r = r * a; b--; } return r * s; } #endif static int string_string_bin_op_result (int op, unsigned char a, unsigned char b, unsigned char *c) { (void) a; (void) b; switch (op) { default: return 0; case SLANG_PLUS: *c = SLANG_STRING_TYPE; break; case SLANG_GT: case SLANG_GE: case SLANG_LT: case SLANG_LE: case SLANG_EQ: case SLANG_NE: *c = SLANG_CHAR_TYPE; break; } return 1; } static int string_string_bin_op (int op, unsigned char a_type, VOID_STAR ap, unsigned int na, unsigned char b_type, VOID_STAR bp, unsigned int nb, VOID_STAR cp) { char *ic; char **a, **b, **c; unsigned int n, n_max; unsigned int da, db; (void) a_type; (void) b_type; if (na == 1) da = 0; else da = 1; if (nb == 1) db = 0; else db = 1; if (na > nb) n_max = na; else n_max = nb; a = (char **) ap; b = (char **) bp; for (n = 0; n < n_max; n++) { if ((*a == NULL) || (*b == NULL)) { SLang_verror (SL_VARIABLE_UNINITIALIZED, "String element[%u] not initialized for binary operation", n); return -1; } a += da; b += db; } a = (char **) ap; b = (char **) bp; ic = (char *) cp; c = NULL; switch (op) { case SLANG_DIVIDE: case SLANG_MINUS: default: return 0; case SLANG_PLUS: /* Concat */ c = (char **) cp; for (n = 0; n < n_max; n++) { if (NULL == (c[n] = SLang_concat_slstrings (*a, *b))) goto return_error; a += da; b += db; } break; case SLANG_NE: for (n = 0; n < n_max; n++) { ic [n] = (0 != strcmp (*a, *b)); a += da; b += db; } break; case SLANG_GT: for (n = 0; n < n_max; n++) { ic [n] = (strcmp (*a, *b) > 0); a += da; b += db; } break; case SLANG_GE: for (n = 0; n < n_max; n++) { ic [n] = (strcmp (*a, *b) >= 0); a += da; b += db; } break; case SLANG_LT: for (n = 0; n < n_max; n++) { ic [n] = (strcmp (*a, *b) < 0); a += da; b += db; } break; case SLANG_LE: for (n = 0; n < n_max; n++) { ic [n] = (strcmp (*a, *b) <= 0); a += da; b += db; } break; case SLANG_EQ: for (n = 0; n < n_max; n++) { ic [n] = (strcmp (*a, *b) == 0); a += da; b += db; } break; } return 1; return_error: if (c != NULL) { unsigned int nn; for (nn = 0; nn < n; nn++) { SLang_free_slstring (c[nn]); c[nn] = NULL; } for (nn = n; nn < n_max; nn++) c[nn] = NULL; } return -1; } static void string_destroy (unsigned char unused, VOID_STAR s) { (void) unused; SLang_free_slstring (*(char **) s); } static int string_push (unsigned char unused, VOID_STAR sptr) { (void) unused; return SLang_push_string (*(char **) sptr); } static int string_cmp (unsigned char unused, VOID_STAR ap, VOID_STAR bp, int *c) { char *a, *b; (void) unused; a = *(char **) ap; b = *(char **) bp; if (a != b) { if (a == NULL) *c = -1; else if (b == NULL) *c = 1; else *c = strcmp (a, b); return 0; } *c = 0; return 0; } static int string_to_int (unsigned char a_type, VOID_STAR ap, unsigned int na, unsigned char b_type, VOID_STAR bp) { char **s; unsigned int i; int *b; (void) a_type; (void) b_type; s = (char **) ap; b = (int *) bp; for (i = 0; i < na; i++) { if (s[i] == NULL) b[i] = 0; else b[i] = s[i][0]; } return 1; } struct _SLang_Foreach_Context_Type { char *string; unsigned int n; }; static SLang_Foreach_Context_Type * string_foreach_open (unsigned char type, unsigned int num) { char *s; SLang_Foreach_Context_Type *c; (void) type; if (num != 0) { SLang_verror (SL_NOT_IMPLEMENTED, "'foreach using' form not supported by String_Type"); SLdo_pop_n (num + 1); return NULL; } if (-1 == SLang_pop_slstring (&s)) return NULL; c = (SLang_Foreach_Context_Type *)SLmalloc (sizeof (SLang_Foreach_Context_Type)); if (c == NULL) { SLang_free_slstring (s); return NULL; } memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type)); c->string = s; return c; } static void string_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) { (void) type; if (c == NULL) return; SLang_free_slstring (c->string); SLfree ((char *) c); } static int string_foreach (unsigned char type, SLang_Foreach_Context_Type *c) { char ch; (void) type; ch = c->string[c->n]; if (ch == 0) return 0; /* done */ c->n += 1; if (-1 == SLclass_push_int_obj (SLANG_INT_TYPE, ch)) return -1; return 1; } int _SLstring_list_push (_SLString_List_Type *p) { unsigned int num; int inum; SLang_Array_Type *at; char **buf; if ((buf = p->buf) == NULL) return SLang_push_null (); num = p->num; inum = (int) num; if (num == 0) num++; if (num != p->max_num) { if (NULL == (buf = (char **)SLrealloc ((char *) buf, sizeof (char *) * num))) { _SLstring_list_delete (p); return -1; } p->max_num = num; p->buf = buf; } if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) buf, &inum, 1))) { _SLstring_list_delete (p); return -1; } p->buf = NULL; _SLstring_list_delete (p); return SLang_push_array (at, 1); } int _SLstring_list_init (_SLString_List_Type *p, unsigned int max_num, unsigned int delta_num) { if (NULL == (p->buf = (char **) SLmalloc (max_num * sizeof (char *)))) return -1; p->max_num = max_num; p->num = 0; p->delta_num = delta_num; return 0; } int _SLstring_list_append (_SLString_List_Type *p, char *s) { if (s == NULL) { _SLstring_list_delete (p); return -1; } if (p->max_num == p->num) { char **b; unsigned int max_num = p->num + p->delta_num; b = (char **)SLrealloc ((char *)p->buf, max_num * sizeof (char *)); if (b == NULL) { _SLstring_list_delete (p); SLang_free_slstring (s); return -1; } p->buf = b; p->max_num = max_num; } p->buf[p->num] = s; p->num++; return 0; } void _SLstring_list_delete (_SLString_List_Type *p) { if (p->buf != NULL) { unsigned int i, imax; char **buf = p->buf; imax = p->num; for (i = 0; i < imax; i++) SLang_free_slstring (buf[i]); SLfree ((char *)buf); p->buf = NULL; } } /* Ref type */ int SLang_pop_ref (SLang_Ref_Type **ref) { return SLclass_pop_ptr_obj (SLANG_REF_TYPE, (VOID_STAR *)ref); } /* Note: This is ok if ptr is NULL. Some routines rely on this behavior */ int _SLang_push_ref (int is_global, VOID_STAR ptr) { SLang_Ref_Type *r; if (ptr == NULL) return SLang_push_null (); r = (SLang_Ref_Type *) SLmalloc (sizeof (SLang_Ref_Type)); if (r == NULL) return -1; r->is_global = is_global; r->v.nt = (SLang_Name_Type *) ptr; if (-1 == SLclass_push_ptr_obj (SLANG_REF_TYPE, (VOID_STAR) r)) { SLfree ((char *) r); return -1; } return 0; } static void ref_destroy (unsigned char type, VOID_STAR ptr) { (void) type; SLfree ((char *) *(SLang_Ref_Type **)ptr); } void SLang_free_ref (SLang_Ref_Type *ref) { SLfree ((char *) ref); } static int ref_push (unsigned char type, VOID_STAR ptr) { SLang_Ref_Type *ref; (void) type; ref = *(SLang_Ref_Type **) ptr; if (ref == NULL) return SLang_push_null (); return _SLang_push_ref (ref->is_global, (VOID_STAR) ref->v.nt); } int SLang_assign_to_ref (SLang_Ref_Type *ref, unsigned char type, VOID_STAR v) { SLang_Object_Type *stkptr; SLang_Class_Type *cl; cl = _SLclass_get_class (type); /* Use apush since this function is passing ``array'' bytes rather than the * address of the data. I need to somehow make this more consistent. To * see what I mean, consider: * * double z[2]; * char *s = "silly"; * int i; * * SLang_assign_to_ref (ref, SLANG_INT_TYPE, &i); * SLang_assign_to_ref (ref, SLANG_STRING_TYPE, &s); * SLang_assign_to_ref (ref, SLANG_COMPLEX_TYPE, z); * * That is, all external routines that take a VOID_STAR argument need to * be documented such that how the function should be called with the * various class_types. */ if (-1 == (*cl->cl_apush) (type, v)) return -1; stkptr = _SLStack_Pointer; if (0 == _SLang_deref_assign (ref)) return 0; if (stkptr != _SLStack_Pointer) SLdo_pop (); return -1; } static char *ref_string (unsigned char type, VOID_STAR ptr) { SLang_Ref_Type *ref; (void) type; ref = *(SLang_Ref_Type **) ptr; if (ref->is_global) { char *name, *s; name = ref->v.nt->name; if ((name != NULL) && (NULL != (s = SLmalloc (strlen(name) + 2)))) { *s = '&'; strcpy (s + 1, name); return s; } return NULL; } return SLmake_string ("Local Variable Reference"); } static int ref_dereference (unsigned char unused, VOID_STAR ptr) { (void) unused; return _SLang_dereference_ref (*(SLang_Ref_Type **) ptr); } static int ref_cmp (unsigned char type, VOID_STAR a, VOID_STAR b, int *c) { SLang_Ref_Type *ra, *rb; (void) type; ra = *(SLang_Ref_Type **)a; rb = *(SLang_Ref_Type **)b; if (ra == NULL) { if (rb == NULL) *c = 0; else *c = -1; return 0; } if (rb == NULL) { *c = 1; return 0; } if (ra->v.nt == rb->v.nt) *c = 0; else *c = strcmp (ra->v.nt->name, rb->v.nt->name); return 0; } SLang_Name_Type *SLang_pop_function (void) { SLang_Ref_Type *ref; SLang_Name_Type *f; if (SLang_peek_at_stack () == SLANG_STRING_TYPE) { char *name; if (-1 == SLang_pop_slstring (&name)) return NULL; if (NULL == (f = SLang_get_function (name))) { SLang_verror (SL_UNDEFINED_NAME, "Function %s does not exist", name); SLang_free_slstring (name); return NULL; } SLang_free_slstring (name); return f; } if (-1 == SLang_pop_ref (&ref)) return NULL; f = SLang_get_fun_from_ref (ref); SLang_free_ref (ref); return f; } /* This is a placeholder for version 2 */ void SLang_free_function (SLang_Name_Type *f) { (void) f; } /* NULL type */ int SLang_push_null (void) { return SLclass_push_ptr_obj (SLANG_NULL_TYPE, NULL); } int SLang_pop_null (void) { SLang_Object_Type obj; return _SLang_pop_object_of_type (SLANG_NULL_TYPE, &obj, 0); } static int null_push (unsigned char unused, VOID_STAR ptr_unused) { (void) unused; (void) ptr_unused; return SLang_push_null (); } static int null_pop (unsigned char type, VOID_STAR ptr) { (void) type; if (-1 == SLang_pop_null ()) return -1; *(char **) ptr = NULL; return 0; } /* Implement foreach (NULL) using (whatever) to do nothing. This is useful * because suppose that X is a list but is NULL in some situations. Then * when it is NULL, we want foreach(X) to do nothing. */ static SLang_Foreach_Context_Type * null_foreach_open (unsigned char type, unsigned int num) { (void) type; SLdo_pop_n (num + 1); return (SLang_Foreach_Context_Type *)1; } static void null_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c) { (void) type; (void) c; } static int null_foreach (unsigned char type, SLang_Foreach_Context_Type *c) { (void) type; (void) c; return 0; } static int null_to_bool (unsigned char type, int *t) { (void) type; *t = 0; return SLang_pop_null (); } /* AnyType */ int _SLanytype_typecast (unsigned char a_type, VOID_STAR ap, unsigned int na, unsigned char b_type, VOID_STAR bp) { SLang_Class_Type *cl; SLang_Any_Type **any; unsigned int i; unsigned int sizeof_type; (void) b_type; any = (SLang_Any_Type **) bp; cl = _SLclass_get_class (a_type); sizeof_type = cl->cl_sizeof_type; for (i = 0; i < na; i++) { if ((-1 == (*cl->cl_apush) (a_type, ap)) || (-1 == SLang_pop_anytype (&any[i]))) { while (i != 0) { i--; SLang_free_anytype (any[i]); any[i] = NULL; } return -1; } ap = (VOID_STAR)((char *)ap + sizeof_type); } return 1; } int SLang_pop_anytype (SLang_Any_Type **any) { SLang_Object_Type *obj; *any = NULL; if (NULL == (obj = (SLang_Object_Type *) SLmalloc (sizeof (SLang_Object_Type)))) return -1; if (-1 == SLang_pop (obj)) { SLfree ((char *) obj); return -1; } *any = (SLang_Any_Type *)obj; return 0; } /* This function will result in an object that is represented by the * anytype object. */ int SLang_push_anytype (SLang_Any_Type *any) { return _SLpush_slang_obj ((SLang_Object_Type *)any); } /* After this call, the stack will contain an Any_Type object */ static int anytype_push (unsigned char type, VOID_STAR ptr) { SLang_Any_Type *obj; /* Push the object onto the stack, then pop it back off into our anytype * container. That way, any memory managing associated with the type * will be performed automatically. Another way to think of it is that * pushing an Any_Type onto the stack will create another copy of the * object represented by it. */ if (-1 == _SLpush_slang_obj (*(SLang_Object_Type **)ptr)) return -1; if (-1 == SLang_pop_anytype (&obj)) return -1; /* There is no need to reference count the anytype objects since every * push results in a new anytype container. */ if (-1 == SLclass_push_ptr_obj (type, (VOID_STAR) obj)) { SLang_free_anytype (obj); return -1; } return 0; } static void anytype_destroy (unsigned char type, VOID_STAR ptr) { SLang_Object_Type *obj; (void) type; obj = *(SLang_Object_Type **)ptr; SLang_free_object (obj); SLfree ((char *) obj); } void SLang_free_anytype (SLang_Any_Type *any) { if (any != NULL) anytype_destroy (SLANG_ANY_TYPE, (VOID_STAR) &any); } static int anytype_dereference (unsigned char unused, VOID_STAR ptr) { (void) unused; return _SLpush_slang_obj (*(SLang_Object_Type **) ptr); } /* SLANG_INTP_TYPE */ static int intp_push (unsigned char unused, VOID_STAR ptr) { (void) unused; return SLclass_push_int_obj (SLANG_INT_TYPE, **(int **)ptr); } static int intp_pop (unsigned char unused, VOID_STAR ptr) { (void) unused; return SLang_pop_integer (*(int **) ptr); } static int undefined_push (unsigned char t, VOID_STAR p) { (void) t; (void) p; if (SLang_Error == 0) SLang_Error = SL_VARIABLE_UNINITIALIZED; return -1; } int _SLregister_types (void) { SLang_Class_Type *cl; /* A good compiler should optimize this code away. */ if ((sizeof(short) != SIZEOF_SHORT) || (sizeof(int) != SIZEOF_INT) || (sizeof(long) != SIZEOF_LONG) || (sizeof(float) != SIZEOF_FLOAT) || (sizeof(double) != SIZEOF_DOUBLE)) SLang_exit_error ("S-Lang Library not built properly. Fix SIZEOF_* in config.h and recompile"); if (-1 == _SLclass_init ()) return -1; /* Undefined Type */ if (NULL == (cl = SLclass_allocate_class ("Undefined_Type"))) return -1; (void) SLclass_set_push_function (cl, undefined_push); (void) SLclass_set_pop_function (cl, undefined_push); if (-1 == SLclass_register_class (cl, SLANG_UNDEFINED_TYPE, sizeof (int), SLANG_CLASS_TYPE_SCALAR)) return -1; /* Make Void_Type a synonym for Undefined_Type. Note that this does * not mean that Void_Type represents SLANG_VOID_TYPE. Void_Type is * used by array_map to indicate no array is to be created. */ if (-1 == SLclass_create_synonym ("Void_Type", SLANG_UNDEFINED_TYPE)) return -1; if (-1 == _SLarith_register_types ()) return -1; /* SLANG_INTP_TYPE */ if (NULL == (cl = SLclass_allocate_class ("_IntegerP_Type"))) return -1;